pax_global_header00006660000000000000000000000064147551256530014527gustar00rootroot0000000000000052 comment=dd94f771ef78f68b54ad12c2cf81d3b921565a6d coqeal-2.1.0/000077500000000000000000000000001475512565300127735ustar00rootroot00000000000000coqeal-2.1.0/.github/000077500000000000000000000000001475512565300143335ustar00rootroot00000000000000coqeal-2.1.0/.github/workflows/000077500000000000000000000000001475512565300163705ustar00rootroot00000000000000coqeal-2.1.0/.github/workflows/docker-action.yml000066400000000000000000000016711475512565300216420ustar00rootroot00000000000000# This file was generated from `meta.yml`, please do not edit manually. # Follow the instructions on https://github.com/coq-community/templates to regenerate. name: Docker CI on: push: branches: - master pull_request: branches: - '**' jobs: build: # the OS must be GNU/Linux to be able to use the docker-coq-action runs-on: ubuntu-latest strategy: matrix: image: - 'mathcomp/mathcomp:2.3.0-coq-8.20' - 'mathcomp/mathcomp:2.3.0-coq-dev' - 'mathcomp/mathcomp-dev:coq-8.20' - 'mathcomp/mathcomp-dev:rocq-prover-dev' fail-fast: false steps: - uses: actions/checkout@v4 - uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-coqeal.opam' custom_image: ${{ matrix.image }} # See also: # https://github.com/coq-community/docker-coq-action#readme # https://github.com/erikmd/docker-coq-github-action-demo coqeal-2.1.0/.github/workflows/nix-action-coq-8.20.yml000066400000000000000000001723151475512565300223420ustar00rootroot00000000000000jobs: bignums: needs: - coq - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (bignums) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"bignums\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "bignums" coq: needs: [] runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"coq\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" coq-elpi: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq-elpi) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"coq-elpi\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq-elpi" coqeal: needs: - coq - mathcomp-algebra - bignums - multinomials - mathcomp-real-closed runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coqeal) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"coqeal\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: bignums' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "bignums" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: multinomials' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "multinomials" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coqeal" hierarchy-builder: needs: - coq - coq-elpi - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (hierarchy-builder) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"hierarchy-builder\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "hierarchy-builder" mathcomp: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-character' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-character" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - stdlib - mathcomp-ssreflect - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-algebra\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" mathcomp-algebra-tactics: needs: - coq - mathcomp-algebra - coq-elpi - mathcomp-zify runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra-tactics) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra-tactics" mathcomp-apery: needs: - coq - mathcomp-field - coqeal - mathcomp-real-closed - mathcomp-bigenough - mathcomp-zify - mathcomp-algebra-tactics runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-apery) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-apery\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coqeal' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coqeal" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra-tactics' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra-tactics" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-apery" mathcomp-bigenough: needs: - coq - mathcomp-ssreflect runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-bigenough) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-bigenough\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-bigenough" mathcomp-field: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-field) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-field\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-field" mathcomp-finmap: needs: - coq - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-finmap) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-finmap\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-bigenough - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-real-closed) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-real-closed\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-real-closed" mathcomp-ssreflect: needs: - coq - stdlib - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-ssreflect) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-ssreflect\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" mathcomp-zify: needs: - coq - mathcomp-algebra - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-zify) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-zify\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-zify" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-bigenough runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (multinomials) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"multinomials\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-finmap' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-finmap" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "multinomials" stdlib: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (stdlib) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"stdlib\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" name: Nix CI for bundle coq-8.20 on: pull_request: paths: - .github/workflows/nix-action-coq-8.20.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-8.20.yml types: - opened - synchronize - reopened push: branches: - master coqeal-2.1.0/.github/workflows/nix-action-coq-master.yml000066400000000000000000001726551475512565300232550ustar00rootroot00000000000000jobs: bignums: needs: - coq - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (bignums) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"bignums\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "bignums" coq: needs: [] runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"coq\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" coq-elpi: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq-elpi) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"coq-elpi\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq-elpi" coqeal: needs: - coq - mathcomp-algebra - bignums - multinomials - mathcomp-real-closed runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coqeal) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"coqeal\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: bignums' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "bignums" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: multinomials' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "multinomials" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coqeal" hierarchy-builder: needs: - coq - coq-elpi - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (hierarchy-builder) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"hierarchy-builder\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "hierarchy-builder" mathcomp: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-character' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-character" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - stdlib - mathcomp-ssreflect - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-algebra\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" mathcomp-algebra-tactics: needs: - coq - mathcomp-algebra - coq-elpi - mathcomp-zify runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra-tactics) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra-tactics" mathcomp-apery: needs: - coq - mathcomp-field - coqeal - mathcomp-real-closed - mathcomp-bigenough - mathcomp-zify - mathcomp-algebra-tactics runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-apery) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-apery\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coqeal' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coqeal" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra-tactics' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra-tactics" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-apery" mathcomp-bigenough: needs: - coq - mathcomp-ssreflect runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-bigenough) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-bigenough\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-bigenough" mathcomp-field: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-field) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-field\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-field" mathcomp-finmap: needs: - coq - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-finmap) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-finmap\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-bigenough - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-real-closed) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-real-closed\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-real-closed" mathcomp-ssreflect: needs: - coq - stdlib - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-ssreflect) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-ssreflect\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" mathcomp-zify: needs: - coq - mathcomp-algebra - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-zify) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-zify\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-zify" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-bigenough runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (multinomials) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"multinomials\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-finmap' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-finmap" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "multinomials" stdlib: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (stdlib) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"stdlib\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" name: Nix CI for bundle coq-master on: pull_request: paths: - .github/workflows/nix-action-coq-master.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-master.yml types: - opened - synchronize - reopened push: branches: - master coqeal-2.1.0/.github/workflows/nix-action-rocq-9.0.yml000066400000000000000000001723151475512565300224430ustar00rootroot00000000000000jobs: bignums: needs: - coq - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (bignums) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"bignums\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "bignums" coq: needs: [] runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"coq\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" coq-elpi: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coq-elpi) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"coq-elpi\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq-elpi" coqeal: needs: - coq - mathcomp-algebra - bignums - multinomials - mathcomp-real-closed runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (coqeal) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"coqeal\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: bignums' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "bignums" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: multinomials' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "multinomials" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coqeal" hierarchy-builder: needs: - coq - coq-elpi - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (hierarchy-builder) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"hierarchy-builder\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "hierarchy-builder" mathcomp: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-character' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-character" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - stdlib - mathcomp-ssreflect - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-algebra\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" mathcomp-algebra-tactics: needs: - coq - mathcomp-algebra - coq-elpi - mathcomp-zify runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-algebra-tactics) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-algebra-tactics\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq-elpi" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra-tactics" mathcomp-apery: needs: - coq - mathcomp-field - coqeal - mathcomp-real-closed - mathcomp-bigenough - mathcomp-zify - mathcomp-algebra-tactics runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-apery) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-apery\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coqeal' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coqeal" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-real-closed" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-zify' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-zify" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra-tactics' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra-tactics" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-apery" mathcomp-bigenough: needs: - coq - mathcomp-ssreflect runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-bigenough) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-bigenough\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-bigenough" mathcomp-field: needs: - coq - stdlib - mathcomp-ssreflect - mathcomp-algebra - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-field) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-field\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-field" mathcomp-finmap: needs: - coq - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-finmap) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-finmap\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-bigenough - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-real-closed) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-real-closed\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-real-closed" mathcomp-ssreflect: needs: - coq - stdlib - hierarchy-builder - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-ssreflect) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-ssreflect\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "hierarchy-builder" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" mathcomp-zify: needs: - coq - mathcomp-algebra - mathcomp-ssreflect - stdlib runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (mathcomp-zify) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"mathcomp-zify\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-zify" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-bigenough runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (multinomials) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"multinomials\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-finmap' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-finmap" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "multinomials" stdlib: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.target_commit }} - name: Determine which commit to test run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge | cut -f1)\n mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n if [ -z \"$merge_commit\"\ \ -o \"x$mergeable\" != \"x0\" ]; then\n echo \"tested_commit=${{ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n\ \ fi\nfi\n" - name: Git checkout uses: actions/checkout@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-community uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, math-comp name: coq-community - id: stepGetDerivation name: Getting derivation for current job (stdlib) run: "NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"rocq-9.0\" --argstr job \"stdlib\" \\\n --dry-run 2> err > out || (touch fail; true)\n" - name: Error reporting run: "echo \"out=\"; cat out\necho \"err=\"; cat err\n" - name: Failure check run: if [ -e fail ]; then exit 1; else exit 0; fi; - id: stepCheck name: Checking presence of CI target for current job run: (echo -n status=; cat out err | grep "built:" | sed "s/.*/built/") >> $GITHUB_OUTPUT - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: Building/fetching current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "rocq-9.0" --argstr job "stdlib" name: Nix CI for bundle rocq-9.0 on: pull_request: paths: - .github/workflows/nix-action-rocq-9.0.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-rocq-9.0.yml types: - opened - synchronize - reopened push: branches: - master coqeal-2.1.0/.gitignore000066400000000000000000000001601475512565300147600ustar00rootroot00000000000000*.d *.glob *.vo *.vos *.vok *.cmo *.cma *.cmx *.cmxs *.cmi *.o *.native *.aux Makefile.coq Makefile.coq.conf *~ coqeal-2.1.0/.nix/000077500000000000000000000000001475512565300136475ustar00rootroot00000000000000coqeal-2.1.0/.nix/config.nix000066400000000000000000000133611475512565300156400ustar00rootroot00000000000000{ ## DO NOT CHANGE THIS format = "1.0.0"; ## unless you made an automated or manual update ## to another supported format. ## The attribute to build, either from nixpkgs ## of from the overlays located in `.nix/coq-overlays` attribute = "coqeal"; ## If you want to select a different attribute ## to serve as a basis for nix-shell edit this # shell-attribute = "{{nix_name}}"; ## Maybe the shortname of the library is different from ## the name of the nixpkgs attribute, if so, set it here: # pname = "{{shortname}}"; ## Lists the dependencies, phrased in terms of nix attributes. ## No need to list Coq, it is already included. ## These dependencies will systematically be added to the currently ## known dependencies, if any more than Coq. ## /!\ Remove this field as soon as the package is available on nixpkgs. ## /!\ Manual overlays in `.nix/coq-overlays` should be preferred then. # buildInputs = [ ]; ## Indicate the relative location of your _CoqProject ## If not specified, it defaults to "_CoqProject" # coqproject = "_CoqProject"; ## Cachix caches to use in CI ## Below we list some standard ones cachix.coq = {}; cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; cachix.math-comp = {}; ## If you have write access to one of these caches you can ## provide the auth token or signing key through a secret ## variable on GitHub. Then, you should give the variable ## name here. For instance, coq-community projects can use ## the following line instead of the one above: # cachix.coq-community.authToken = "CACHIX_AUTH_TOKEN"; ## Or if you have a signing key for a given Cachix cache: # cachix.my-cache.signingKey = "CACHIX_SIGNING_KEY" ## Note that here, CACHIX_AUTH_TOKEN and CACHIX_SIGNING_KEY ## are the names of secret variables. They are set in ## GitHub's web interface. ## select an entry to build in the following `bundles` set ## defaults to "default" default-bundle = "coq-8.20"; ## write one `bundles.name` attribute set per ## alternative configuration, the can be used to ## compute several ci jobs as well bundles = let ## You can override Coq and other Coq coqPackages ## through the following attribute # coqPackages.coq.override.version = "8.11"; ## In some cases, light overrides are not available/enough ## in which case you can use either # coqPackages..overrideAttrs = o: ; ## or a "long" overlay to put in `.nix/coq-overlays ## you may use `nix-shell --run fetchOverlay ` ## to automatically retrieve the one from nixpkgs ## if it exists and is correctly named/located ## You can override Coq and other Coq coqPackages ## throught the following attribute ## If does not support lights overrides, ## you may use `overrideAttrs` or long overlays ## located in `.nix/ocaml-overlays` ## (there is no automation for this one) # ocamlPackages..override.version = "x.xx"; ## You can also override packages from the nixpkgs toplevel # .override.overrideAttrs = o: ; ## Or put an overlay in `.nix/overlays` ## you may mark a package as a CI job as follows # coqPackages..ci.job = "test"; ## It can then be built throught ## nix-build --argstr ci "default" --arg ci-job "test"; common-bundles = { mathcomp-ssreflect.job = true; mathcomp-algebra.job = true; mathcomp-field.job = true; mathcomp-finmap.job = true; mathcomp-bigenough.job = true; multinomials.job = true; mathcomp-real-closed.job = true; mathcomp-zify.job = true; mathcomp-algebra-tactics.job = true; mathcomp-apery.override.version = "master"; # reverse dependency of coqeal stdlib.job = true; bignums.job = true; interval.job = false; coquelicot.job = false; # To add an overlay applying to all bundles, # add below a line like #.override.version = ":"; # where # * will typically be one of the strings above (without the quotes) # or look at https://github.com/NixOS/nixpkgs/tree/master/pkgs/development/coq-modules # for a complete list of Coq packages available in Nix # * : is such that this will use the branch # from https://github.com// }; in { "coq-master" = { rocqPackages = { rocq-core.override.version = "master"; stdlib.override.version = "master"; bignums.override.version = "master"; rocq-elpi.override.version = "master"; rocq-elpi.override.elpi-version = "2.0.7"; }; coqPackages = common-bundles // { coq.override.version = "master"; stdlib.override.version = "master"; bignums.override.version = "master"; coq-elpi.override.version = "master"; coq-elpi.override.elpi-version = "2.0.7"; hierarchy-builder.override.version = "master"; mathcomp.override.version = "master"; mathcomp-finmap.override.version = "master"; mathcomp-bigenough.override.version = "master"; multinomials.override.version = "master"; mathcomp-real-closed.override.version = "master"; mathcomp-zify.override.version = "master"; mathcomp-algebra-tactics.override.version = "master"; }; }; "rocq-9.0".coqPackages = common-bundles // { coq.override.version = "9.0"; coq-elpi.job = true; hierarchy-builder.job = true; mathcomp.override.version = "2.3.0"; multinomials.override.version = "2.3.0"; }; "coq-8.20".coqPackages = common-bundles // { coq.override.version = "8.20"; coq-elpi.override.version = "2.5.0"; coq-elpi.override.elpi-version = "2.0.7"; hierarchy-builder.override.version = "1.8.1"; mathcomp.override.version = "2.3.0"; }; }; } coqeal-2.1.0/.nix/coq-nix-toolbox.nix000066400000000000000000000000531475512565300174270ustar00rootroot00000000000000"249b84ba5526b5b8c49f236923d595c8505717f2" coqeal-2.1.0/.nix/coq-overlays/000077500000000000000000000000001475512565300162735ustar00rootroot00000000000000coqeal-2.1.0/.nix/coq-overlays/coq-elpi/000077500000000000000000000000001475512565300200045ustar00rootroot00000000000000coqeal-2.1.0/.nix/coq-overlays/coq-elpi/default.nix000066400000000000000000000147161475512565300221610ustar00rootroot00000000000000{ lib, mkCoqDerivation, which, coq, rocqPackages, stdlib, version ? null, elpi-version ? null, }: let default-elpi-version = if elpi-version != null then elpi-version else ( lib.switch coq.coq-version [ { case = "8.11"; out = "1.11.4"; } { case = "8.12"; out = "1.12.0"; } { case = "8.13"; out = "1.13.7"; } { case = "8.14"; out = "1.13.7"; } { case = "8.15"; out = "1.15.0"; } { case = "8.16"; out = "1.17.0"; } { case = "8.17"; out = "1.17.0"; } { case = "8.18"; out = "1.18.1"; } { case = "8.19"; out = "1.18.1"; } { case = "8.20"; out = "1.19.2"; } { case = "9.0"; out = "2.0.7"; } ] { } ); elpi = coq.ocamlPackages.elpi.override { version = default-elpi-version; }; propagatedBuildInputs_wo_elpi = [ coq.ocamlPackages.findlib ]; derivation = mkCoqDerivation { pname = "elpi"; repo = "coq-elpi"; owner = "LPCIC"; inherit version; defaultVersion = lib.switch coq.coq-version [ { case = "9.0"; out = "2.5.0"; } { case = "8.20"; out = "2.2.0"; } { case = "8.19"; out = "2.0.1"; } { case = "8.18"; out = "2.0.0"; } { case = "8.17"; out = "1.18.0"; } { case = "8.16"; out = "1.15.6"; } { case = "8.15"; out = "1.14.0"; } { case = "8.14"; out = "1.11.2"; } { case = "8.13"; out = "1.11.1"; } { case = "8.12"; out = "1.8.3_8.12"; } { case = "8.11"; out = "1.6.3_8.11"; } ] null; release."2.5.0".sha256 = "sha256-Z5xjO83X/ZoTQlWnVupGXPH3HuJefr57Kv128I0dltg="; release."2.4.0".sha256 = "sha256-W2+vVGExLLux8e0nSZESSoMVvrLxhL6dmXkb+JuKiqc="; release."2.2.0".sha256 = "sha256-rADEoqTXM7/TyYkUKsmCFfj6fjpWdnZEOK++5oLfC/I="; release."2.0.1".sha256 = "sha256-cuoPsEJ+JRLVc9Golt2rJj4P7lKltTrrmQijjoViooc="; release."2.0.0".sha256 = "sha256-A/cH324M21k3SZ7+YWXtaYEbu6dZQq3K0cb1RMKjbsM="; release."1.19.0".sha256 = "sha256-kGoo61nJxeG/BqV+iQaV3iinwPStND+7+fYMxFkiKrQ="; release."1.18.0".sha256 = "sha256-2fCOlhqi4YkiL5n8SYHuc3pLH+DArf9zuMH7IhpBc2Y="; release."1.17.0".sha256 = "sha256-J8GatRKFU0ekNCG3V5dBI+FXypeHcLgC5QJYGYzFiEM="; release."1.15.6".sha256 = "sha256-qc0q01tW8NVm83801HHOBHe/7H1/F2WGDbKO6nCXfno="; release."1.15.1".sha256 = "sha256-NT2RlcIsFB9AvBhMxil4ZZIgx+KusMqDflj2HgQxsZg="; release."1.14.0".sha256 = "sha256:1v2p5dlpviwzky2i14cj7gcgf8cr0j54bdm9fl5iz1ckx60j6nvp"; release."1.13.0".sha256 = "1j7s7dlnjbw222gnbrsjgmjck1yrx7h6hwm8zikcyxi0zys17w7n"; release."1.12.1".sha256 = "sha256-4mO6/co7NcIQSGIQJyoO8lNWXr6dqz+bIYPO/G0cPkY="; release."1.11.2".sha256 = "0qk5cfh15y2zrja7267629dybd3irvxk1raz7z8qfir25a81ckd4"; release."1.11.1".sha256 = "10j076vc2hdcbm15m6s7b6xdzibgfcbzlkgjnlkr2vv9k13qf8kc"; release."1.10.1".sha256 = "1zsyx26dvj7pznfd2msl2w7zbw51q1nsdw0bdvdha6dga7ijf7xk"; release."1.9.7".sha256 = "0rvn12h9dpk9s4pxy32p8j0a1h7ib7kg98iv1cbrdg25y5vs85n1"; release."1.9.5".sha256 = "0gjdwmb6bvb5gh0a6ra48bz5fb3pr5kpxijb7a8mfydvar5i9qr6"; release."1.9.4".sha256 = "0nii7238mya74f9g6147qmpg6gv6ic9b54x5v85nb6q60d9jh0jq"; release."1.9.3".sha256 = "198irm800fx3n8n56vx1c6f626cizp1d7jfkrc6ba4iqhb62ma0z"; release."1.9.2".sha256 = "1rr2fr8vjkc0is7vh1461aidz2iwkigdkp6bqss4hhv0c3ijnn07"; release."1.8.3_8.12".sha256 = "15z2l4zy0qpw0ws7bvsmpmyv543aqghrfnl48nlwzn9q0v89p557"; release."1.8.3_8.12".version = "1.8.3"; release."1.8.2_8.12".sha256 = "1n6jwcdazvjgj8vsv2r9zgwpw5yqr5a1ndc2pwhmhqfl04b5dk4y"; release."1.8.2_8.12".version = "1.8.2"; release."1.8.1".sha256 = "1fbbdccdmr8g4wwpihzp4r2xacynjznf817lhijw6kqfav75zd0r"; release."1.8.0".sha256 = "13ywjg94zkbki22hx7s4gfm9rr87r4ghsgan23xyl3l9z8q0idd1"; release."1.7.0".sha256 = "1ws5cqr0xawv69prgygbl3q6dgglbaw0vc397h9flh90kxaqgyh8"; release."1.6.3_8.11".sha256 = "1j340cr2bv95clzzkkfmsjkklham1mj84cmiyprzwv20q89zr1hp"; release."1.6.3_8.11".version = "1.6.3"; release."1.6.2_8.11".sha256 = "06xrx0ljilwp63ik2sxxr7h617dgbch042xfcnfpy5x96br147rn"; release."1.6.2_8.11".version = "1.6.2"; release."1.6.1_8.11".sha256 = "0yyyh35i1nb3pg4hw7cak15kj4y6y9l84nwar9k1ifdsagh5zq53"; release."1.6.1_8.11".version = "1.6.1"; release."1.6.0_8.11".sha256 = "0ahxjnzmd7kl3gl38kyjqzkfgllncr2ybnw8bvgrc6iddgga7bpq"; release."1.6.0_8.11".version = "1.6.0"; release."1.6.0".sha256 = "0kf99i43mlf750fr7fric764mm495a53mg5kahnbp6zcjcxxrm0b"; releaseRev = v: "v${v}"; buildFlags = [ "OCAMLWARN=" ]; mlPlugin = true; useDuneifVersion = v: lib.versions.isGe "2.2.0" v || v == "dev"; propagatedBuildInputs = propagatedBuildInputs_wo_elpi ++ [ elpi ]; preConfigure = '' make elpi/dune || true ''; meta = { description = "Coq plugin embedding ELPI"; maintainers = [ lib.maintainers.cohencyril ]; license = lib.licenses.lgpl21Plus; }; }; patched-derivation1 = derivation.overrideAttrs ( o: lib.optionalAttrs (o ? elpi-version) { propagatedBuildInputs = propagatedBuildInputs_wo_elpi ++ [ (coq.ocamlPackages.elpi.override { version = o.elpi-version; }) ]; } ); patched-derivation2 = patched-derivation1.overrideAttrs ( o: lib.optionalAttrs (o.version != null && (o.version == "dev" || lib.versions.isGe "2.2.0" o.version)) { propagatedBuildInputs = o.propagatedBuildInputs ++ [ coq.ocamlPackages.ppx_optcomp ]; } ); patched-derivation3 = patched-derivation2.overrideAttrs ( o: lib.optionalAttrs (o.version != null && o.version == "2.4.0") { propagatedBuildInputs = o.propagatedBuildInputs ++ [ stdlib ]; } ); patched-derivation4 = patched-derivation3.overrideAttrs ( o: # this is just a wrapper for rocPackages.rocq-elpi for Rocq >= 9.0 if coq.version != null && (coq.version == "dev" || lib.versions.isGe "9.0" coq.version) then { configurePhase = '' echo no configuration ''; buildPhase = '' echo building nothing ''; installPhase = '' echo installing nothing ''; propagatedBuildInputs = o.propagatedBuildInputs ++ [ rocqPackages.rocq-elpi ]; } else lib.optionalAttrs (o.version != null && (o.version == "dev" || lib.versions.isGe "2.5.0" o.version)) { configurePhase = '' make dune-files || true ''; buildPhase = '' dune build -p rocq-elpi @install ''${enableParallelBuilding:+-j $NIX_BUILD_CORES} ''; installPhase = '' dune install --root . rocq-elpi --prefix=$out --libdir $OCAMLFIND_DESTDIR mkdir $out/lib/coq/ mv $OCAMLFIND_DESTDIR/coq $out/lib/coq/${coq.coq-version} ''; } ); in patched-derivation4 coqeal-2.1.0/LICENSE000066400000000000000000000022651475512565300140050ustar00rootroot00000000000000The MIT License (MIT) Copyright (c) 2014 Guillaume Cano, Cyril Cohen, Maxime Dénès, Anders Mörtberg and Vincent Siles. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. coqeal-2.1.0/Makefile000066400000000000000000000005171475512565300144360ustar00rootroot00000000000000all: Makefile.coq @+$(MAKE) -f Makefile.coq all clean: Makefile.coq @+$(MAKE) -f Makefile.coq cleanall @rm -f Makefile.coq Makefile.coq.conf Makefile.coq: _CoqProject $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq force _CoqProject Makefile: ; %: Makefile.coq force @+$(MAKE) -f Makefile.coq $@ .PHONY: all clean force coqeal-2.1.0/README.md000066400000000000000000000163561475512565300142650ustar00rootroot00000000000000 # CoqEAL [![Docker CI][docker-action-shield]][docker-action-link] [![Contributing][contributing-shield]][contributing-link] [![Code of Conduct][conduct-shield]][conduct-link] [![Zulip][zulip-shield]][zulip-link] [docker-action-shield]: https://github.com/coq-community/coqeal/actions/workflows/docker-action.yml/badge.svg?branch=master [docker-action-link]: https://github.com/coq-community/coqeal/actions/workflows/docker-action.yml [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users This Coq library contains a subset of the work that was developed in the context of the ForMath EU FP7 project (2009-2013). It has two parts: - theory, which contains developments in algebra including normal forms of matrices, and optimized algorithms on MathComp data structures. - refinements, which is a framework to ease change of data representations during a proof. ## Meta - Author(s): - Guillaume Cano (initial) - Cyril Cohen (initial) - Maxime Dénès (initial) - Érik Martin-Dorel - Anders Mörtberg (initial) - Damien Rouhling - Pierre Roux - Vincent Siles (initial) - Coq-community maintainer(s): - Cyril Cohen ([**@CohenCyril**](https://github.com/CohenCyril)) - Pierre Roux ([**@proux01**](https://github.com/proux01)) - License: [MIT License](LICENSE) - Compatible Coq versions: 8.20 or later (use releases for other Coq versions) - Additional dependencies: - [Bignums](https://github.com/coq/bignums) same version as Coq - [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 2.4.1 or later - [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder) 1.4.0 or later - [MathComp ssreflect](https://math-comp.github.io) 2.3 or later - [MathComp algebra](https://math-comp.github.io) 2.1 or later - [MathComp Multinomials](https://github.com/math-comp/multinomials) 2.0 or later - [MathComp real-closed](https://math-comp.github.io) 2.0 or later - Coq namespace: `CoqEAL` - Related publication(s): - [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) - [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) - [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) - [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) - [A refinement-based approach to large scale reflection for algebra](https://hal.inria.fr/hal-01414881/document) - [Interaction entre algèbre linéaire et analyse en formalisation des mathématiques](https://tel.archives-ouvertes.fr/tel-00986283/) - [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) - [Formalizing Refinements and Constructive Algebra in Type Theory](http://hdl.handle.net/2077/37325) - [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) ## Building and installation instructions The easiest way to install the latest released version of CoqEAL is via [OPAM](https://opam.ocaml.org/doc/Install.html): ```shell opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-coqeal ``` To instead build and install manually, do: ``` shell git clone https://github.com/coq-community/coqeal.git cd coqeal make # or make -j make install ``` ## Theory The theory directory has the following content: - `ssrcomplements`, `minor` `mxstructure`, `polydvd`, `similar`, `binetcauchy`, `ssralg_ring_tac`: Various extensions of the Mathematical Components library. - `dvdring`, `coherent`, `stronglydiscrete`, `edr`: Hierarchy of structures with divisibility (from rings with divisibility, PIDs, elementary divisor rings, etc.). - `fpmod`: Formalization of finitely presented modules. - `kaplansky`: For providing elementary divisor rings from the Kaplansky condition. - `closed_poly`: Polynomials with coefficients in a closed field. - `companion`, `frobenius_form`, `jordan`, `perm_eq_image`, `smith_complements`: Results on normal forms of matrices. - `bareiss_dvdring`, `bareiss`, `gauss`, `karatsuba`, `rank`, `strassen`, `toomcook`, `smithpid`, `smith`: Various efficient algorithms for computing operations on polynomials or matrices. ## Refinements The refinements directory has the following content: - `refinements`: Classes for refinements and refines together with operational typeclasses for common operations. - `binnat`: Proof that the binary naturals of Coq (`N`) are a refinement of the MathComp unary naturals (`nat`) together with basic operations. - `binord`: Proof that the binary natural numbers of Coq (`N`) are a refinement of the MathComp ordinals. - `binint`: MathComp integers (`ssrint`) are refined to a new type parameterized by positive numbers (represented by a sigma type) and natural numbers. This means that proofs can be done using only lemmas from the MathComp library which leads to simpler proofs than previous versions of `binint` (e.g., `N`). - `binrat`: Arbitrary precision rational numbers (`bigQ`) from the [Bignums](https://github.com/coq/bignums) library are refined to MathComp's rationals (`rat`). - `rational`: The rational numbers of MathComp (`rat`) are refined to pairs of elements refining integers using parametricity of refinements. - `seqmatrix` and `seqmx_complements`: Refinement of MathComp matrices (`M[R]_(m,n)`) to lists of lists (`seq (seq R)`). - `seqpoly`: Refinement of MathComp polynomials (`{poly R}`) to lists (`seq R`). - `multipoly`: Refinement of [MathComp multinomials](https://github.com/math-comp/multinomials) and multivariate polynomials to Coq [finite maps](https://github.com/coq/coq/blob/master/theories/FSets/FMapAVL.v). Files should use the following conventions (w.r.t. `Local` and `Global` instances): ```coq (** Part 1: Generic operations *) Section generic_operations. Global Instance generic_operation := ... (** Part 2: Correctness proof for proof-oriented types and programs *) Section theory. Local Instance param_correctness : param ... (** Part 3: Parametricity *) Section parametricity. Global Instance param_parametricity : param ... Proof. exact: param_trans. Qed. End parametricity. End theory. ``` coqeal-2.1.0/_CoqProject000066400000000000000000000030121475512565300151220ustar00rootroot00000000000000-R . CoqEAL -arg -w -arg -projection-no-head-constant -arg -w -arg -redundant-canonical-projection -arg -w -arg -notation-overridden -arg -w -arg +duplicate-clear -arg -w -arg +non-primitive-record -arg -w -arg +undeclared-scope -arg -w -arg +deprecated-hint-without-locality -arg -w -arg +deprecated-hint-rewrite-without-locality -arg -w -arg +deprecated-ident-entry -arg -w -arg +deprecated-typeclasses-transparency-without-locality -arg -w -arg -ambiguous-paths -arg -w -arg +implicit-core-hint-db theory/atomic_operations.v theory/bareiss_dvdring.v theory/bareiss.v theory/binetcauchy.v theory/closed_poly.v theory/coherent.v theory/companion.v theory/dvdring.v theory/edr.v theory/fpmod.v theory/frobenius_form.v theory/gauss.v theory/jordan.v theory/kaplansky.v theory/karatsuba.v theory/minor.v theory/mxstructure.v theory/perm_eq_image.v theory/polydvd.v theory/rank.v theory/similar.v theory/smithpid.v theory/smith.v theory/smith_complements.v theory/ssralg_ring_tac.v theory/ssrcomplements.v theory/strassen.v theory/stronglydiscrete.v theory/toomcook.v refinements/hrel.v refinements/param.v refinements/refinements.v refinements/pos.v refinements/binnat.v refinements/binint.v refinements/poly_op.v refinements/seqpoly.v refinements/karatsuba.v refinements/poly_div.v refinements/binord.v refinements/seqmx.v refinements/seqmx_complements.v refinements/hpoly.v refinements/bareiss_eff.v refinements/rational.v refinements/boolF2.v refinements/trivial_seq.v refinements/examples/irred.v refinements/binrat.v refinements/multipoly.v coqeal-2.1.0/coq-coqeal.opam000066400000000000000000000033261475512565300157010ustar00rootroot00000000000000# This file was generated from `meta.yml`, please do not edit manually. # Follow the instructions on https://github.com/coq-community/templates to regenerate. opam-version: "2.0" maintainer: "Cyril Cohen " version: "dev" homepage: "https://github.com/coq-community/coqeal" dev-repo: "git+https://github.com/coq-community/coqeal.git" bug-reports: "https://github.com/coq-community/coqeal/issues" license: "MIT" synopsis: "CoqEAL - The Coq Effective Algebra Library" description: """ This Coq library contains a subset of the work that was developed in the context of the ForMath EU FP7 project (2009-2013). It has two parts: - theory, which contains developments in algebra including normal forms of matrices, and optimized algorithms on MathComp data structures. - refinements, which is a framework to ease change of data representations during a proof.""" build: [make "-j%{jobs}%"] install: [make "install"] depends: [ "coq" {(>= "8.20" & < "9.1~") | (= "dev")} "coq-bignums" "coq-elpi" {>= "2.4.1" | = "dev"} "coq-hierarchy-builder" {>= "1.4.0"} "coq-mathcomp-ssreflect" {>= "2.3"} "coq-mathcomp-algebra" "coq-mathcomp-multinomials" {>= "2.0"} "coq-mathcomp-real-closed" {>= "2.0"} ] tags: [ "category:Computer Science/Decision Procedures and Certified Algorithms/Correctness proofs of algorithms" "keyword:effective algebra" "keyword:elementary divisor rings" "keyword:Smith normal form" "keyword:mathematical components" "keyword:Bareiss" "keyword:Karatsuba multiplication" "keyword:refinements" "logpath:CoqEAL" ] authors: [ "Guillaume Cano" "Cyril Cohen" "Maxime Dénès" "Érik Martin-Dorel" "Anders Mörtberg" "Damien Rouhling" "Pierre Roux" "Vincent Siles" ] coqeal-2.1.0/default.nix000066400000000000000000000006611475512565300151420ustar00rootroot00000000000000{ config ? {}, withEmacs ? false, print-env ? false, do-nothing ? false, update-nixpkgs ? false, ci-matrix ? false, override ? {}, ocaml-override ? {}, global-override ? {}, bundle ? null, job ? null, inNixShell ? null, src ? ./., }@args: let auto = fetchGit { url = "https://github.com/coq-community/coq-nix-toolbox.git"; ref = "master"; rev = import .nix/coq-nix-toolbox.nix; }; in import auto ({inherit src;} // args) coqeal-2.1.0/meta.yml000066400000000000000000000162271475512565300144540ustar00rootroot00000000000000--- fullname: CoqEAL shortname: coqeal organization: coq-community community: true action: true coqdoc: false dune: false synopsis: >- CoqEAL - The Coq Effective Algebra Library description: |- This Coq library contains a subset of the work that was developed in the context of the ForMath EU FP7 project (2009-2013). It has two parts: - theory, which contains developments in algebra including normal forms of matrices, and optimized algorithms on MathComp data structures. - refinements, which is a framework to ease change of data representations during a proof. publications: - pub_url: https://hal.inria.fr/hal-00734505/document pub_title: A refinement-based approach to computational algebra in Coq pub_doi: 10.1007/978-3-642-32347-8_7 - pub_url: https://hal.inria.fr/hal-01113453/document pub_title: Refinements for free! pub_doi: 10.1007/978-3-319-03545-1_10 - pub_url: https://hal.inria.fr/hal-01378905/document pub_title: A Coq Formalization of Finitely Presented Modules pub_doi: 10.1007/978-3-319-08970-6_13 - pub_url: https://hal.inria.fr/hal-01081908/document pub_title: Formalized Linear Algebra over Elementary Divisor Rings in Coq pub_doi: 10.2168/LMCS-12(2:7)2016 - pub_url: https://hal.inria.fr/hal-01414881/document pub_title: A refinement-based approach to large scale reflection for algebra - pub_url: https://tel.archives-ouvertes.fr/tel-00986283/ pub_title: Interaction entre algèbre linéaire et analyse en formalisation des mathématiques - pub_url: https://jfr.unibo.it/article/view/2615 pub_doi: 10.6092/issn.1972-5787/2615 pub_title: A formal proof of Sasaki-Murao algorithm - pub_url: http://hdl.handle.net/2077/37325 pub_title: Formalizing Refinements and Constructive Algebra in Type Theory - pub_title: Coherent and Strongly Discrete Rings in Type Theory pub_url: https://staff.math.su.se/anders.mortberg/papers/coherent.pdf pub_doi: 10.1007/978-3-642-35308-6_21 authors: - name: Guillaume Cano initial: true - name: Cyril Cohen initial: true - name: Maxime Dénès initial: true - name: Érik Martin-Dorel initial: false - name: Anders Mörtberg initial: true - name: Damien Rouhling initial: false - name: Pierre Roux initial: false - name: Vincent Siles initial: true maintainers: - name: Cyril Cohen nickname: CohenCyril - name: Pierre Roux nickname: proux01 opam-file-maintainer: Cyril Cohen opam-file-version: dev license: fullname: MIT License identifier: MIT supported_coq_versions: text: 8.20 or later (use releases for other Coq versions) opam: '{(>= "8.20" & < "9.1~") | (= "dev")}' dependencies: - opam: name: coq-bignums description: |- [Bignums](https://github.com/coq/bignums) same version as Coq - opam: name: coq-elpi version: '{>= "2.4.1" | = "dev"}' description: |- [Coq-Elpi](https://github.com/LPCIC/coq-elpi) 2.4.1 or later - opam: name: coq-hierarchy-builder version: '{>= "1.4.0"}' description: |- [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder) 1.4.0 or later - opam: name: coq-mathcomp-ssreflect version: '{>= "2.3"}' description: |- [MathComp ssreflect](https://math-comp.github.io) 2.3 or later - opam: name: coq-mathcomp-algebra description: |- [MathComp algebra](https://math-comp.github.io) 2.1 or later - opam: name: coq-mathcomp-multinomials version: '{>= "2.0"}' description: |- [MathComp Multinomials](https://github.com/math-comp/multinomials) 2.0 or later - opam: name: coq-mathcomp-real-closed version: '{>= "2.0"}' description: |- [MathComp real-closed](https://math-comp.github.io) 2.0 or later tested_coq_opam_versions: - version: '2.3.0-coq-8.20' repo: 'mathcomp/mathcomp' - version: '2.3.0-coq-dev' repo: 'mathcomp/mathcomp' - version: 'coq-8.20' repo: 'mathcomp/mathcomp-dev' - version: 'coq-dev' repo: 'mathcomp/mathcomp-dev' namespace: CoqEAL keywords: - name: effective algebra - name: elementary divisor rings - name: Smith normal form - name: mathematical components - name: Bareiss - name: Karatsuba multiplication - name: refinements categories: - name: Computer Science/Decision Procedures and Certified Algorithms/Correctness proofs of algorithms documentation: |- ## Theory The theory directory has the following content: - `ssrcomplements`, `minor` `mxstructure`, `polydvd`, `similar`, `binetcauchy`, `ssralg_ring_tac`: Various extensions of the Mathematical Components library. - `dvdring`, `coherent`, `stronglydiscrete`, `edr`: Hierarchy of structures with divisibility (from rings with divisibility, PIDs, elementary divisor rings, etc.). - `fpmod`: Formalization of finitely presented modules. - `kaplansky`: For providing elementary divisor rings from the Kaplansky condition. - `closed_poly`: Polynomials with coefficients in a closed field. - `companion`, `frobenius_form`, `jordan`, `perm_eq_image`, `smith_complements`: Results on normal forms of matrices. - `bareiss_dvdring`, `bareiss`, `gauss`, `karatsuba`, `rank`, `strassen`, `toomcook`, `smithpid`, `smith`: Various efficient algorithms for computing operations on polynomials or matrices. ## Refinements The refinements directory has the following content: - `refinements`: Classes for refinements and refines together with operational typeclasses for common operations. - `binnat`: Proof that the binary naturals of Coq (`N`) are a refinement of the MathComp unary naturals (`nat`) together with basic operations. - `binord`: Proof that the binary natural numbers of Coq (`N`) are a refinement of the MathComp ordinals. - `binint`: MathComp integers (`ssrint`) are refined to a new type parameterized by positive numbers (represented by a sigma type) and natural numbers. This means that proofs can be done using only lemmas from the MathComp library which leads to simpler proofs than previous versions of `binint` (e.g., `N`). - `binrat`: Arbitrary precision rational numbers (`bigQ`) from the [Bignums](https://github.com/coq/bignums) library are refined to MathComp's rationals (`rat`). - `rational`: The rational numbers of MathComp (`rat`) are refined to pairs of elements refining integers using parametricity of refinements. - `seqmatrix` and `seqmx_complements`: Refinement of MathComp matrices (`M[R]_(m,n)`) to lists of lists (`seq (seq R)`). - `seqpoly`: Refinement of MathComp polynomials (`{poly R}`) to lists (`seq R`). - `multipoly`: Refinement of [MathComp multinomials](https://github.com/math-comp/multinomials) and multivariate polynomials to Coq [finite maps](https://github.com/coq/coq/blob/master/theories/FSets/FMapAVL.v). Files should use the following conventions (w.r.t. `Local` and `Global` instances): ```coq (** Part 1: Generic operations *) Section generic_operations. Global Instance generic_operation := ... (** Part 2: Correctness proof for proof-oriented types and programs *) Section theory. Local Instance param_correctness : param ... (** Part 3: Parametricity *) Section parametricity. Global Instance param_parametricity : param ... Proof. exact: param_trans. Qed. End parametricity. End theory. ``` --- coqeal-2.1.0/refinements/000077500000000000000000000000001475512565300153125ustar00rootroot00000000000000coqeal-2.1.0/refinements/bareiss_eff.v000066400000000000000000001342131475512565300177550ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) (* Formalization of the Sasaki-Murao algorithm *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path ssralg. From mathcomp Require Import fintype perm choice matrix bigop zmodp poly polydiv mxpoly. From CoqEAL Require Import minor hrel param refinements seqmx. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Section generic_bareiss. Variable R : Type. Local Open Scope hetero_computable_scope. Local Open Scope computable_scope. Variable polyR : Type. Variable mxR : nat -> nat -> Type. Variable mxpolyR : nat -> nat -> Type. Context `{zero_of R, one_of polyR}. Context `{forall m n, opp_of (mxR m n)}. Context `{ursubmx : ursubmx_of mxpolyR}. Context `{dlsubmx : dlsubmx_of mxpolyR}. Context `{drsubmx : drsubmx_of mxpolyR}. Context `{!hmul_of mxpolyR}. Context `{forall m n, sub_of (mxpolyR m n)}. Context `{forall m n, scale_of polyR (mxpolyR m n)}. Context `{map_mx : forall m n, map_mx_of polyR polyR (mxpolyR m n) (mxpolyR m n)}. Context `{top_left : forall m, top_left_of (mxpolyR (1 + m) (1 + m)) polyR}. Context `{divp : div_of polyR}. Variable char_poly_mx : forall n, mxR n n -> mxpolyR n n. Variable head : polyR -> R. Fixpoint bareiss_rec m (a : polyR) : mxpolyR (1 + m) (1 + m) -> polyR := match m with | S p => fun M => let d := top_left M in let l := ursubmx M in let c := dlsubmx M in let N := drsubmx M in let M' := (d *: N - c *m l)%HC in let M'' := map_mx (fun x => x %/ a) M' in bareiss_rec d M'' | _ => fun M => top_left M end. Definition bareiss n (M : mxpolyR (1 + n) (1 + n)) := bareiss_rec 1 M. Definition bareiss_char_poly n (M : mxR (1 + n) (1 + n)) := bareiss (char_poly_mx M). (* The actual determinant function based on Bareiss *) Definition bdet n (M : mxR (1 + n) (1 + n)) := head (bareiss_char_poly (- M)%C). End generic_bareiss. Elpi derive.param2 hmul_op. Elpi derive.param2 bareiss_rec. Elpi derive.param2 bareiss. Elpi derive.param2 bareiss_char_poly. Elpi derive.param2 bdet. (* First some general lemmas *) Section prelude. Variable R : comRingType. Lemma key_lemma m d l (c : 'cV[R]_m) M : d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l). Proof. rewrite -[d ^+ m]mul1r -det_scalar -(det1 _ 1) -(det_ublock _ 0) -det_mulmx. rewrite mulmx_block ?(mul0mx,addr0,add0r,mul1mx,mul_scalar_mx) -2![LHS]mul1r. rewrite -{1}(@det1 _ 1) -{2}(@det1 _ m) mulrA -(@det_lblock _ _ _ _ (- c)). rewrite -det_mulmx mulmx_block ?(mul1mx,mul0mx,addr0) addrC mul_mx_scalar. by rewrite scalerN subrr det_ublock det_scalar1 addrC mulNmx. Qed. (* The key lemma of our proof: after simplification, all the k-minors *) (* (involving 1st line/column) can be divided by (M 0 0)^k *) Lemma key_lemma_sub m n k (M : 'M[R]_(1 + m,1 + n)) (f : 'I_k -> 'I_m) (g : 'I_k -> 'I_n) : M 0 0 * (minor f g (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)) = M 0 0 ^+ k * (minor (lift_pred f) (lift_pred g) M). Proof. rewrite /minor -{7}[M]submxK submatrix_add submatrix_scale submatrix_opp. have -> : ulsubmx M = (M 0 0)%:M by apply/rowP=> i; rewrite ord1 !mxE !lshift0. by rewrite submatrix_lift_block key_lemma submatrix_mul. Qed. (* Why is this not in the libraries? *) Lemma monic_lreg (p : {poly R}) : p \is monic -> GRing.lreg p. Proof. by rewrite monicE=> /eqP h; apply/lreg_lead; rewrite h; apply/lreg1. Qed. End prelude. Section bareiss_correctness. Variable R : comRingType. Instance : zero_of R := 0. Instance : one_of {poly R} := 1. Instance : forall m n, opp_of 'M[R]_(m, n) := fun m n M => - M. Instance ursubmx : ursubmx_of (matrix {poly R}) := @matrix.ursubmx {poly R}. Instance dlsubmx : dlsubmx_of (matrix {poly R}) := @matrix.dlsubmx {poly R}. Instance drsubmx : drsubmx_of (matrix {poly R}) := @matrix.drsubmx {poly R}. Instance : hmul_of (matrix {poly R}) := @mulmx {poly R}. Instance : forall m n, sub_of (matrix {poly R} m n) := fun m n (M N : 'M[{poly R}]_(m,n)) => M - N. Instance : forall m n, scale_of {poly R} (matrix {poly R} m n) := @scalemx {poly R}. Instance map_mx : forall m n, map_mx_of {poly R} {poly R} (matrix {poly R} m n) (matrix {poly R} m n) := fun m n f => @matrix.map_mx {poly R} {poly R} f m n. Instance top_left : forall m, top_left_of 'M[{poly R}]_(1 + m,1 + m) {poly R} := fun m M => M ord0 ord0. Instance : div_of {poly R} := @rdivp R. Definition head : {poly R} -> R := fun p => p`_0. (* Lemma bareiss_invariants : forall m a (M : 'M[{poly R}]_(1 + m)), *) (* a \is monic -> *) (* (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> *) (* (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *) (* let d := M 0 0 in let l := ursubmx M in *) (* let c := dlsubmx M in let N := drsubmx M in *) (* let M' := d *: N - c *m l in let M'' := map_mx (fun x => rdivp x a) M' in *) (* [/\ M 0 0 \is monic, *) (* M' = a *: M'', (* This is not really an invariant *) *) (* forall p (h h' : p < m), pminor h h' M'' \is monic & *) (* forall k (f g : 'I_k.+1 -> 'I_m), rdvdp (d ^+ k) (minor f g M'') ]. *) (* Proof. *) (* move=> m a M am hpm hdvd /=. *) (* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M'. *) (* have hM' : M' = a *: M''. *) (* pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *) (* apply/matrixP => i j. *) (* rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //. *) (* move: (hdvd 1%nat (f _ i) (f _ j)). *) (* by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1. *) (* have d_monic : d \is monic. *) (* have -> // : d = pminor (ltn0Sn m) (ltn0Sn m) M. *) (* have h : widen_ord (ltn0Sn m) =1 (fun _ => 0) *) (* by move=> x; apply/ord_inj; rewrite [x]ord1. *) (* by rewrite /pminor (minor_eq h h) minor1. *) (* split=> // [p h h'|k f g]. *) (* rewrite -(@monicMl _ (a ^+ p.+1)) ?monic_exp // -detZ -submatrix_scale -hM'. *) (* rewrite -(monicMl _ d_monic) key_lemma_sub monicMr ?monic_exp //. *) (* by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm. *) (* case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)); rewrite ?monic_exp // => x hx. *) (* apply/rdvdpP; rewrite ?monic_exp //; exists x. *) (* apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic). *) (* rewrite -detZ -submatrix_scale -hM' key_lemma_sub mulrA [x * _]mulrC mulrACA. *) (* by rewrite -exprS [_ * x]mulrC -hx. *) (* Qed. *) (* Lemma bareiss_recE2 : forall m a (M : 'M[{poly R}]_(1 + m)), *) (* a \is monic -> *) (* (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> *) (* (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *) (* a ^+ m * (bareiss_rec a M) = \det M. *) (* Proof. *) (* elim=> [a M _ _ _|m ih a M am hpm hdvd] /=. *) (* by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1. *) (* case: (bareiss_invariants am hpm hdvd). *) (* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M'. *) (* move=> d_monic hM' h1 h2. *) (* rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)). *) (* have -> : ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0. *) (* rewrite key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA. *) (* by rewrite ih. *) (* Qed. *) Lemma bareiss_recE : forall m a (M : 'M[{poly R}]_(1 + m)), a \is monic -> (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> a ^+ m * (bareiss_rec a M) = \det M. Proof. elim=> [a M _ _ _|m ih a M am hpm hdvd] /=. by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1. have ak_monic k : a ^+ k \is monic by apply/monic_exp. simpC; rewrite /map_mx /drsubmx /dlsubmx /ursubmx /top_left. set d := M 0 0; set M' := (_ - _); set M'' := matrix.map_mx _ _; simpl in M'. have d_monic : d \is monic. have -> // : d = pminor (ltn0Sn _) (ltn0Sn _) M. have h : widen_ord (ltn0Sn m.+1) =1 (fun _ => 0) by move=> x; apply/ord_inj; rewrite [x]ord1. by rewrite /pminor (minor_eq h h) minor1. have dk_monic : forall k, d ^+ k \is monic by move=> k; apply/monic_exp. have hM' : M' = a *: M''. pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else (lift 0 i). apply/matrixP => i j. rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //. move: (hdvd 1%nat (f _ i) (f _ j)). by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1. rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)). have -> : matrix.ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0. rewrite key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA. rewrite ih // => [p h h'|k f g]. rewrite -(@monicMl _ (a ^+ p.+1)) // -detZ -submatrix_scale -hM'. rewrite -(monicMl _ d_monic) key_lemma_sub monicMr //. by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm. case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)) => // x hx. apply/rdvdpP => //; exists x. apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic). rewrite -detZ -submatrix_scale -hM' key_lemma_sub mulrA [x * _]mulrC mulrACA. by rewrite -exprS [_ * x]mulrC -hx. Qed. Lemma bareissE n (M : 'M[{poly R}]_(1 + n)) (H : forall p (h h' : p < 1 + n), pminor h h' M \is monic) : bareiss M = \det M. Proof. rewrite /bareiss -(@bareiss_recE n 1 M) ?monic1 ?expr1n ?mul1r //. by move=> k f g; rewrite expr1n rdvd1p. Qed. Lemma bareiss_char_polyE n (M : 'M[R]_(1 + n)) : bareiss_char_poly (@char_poly_mx R) M = char_poly M. Proof. rewrite /bareiss_char_poly bareissE // => p h h'. exact: pminor_char_poly_mx_monic. Qed. Lemma bdetE n (M : 'M[R]_(1 + n)) : bdet (polyR:= {poly R}) (@char_poly_mx R) head M = \det M. Proof. rewrite /bdet /head bareiss_char_polyE char_poly_det. have -> : (-M)%C = -M by []. by rewrite -scaleN1r detZ mulrA -expr2 sqrr_sign mul1r. Qed. Section bareiss_param. Local Open Scope rel_scope. Context (C : Type) (rC : R -> C -> Type). Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). Context (mxC : nat -> nat -> Type) (RmxC : forall m1 m2, nat_R m1 m2 -> forall n1 n2, nat_R n1 n2 -> 'M[R]_(m1, n1) -> mxC m2 n2 -> Type). Arguments RmxC {_ _} _ {_ _} _ _ _. (* Cyril: bug *) (*Arguments RmxC {_ _ _ _ _ _} _ _. *) Context (mxpolyC : nat -> nat -> Type) (RmxpolyC : forall m1 m2, nat_R m1 m2 -> forall n1 n2, nat_R n1 n2 -> 'M[{poly R}]_(m1, n1) -> mxpolyC m2 n2 -> Type). Arguments RmxpolyC {_ _} _ {_ _} _ _ _. (* Cyril: bug *) (* Arguments RmxpolyC {_ _ _ _ _ _} _ _. *) Context `{zero_of C, one_of polyC}. Context `{forall m n, opp_of (mxC m n)}. Context `{ursubmxC : ursubmx_of mxpolyC}. Context `{dlsubmxC : dlsubmx_of mxpolyC}. Context `{drsubmxC : drsubmx_of mxpolyC}. Context `{!hmul_of mxpolyC}. Context `{subC : forall m n, sub_of (mxpolyC m n)}. Context `{forall m n, scale_of polyC (mxpolyC m n)}. Context `{map_mxC : forall m n, map_mx_of polyC polyC (mxpolyC m n) (mxpolyC m n)}. Context `{top_leftC : forall m, top_left_of (mxpolyC (1 + m) (1 + m)) polyC}. Context `{divpC : div_of polyC}. Variable char_poly_mxC : forall n, mxC n n -> mxpolyC n n. Variable headC : polyC -> C. Context `{!refines rC 0%R 0%C, !refines RpolyC 1%R 1%C}. Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2), refines (RmxC rm rn ==> RmxC rm rn) -%R -%C}. Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22), refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RmxpolyC rm1 rn2) (@ursubmx m11 m21 n11 n21) (@ursubmxC m12 m22 n12 n22)}. Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22), refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2)==> RmxpolyC rm2 rn1) (@dlsubmx m11 m21 n11 n21) (@dlsubmxC m12 m22 n12 n22)}. Context `{forall m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22), refines (RmxpolyC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RmxpolyC rm2 rn2) (@drsubmx m11 m21 n11 n21) (@drsubmxC m12 m22 n12 n22)}. Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) p1 p2 (rp : nat_R p1 p2), refines (RmxpolyC rm rn ==> RmxpolyC rn rp ==> RmxpolyC rm rp) mulmx (@hmul_op _ _ _ m2 n2 p2)}. Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2), refines (RmxpolyC rm rn ==> RmxpolyC rm rn ==> RmxpolyC rm rn) (fun M N => M - N) sub_op}. Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2), refines (RpolyC ==> RmxpolyC rm rn ==> RmxpolyC rm rn) *:%R *:%C}. Context `{forall m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2), refines ((RpolyC ==> RpolyC) ==> RmxpolyC rm rn ==> RmxpolyC rm rn) (fun f => @matrix.map_mx _ _ f m1 n1) (@map_mxC m2 n2)}. Context `{forall m1 m2 (rm : nat_R m1 m2), refines (RmxpolyC (S_R rm) (S_R rm) ==> RpolyC) (@top_left m1) (@top_leftC m2)}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) (@rdivp R) divpC}. Context `{forall n1 n2 (rn : nat_R n1 n2), refines (RmxC rn rn ==> RmxpolyC rn rn) (@char_poly_mx _ n1) (@char_poly_mxC n2)}. Context `{!refines (RpolyC ==> rC) head headC}. #[export] Instance RmxpolyC_ursubmx : refines (ursubmx_of_R (@RmxpolyC)) ursubmx ursubmxC. Proof. by rewrite /ursubmx_of_R refinesE => *; apply: refinesP. Qed. #[export] Instance RmxpolyC_dlsubmx : refines (dlsubmx_of_R (@RmxpolyC)) dlsubmx dlsubmxC. Proof. by rewrite /dlsubmx_of_R refinesE => *; apply: refinesP. Qed. #[export] Instance RmxpolyC_drsubmx : refines (drsubmx_of_R (@RmxpolyC)) drsubmx drsubmxC. Proof. by rewrite /drsubmx_of_R refinesE => *; apply: refinesP. Qed. #[export] Instance RmxpolyC_hmul : refines (hmul_of_R (@RmxpolyC)) hmul_of_instance_0 hmul_of0. Proof. by rewrite /hmul_of_R refinesE => *; apply: refinesP. Qed. #[export] Instance RpolyC_bareiss_rec m1 m2 (rm : nat_R m1 m2) : refines (RpolyC ==> RmxpolyC (S_R rm) (S_R rm) ==> RpolyC) (bareiss_rec (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (m:=m1)) (bareiss_rec (polyR:=polyC) (mxpolyR:=mxpolyC) (m:=m2)). Proof. param bareiss_rec_R. Qed. #[export] Instance refine_bareiss_rec m : refines (RpolyC ==> RmxpolyC (S_R (nat_Rxx m)) (S_R (nat_Rxx m)) ==> RpolyC) (bareiss_rec (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (m:=m)) (bareiss_rec (polyR:=polyC) (mxpolyR:=mxpolyC) (m:=m)). Proof. exact: RpolyC_bareiss_rec. Qed. #[export] Instance RpolyC_bareiss n1 n2 (rn : nat_R n1 n2) : refines (RmxpolyC (S_R rn) (S_R rn) ==> RpolyC) (bareiss (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (n:=n1)) (bareiss (polyR:=polyC) (mxpolyR:=mxpolyC) (n:=n2)). Proof. param bareiss_R. Qed. #[export] Instance refine_bareiss n : refines (RmxpolyC (S_R (nat_Rxx n)) (S_R (nat_Rxx n)) ==> RpolyC) (bareiss (polyR:={poly R}) (mxpolyR:=matrix {poly R}) (n:=n)) (bareiss (polyR:=polyC) (mxpolyR:=mxpolyC) (n:=n)). Proof. exact: RpolyC_bareiss. Qed. #[export] Instance RpolyC_bareiss_char_poly n1 n2 (rn : nat_R n1 n2) : refines (RmxC (S_R rn) (S_R rn) ==> RpolyC) (bareiss_char_poly (polyR:={poly R}) (mxR:=matrix R) (mxpolyR:=matrix {poly R}) (@char_poly_mx R) (n:=n1)) (bareiss_char_poly (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC) char_poly_mxC (n:=n2)). Proof. param bareiss_char_poly_R. Qed. #[export] Instance refine_bareiss_char_poly n : refines (RmxC (S_R (nat_Rxx n)) (S_R (nat_Rxx n)) ==> RpolyC) (bareiss_char_poly (polyR:={poly R}) (mxR:=matrix R) (mxpolyR:=matrix {poly R}) (@char_poly_mx R) (n:=n)) (bareiss_char_poly (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC) char_poly_mxC (n:=n)). Proof. exact: RpolyC_bareiss_char_poly. Qed. #[export] Instance RC_bdet n1 n2 (rn : nat_R n1 n2) : refines (RmxC (S_R rn) (S_R rn) ==> rC) (bdet (R:=R) (polyR:={poly R}) (mxR:=matrix R) (mxpolyR:=matrix {poly R}) (@char_poly_mx R) head (n:=n1)) (bdet (R:=C) (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC) char_poly_mxC headC (n:=n2)). Proof. by param bdet_R; rewrite /opp_of_R refinesE => *; apply: refinesP. Qed. #[export] Instance refine_bdet n : refines (RmxC (S_R (nat_Rxx n)) (S_R (nat_Rxx n)) ==> rC) (bdet (R:=R) (polyR:={poly R}) (mxR:=matrix R) (mxpolyR:=matrix {poly R}) (@char_poly_mx R) head (n:=n)) (bdet (R:=C) (polyR:=polyC) (mxR:=mxC) (mxpolyR:=mxpolyC) char_poly_mxC headC (n:=n)). Proof. exact: RC_bdet. Qed. #[export] Instance RC_det_bdet n1 n2 (rn : nat_R n1 n2) : refines (RmxC (S_R rn) (S_R rn) ==> rC) determinant (bdet (R:=C) (polyR:=polyC) (mxpolyR:=mxpolyC) char_poly_mxC headC (n:=n2)). Proof. rewrite refinesE=> M M' HM. rewrite -bdetE. exact: refinesP. Qed. #[export] Instance refine_det n : refines (RmxC (S_R (nat_Rxx n)) (S_R (nat_Rxx n)) ==> rC) determinant (bdet (R:=C) (polyR:=polyC) (mxpolyR:=mxpolyC) char_poly_mxC headC (n:=n)). Proof. exact: RC_det_bdet. Qed. End bareiss_param. (***** WIP below here **********) End bareiss_correctness. From mathcomp Require Import ssrint. From CoqEAL Require Import binnat binint seqpoly poly_div binord trivial_seq. Section test_bareiss. Definition M : 'M[int]_(2,2) := \matrix_(i,j < 2) 3%:Z. Goal \det M == 0. by coqeal [(\det _)%pattern] vm_compute. Qed. Definition detM := [coqeal vm_compute of \det M]. Goal \det (1 : 'M[int]_(3)) = 1. by coqeal. Abort. Definition Madd := \matrix_(i,j < 29) (i + j)%:Z%:P. (* Time Definition det_Madd := [coqeal vm_compute of \det Madd]. *) Definition ctmat1 : 'M[int]__ := \matrix_(i < 3, j < 3) (nth [::] [:: [:: 1 ; 1 ; 1 ] ; [:: -1 ; 1 ; 1 ] ; [:: 0 ; 0 ; 1 ] ] i)`_j. Definition det_ctmat1 := [coqeal vm_compute of \det ctmat1]. (* Definition char_poly_ctmat1 := *) (* [coqeal vm_compute of \det _ for char_poly ctmat1]. *) End test_bareiss. (* Section poly_op. *) (* Variable R : comRingType. *) (* Implicit Types p q : {poly R}. *) (* Definition prptnl n p := \poly_(j < size p - n) p`_(j + n). *) (* Lemma prptnl0p p : prptnl 0 p = p. *) (* Proof. *) (* rewrite /prptnl subn0 -[RHS]coefK. *) (* apply/polyP=> i. *) (* by rewrite !coef_poly addn0. *) (* Qed. *) (* Lemma prptnlp0 n : prptnl n 0 = 0. *) (* Proof. *) (* rewrite /prptnl size_poly0 sub0n. *) (* apply/polyP=> i. *) (* by rewrite coef_poly /= coef0. *) (* Qed. *) (* Lemma prptnl_oversize n p : size p <= n -> prptnl n p = 0. *) (* Proof. *) (* move=> h; apply/polyP=> i. *) (* by rewrite coef_poly coef0 ltn_subRL leqNgt ltnS -[size p]addn0 *) (* (leq_add h (leq0n _)). *) (* Qed. *) (* Lemma prptnl_add n p q : prptnl n (p + q) = prptnl n p + prptnl n q. *) (* Proof. *) (* apply/polyP => i; symmetry. *) (* rewrite /prptnl coefD !coef_poly coefD !ltn_subRL addnC. *) (* have [H1|H1] := ltnP. *) (* have [_|H2] := ltnP; first by rewrite -coefD; have [|/leq_sizeP ->] := ltnP. *) (* move/leq_sizeP: (H2) => -> //. *) (* by rewrite (size_addl (leq_ltn_trans H2 H1)) H1. *) (* move/leq_sizeP: (H1) => -> //. *) (* have [H2|/leq_sizeP -> //] := ltnP; last by rewrite addr0 if_same. *) (* by rewrite [p + q]addrC (size_addl (leq_ltn_trans H1 H2)) H2. *) (* Qed. *) (* Lemma prptnl_opp n p : prptnl n (- p) = - prptnl n p. *) (* Proof. *) (* apply/polyP => i. *) (* rewrite /prptnl coefN !coef_poly coefN size_opp -{2}oppr0. *) (* by case: ltnP. *) (* Qed. *) (* Lemma prptnl_sub n p q : prptnl n (p - q) = prptnl n p - prptnl n q. *) (* Proof. by rewrite prptnl_add prptnl_opp. Qed. *) (* Lemma prptnlX n p : prptnl n p = prptnl n.+1 (p * 'X). *) (* Proof. *) (* have [/eqP ->|Hpn0] := (boolP (p == 0)); first by rewrite mul0r !prptnlp0. *) (* apply/polyP => i. *) (* by rewrite !coef_poly size_mulX ?coefMX // subnS subSKn addnS. *) (* Qed. *) (* Lemma prptnlXn n k p : prptnl n p = prptnl (n + k) (p * 'X^k). *) (* Proof. *) (* elim: k => [|k ih]; first by rewrite addn0 expr0 mulr1. *) (* by rewrite addnS exprS mulrCA mulrC -prptnlX. *) (* Qed. *) (* Lemma size_prptnl n p : size (prptnl n p) = (size p - n)%N. *) (* Proof. *) (* have [/eqP ->|Hpn0] := (boolP (p == 0)); first by rewrite prptnlp0 size_poly0 sub0n. *) (* have [H|] := (ltnP n (size p)). *) (* rewrite size_poly_eq //. *) (* suff -> : ((size p - n).-1 + n)%N = (size p).-1 by rewrite lead_coef_eq0. *) (* case: (size p) H => // m; rewrite ltnS => H. *) (* by rewrite subSKn subnK. *) (* rewrite /prptnl -subn_eq0 => /eqP ->. *) (* rewrite -[0%N](@size_poly0 R). *) (* congr size; congr polyseq. *) (* apply/polyP => i. *) (* by rewrite coef_poly size_poly0 coef0. *) (* Qed. *) (* Lemma prptnlS n p : prptnl n.+1 p = prptnl 1 (prptnl n p). *) (* Proof. *) (* apply/polyP=> i. *) (* rewrite !coef_poly [(i + 1)%N]addnC -ltn_subRL subnS !subn1 size_prptnl add1n. *) (* by rewrite addSnnS; case: ltnP. *) (* Qed. *) (* Lemma mulXn_prptnl : forall n p q, p * 'X^n = q -> p = prptnl n q. *) (* Proof. *) (* elim=> [p q|n ih p q h]; first by rewrite expr0 mulr1 prptnl0p => ->. *) (* rewrite prptnlS -(ih (p * 'X)); first by rewrite -prptnlX prptnl0p. *) (* by rewrite -mulrA -exprS. *) (* Qed. *) (* (* Key property - maybe it should be expressed with rdivp... *) *) (* Lemma test n p q r : p * 'X^n = q + r -> size r <= n -> p = prptnl n q. *) (* Proof. *) (* move=> h_eq sr. *) (* by rewrite (mulXn_prptnl h_eq) prptnl_add (prptnl_oversize sr) addr0. *) (* Qed. *) (* Lemma prptnlK m n p : prptnl m (prptnl n p) = prptnl (m + n) p. *) (* Proof. *) (* apply/polyP => i. *) (* rewrite !coef_poly {1}addnC -ltn_subRL {1}[(m + n)%N]addnC subnDA size_prptnl. *) (* by rewrite addnA; case: ltnP. *) (* Qed. *) (* Lemma prptnl_mulC n d p : prptnl n (d%:P * p) = d%:P * prptnl n p. *) (* Proof. *) (* elim/poly_ind: p n => [n|p c ih [|n]]; first by rewrite mulr0 !prptnlp0 mulr0. *) (* by rewrite !prptnl0p. *) (* rewrite mulrDr !prptnl_add mulrDr mulrA -!prptnlX ih -polyC_mul. *) (* rewrite ![prptnl n.+1 _%:P]prptnl_oversize ?mulr0 ?addr0 // size_polyC. *) (* by case: (c == 0). *) (* by case: (d * c == 0). *) (* Qed. *) (* (* Lemma prptnlC : forall n c, prptnl n c%:P = *) *) (* Lemma prptnl_mul n p q : prptnl (size p + n) (p * q) = *) (* prptnl (size p) (p * prptnl n q). *) (* Proof. *) (* elim/poly_ind: p q n=> [|p c ih] q n; first by rewrite !mul0r !prptnlp0. *) (* have [/eqP ->|Hpn0] := (boolP (p == 0)). *) (* by rewrite mul0r add0r !prptnl_mulC prptnlK. *) (* rewrite !mulrDl !prptnl_add size_addl size_mulX //; last first. *) (* rewrite size_polyC ltnS. *) (* by case: (c == 0) => //=; rewrite lt0n size_eq0 -polyseq0. *) (* rewrite mulrC mulrA -prptnlX mulrC ih // -mulrA ['X * _]mulrC mulrA. *) (* by rewrite -prptnlX -prptnl_mulC prptnlK addSn. *) (* Qed. *) (* (* Lemma prptnl_monic : forall n p, prptnl n p \is monic = (p \is monic). *) *) (* (* Proof. *) *) (* (* move => n. *) *) (* (* elim/poly_ind. *) *) (* (* by rewrite prptnlp0. *) *) (* (* move=> p c ih. *) *) (* (* rewrite prptnl_add !monicE. *) *) (* (* admit. *) *) (* (* Qed. *) *) (* Definition pmul (n : nat) p q := prptnl n (p * q). *) (* Lemma pmulP : forall n p q, pmul n p q = prptnl n (p * q). *) (* Admitted. *) (* Fixpoint sasaki_rec m (a : {poly R}) : 'M[{poly R}]_(1 + m) -> {poly R} := *) (* match m return 'M[_]_(1 + m) -> {poly R} with *) (* | S p => fun (M: 'M[_]_(1 + _)) => *) (* let d := M 0 0 in *) (* let l := ursubmx M in *) (* let c := dlsubmx M in *) (* let N := drsubmx M in *) (* let M' := \matrix_(i,j) (pmul (size a).-2 d (N i j) - *) (* pmul (size a).-2 (c i 0) (l 0 j)) in *) (* let q := rdivp 'X^(size a).*2.+1 a in *) (* let M'' := map_mx (fun x => pmul ((size a).+3 - (size a == 1))%N q x) M' in *) (* sasaki_rec d M'' *) (* | _ => fun M => M 0 0 *) (* end. *) (* Definition sasaki_char_poly n (M : 'M[R]_(1 + n)) := sasaki_rec 1 (char_poly_mx M). *) (* (* Lemma size_rdivp : forall p q, p \is monic -> rdvdp p q -> size (rdivp q p) = (size q - (size p).-1)%N. *) *) (* (* Proof. *) *) (* (* move=> p q pm hdvd. *) *) (* (* admit. *) *) (* (* Qed. *) *) (* (* Lemma test_size : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *) (* (* a \is monic -> *) *) (* (* M 0 0 \is monic -> *) *) (* (* (forall i j, rdvdp (R:=R) a *) *) (* (* (M 0 0 * M (lift 0 i) (lift 0 j) - M (lift 0 i) 0 * M 0 (lift 0 j))) -> *) *) (* (* (* (forall i, size (M i i) = (size a).+2)%N -> *) *) *) (* (* (* (forall i j, size (M j i * M i j) * (i != j) < size (M i i * M j j)) -> *) *) *) (* (* (forall i j, if i == j then size (M i i) = (size a).+2 *) *) (* (* else (M i j == 0) || (size (M i j) == (size a).-1)) -> *) *) (* (* forall i j, size (rdivp (M 0 0 * M (lift 0 i) (lift 0 j) - *) *) (* (* M (lift 0 i) 0 * M 0 (lift 0 j)) a) <= (size a).+2. *) *) (* (* Proof. *) *) (* (* move=> m a /= M am m00 hdvd h1 /= i j. *) *) (* (* rewrite size_rdivp //. *) *) (* (* rewrite size_addl. *) *) (* (* case hij: (i == j). *) *) (* (* rewrite (eqP hij). *) *) (* (* rewrite size_monicM //. *) *) (* (* move: (h1 0 0). *) *) (* (* rewrite eqxx => -> /=. *) *) (* (* move: (h1 (lift 0 j) (lift 0 j)). *) *) (* (* rewrite eqxx => ->. *) *) (* (* admit. *) *) (* (* admit. *) *) (* (* admit. *) *) (* (* rewrite size_opp. *) *) (* (* case h000: (M (lift 0 i) (lift 0 j) == 0). *) *) (* (* (* by rewrite (eqP h000) mulr0 size_poly0 sub0n. *) *) *) (* (* admit. *) *) (* (* rewrite [size (M 0 0 * _)]size_monicM //. *) *) (* (* admit. *) *) (* (* admit. *) *) (* (* Qed. *) *) (* (* Lemma sasaki_recE : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *) (* (* a \is monic -> *) *) (* (* (forall (p : nat) (h h' : p < 1 + m), pminor h h' M \is monic) -> *) *) (* (* (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> *) *) (* (* (forall i, size (M i i) = (size a).+2)%N -> *) *) (* (* (forall i j, size (M j i * M i j) * (i != j) < size (M i i * M j j)) -> *) *) (* (* (* (forall (f g : 'I_2 -> 'I_m.+1), size (minor f g M) <= (size a).+2) -> *) *) *) (* (* sasaki_rec a M = bareiss_rec a M. *) *) (* (* Proof. *) *) (* (* elim=> //= m ih a M am hpm hdvdk hsize1 hsize2. *) *) (* (* case: (bareiss_invariants am hpm hdvdk). *) *) (* (* set d := M 0 0; set M' := _ - _; set M'' := map_mx _ _; simpl in M' => h1 h2 h3 h4. *) *) (* (* suff -> : map_mx *) *) (* (* [eta pmul ((size a).+3 - (size a == 1)%N) *) *) (* (* (rdivp (R:=R) 'X^(size a).*2.+1 a)] *) *) (* (* (\matrix_(i, j) (pmul (size a).-2 (M 0 0) ((drsubmx M) i j) - *) *) (* (* pmul (size a).-2 ((dlsubmx M) i 0) ((ursubmx M) 0 j))) = *) *) (* (* map_mx ((rdivp (R:=R))^~ a) (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M). *) *) (* (* rewrite ih //. *) *) (* (* move=> i. *) *) (* (* rewrite -/M'. *) *) (* (* rewrite !mxE !big_ord1 !mxE !lshift0 !rshift1 /d size_rdivp //; last first. *) *) (* (* pose f := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *) *) (* (* have := (@hdvdk _ f f). *) *) (* (* by rewrite minor2 /f /= expr1. *) *) (* (* rewrite (hsize1 0). *) *) (* (* rewrite size_addl; last first. *) *) (* (* rewrite size_opp. *) *) (* (* move: (hsize2 0 (lift 0 i)). *) *) (* (* by rewrite /= muln1. *) *) (* (* case H0 : (M (lift 0 i) (lift 0 i) == 0). *) *) (* (* move: (hsize1 (lift 0 i)). *) *) (* (* by rewrite (eqP H0) size_poly0. *) *) (* (* rewrite size_monicM //; last by rewrite H0. *) *) (* (* rewrite (hsize1 0) (hsize1 (lift 0 i)). *) *) (* (* simpl. *) *) (* (* case a0 : (size a == 0)%N. *) *) (* (* move: am. *) *) (* (* move: a0. *) *) (* (* rewrite size_poly_eq0 => /eqP ->. *) *) (* (* rewrite monicE. *) *) (* (* rewrite lead_coef0. *) *) (* (* rewrite eq_sym =>HH. *) *) (* (* move: (oner_neq0 R). *) *) (* (* by rewrite HH. *) *) (* (* rewrite -subn1 subnBA; last by rewrite lt0n a0. *) *) (* (* rewrite addn1 -!addnS. *) *) (* (* rewrite addnC. *) *) (* (* rewrite -addnBA. *) *) (* (* by rewrite subnn addn0. *) *) (* (* done. *) *) (* (* admit. *) *) (* (* apply/matrixP=> i j; rewrite !mxE big_ord1 !pmulP !mxE lshift0 -prptnl_sub !rshift1. *) *) (* (* have [sa0|an0] := boolP (size a == 0)%N. *) *) (* (* rewrite (eqP sa0); move: sa0; rewrite size_poly_eq0 => /eqP -> /=. *) *) (* (* by rewrite !rdivp0 mul0r prptnlp0. *) *) (* (* have a0 : a != 0 by rewrite -size_poly_eq0. *) *) (* (* set e := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *) (* (* have hdvd : rdvdp a (d * N - c * l). *) *) (* (* move: (hdvdk 1%N) => HHH. *) *) (* (* pose f := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 i). *) *) (* (* pose g := fun (x : 'I_2) => if x == 0 then 0 else (lift 0 j). *) *) (* (* move: (HHH f g). *) *) (* (* by rewrite minor2 /f /g /= expr1. *) *) (* (* have := (rdivp_eq am ('X^(size a).*2.+1)). *) *) (* (* set q := rdivp _ _; set r := rmodp _ _; set M''' := rdivp _ _. *) *) (* (* move=> Hqr. *) *) (* (* have H1 : M''' * 'X^(size a).*2.+1 = (d * N - c * l) * q + M''' * r. *) *) (* (* rewrite Hqr mulrDr. *) *) (* (* congr (_ + _). *) *) (* (* rewrite mulrC -mulrA mulrC. *) *) (* (* congr (_ * _). *) *) (* (* rewrite /M' mulrC rdivpK //. *) *) (* (* move: am. *) *) (* (* by rewrite monicE => /eqP ->; rewrite expr1n mulr1. *) *) (* (* have := (ltn_rmodpN0 'X^(size a).*2.+1 a0); rewrite -/r => Hr. *) *) (* (* have q0 : q != 0. *) *) (* (* apply/eqP => q0; move: Hqr Hr. *) *) (* (* rewrite q0 !mul0r add0r => <-. *) *) (* (* by rewrite size_polyXn -addnn -!addnS -{3}[size a]addn0 leq_add2l. *) *) (* (* have laq0 : lead_coef q * lead_coef a != 0. *) *) (* (* have H : GRing.lreg (lead_coef a). *) *) (* (* move: am. *) *) (* (* rewrite monicE => /eqP ->. *) *) (* (* exact: lreg1. *) *) (* (* by rewrite mulrC (mulrI_eq0 _ H) lead_coef_eq0. *) *) (* (* have Hsize : size q = (size a).+3. *) *) (* (* have := (size_polyXn R (size a).*2.+1). *) *) (* (* rewrite Hqr size_addl size_proper_mul //. *) *) (* (* rewrite -addnn -addSn => /eqP. *) *) (* (* rewrite -eqSS -!addSn prednK /=. *) *) (* (* by rewrite eqn_add2r => /eqP. *) *) (* (* by rewrite addn_gt0 !lt0n an0 orbT. *) *) (* (* move: q0. *) *) (* (* rewrite -size_poly_eq0. *) *) (* (* case: (size q) => // n _. *) *) (* (* exact: (ltn_addl n Hr). *) *) (* (* have Hm' : size M''' <= (size a).+2. *) *) (* (* rewrite /M'''. *) *) (* (* (* apply/(leq_trans (leq_rdivp (d * N - c * l) a)). *) *) *) (* (* rewrite /e /N /c /l. *) *) (* (* rewrite test_size //. *) *) (* (* move=> /= x y. *) *) (* (* move: (hdvdk 1%N) => HHH. *) *) (* (* pose f := fun (apa : 'I_2) => if apa == 0 then 0 else (lift 0 x). *) *) (* (* pose g := fun (apa : 'I_2) => if apa == 0 then 0 else (lift 0 y). *) *) (* (* move: (HHH f g). *) *) (* (* by rewrite minor2 /f /g /= expr1. *) *) (* (* have H2 : size (M''' * r) <= (size a).*2.+1. *) *) (* (* rewrite (leq_trans (size_mul_leq M''' r)) // -addnn. *) *) (* (* have := (leq_add Hm' Hr). *) *) (* (* rewrite !addSn addnS ltnS => HH. *) *) (* (* have H : (size M''' + size r).-1 <= (size M''' + size r). *) *) (* (* by case: (size M''' + size r)%N. *) *) (* (* exact: (leq_trans H HH). *) *) (* (* rewrite (test H1 H2). *) *) (* (* case sa: (size a == 1)%N. *) *) (* (* by rewrite (eqP sa) prptnl0p -addnn mulrC. *) *) (* (* rewrite subn0 -Hsize -prptnl_mul Hsize mulrC. *) *) (* (* f_equal. *) *) (* (* rewrite -addnn !addSn -!addnS prednK. *) *) (* (* rewrite prednK //. *) *) (* (* by case: (size a) an0. *) *) (* (* by case: (size a) an0 sa => //= [[]]. *) *) (* (* Qed. *) *) (* (* OLD STUFF BELOW *) *) (* (* Definition sasaki_char_poly n (M : 'M[R]_(1 + n)) := sasaki_rec 1 (char_poly_mx M). *) *) (* (* (* Lemma sasakiE : forall m (M : 'M[R]_(1 + m)), sasaki_char_poly M = bareiss_char_poly M. *) *) *) (* (* (* Proof. *) *) *) (* (* (* rewrite /sasaki_char_poly /bareiss_char_poly /bareiss. *) *) *) (* (* (* elim. *) *) *) (* (* (* move=> M. *) *) *) (* (* (* simpl. *) *) *) (* (* (* done. *) *) *) (* (* (* move=> n ih M. *) *) *) (* (* (* simpl. *) *) *) (* (* (* rewrite /bareiss. *) *) *) (* (* Lemma size_rmodpXn p (p0 : p != 0) : size (rmodp 'X^(size p).*2.+1 p) < (size p). *) *) (* (* Proof. exact: (ltn_rmodpN0 'X^(size p).*2.+1 p0). Qed. *) *) (* (* Lemma size_rdivpXn p (pm : p \is monic) : size (rdivp 'X^(size p).*2.+1 p) = (size p).+3. *) *) (* (* Proof. *) *) (* (* move: (rdivp_eq pm ('X^(size p).*2.+1)) (ltn_rmodpN0 'X^(size p).*2.+1 (monic_neq0 pm)) *) *) (* (* (size_polyXn R (size p).*2.+1). *) *) (* (* set q := rdivp _ _; set r := rmodp _ _ => -> Hr. *) *) (* (* rewrite size_addl size_proper_mul //. *) *) (* (* rewrite -addnn -addSn => /eqP. *) *) (* (* rewrite -eqSS -!addSn prednK /=. *) *) (* (* by rewrite eqn_add2r => /eqP. *) *) (* (* by rewrite addn_gt0 !lt0n !size_poly_eq0 (monic_neq0 pm) orbT. *) *) (* (* admit. *) *) (* (* move: (monic_neq0 pm). *) *) (* (* rewrite -size_poly_eq0. *) *) (* (* case: (size p) => // n _ /=. *) *) (* (* rewrite addnS /=. *) *) (* (* move: (ltn_addl n Hr). *) *) (* (* admit. *) *) (* (* admit. *) *) (* (* Qed. *) *) (* (* Lemma sasaki_recE : forall m (a : {poly R}) (M : 'M[{poly R}]_(1 + m)), *) *) (* (* (* (forall (f g : 'I_2 -> 'I_(1 + m)%N), size (minor f g M) <= (size a).+2) -> *) *) *) (* (* (* (forall i j, if i == j then size (M i i) == (size a).+1 *) *) *) (* (* (* else size (M i j) <= size a) -> *) (* THIS DOES NOT WORK!!! *) *) *) (* (* a \is monic -> *) *) (* (* (forall i, M i i \is monic) -> *) *) (* (* (* (forall i j, size (M i i * M j j) == (size a).+2) -> *) *) *) (* (* (* (forall i j, size (M 0 i * M j 0) <= size a) -> *) *) *) (* (* (* (forall i j, size (M 0 0 * M (lift 0 i) (lift 0 j) - M (lift 0 i) 0 * M 0 (lift 0 j)) <= (size a).+2) -> *) *) *) (* (* (* (forall (f g : 'I_2 -> 'I_m.+1), rdvdp a (minor f g M)) -> *) *) *) (* (* sasaki_rec a M = bareiss_rec a M. *) *) (* (* Proof. *) *) (* (* (* elim=> //= m ih a M hs am hm. *) *) *) (* (* (* elim=> //= m ih a M am hm hs_diag hs. *) *) *) (* (* elim=> //= m ih a M am hm. *) *) (* (* (* have -> : (map_mx *) *) *) (* (* (* (fun x : {poly R} => *) *) *) (* (* (* if (size a == 1)%N *) *) *) (* (* (* then pmul (size a).+2 (rdivp (R:=R) 'X^(size a).*2.+1 a) x *) *) *) (* (* (* else pmul (size a).+3 (rdivp (R:=R) 'X^(size a).*2.+1 a) x) *) *) *) (* (* (* (\matrix_(i, j) (pmul (size a).-2 (M 0 0) ((drsubmx M) i j) - *) *) *) (* (* (* pmul (size a).-2 ((dlsubmx M) i 0) ((ursubmx M) 0 j)))) = (map_mx ((rdivp (R:=R))^~ a) *) *) *) (* (* (* (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)); last first. *) *) *) (* (* (* admit. *) *) *) (* (* rewrite ih; last first. *) *) (* (* admit. *) *) (* (* (* move=> i. *) *) *) (* (* (* rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *) (* (* (* case: ifP => sa1; rewrite prptnl_monic. *) *) *) (* (* (* rewrite (eqP sa1) /= prptnl0p. *) *) *) (* (* (* admit. *) *) *) (* (* (* admit. *) *) *) (* (* (* simpl. *) *) *) (* (* (* move=> i j. *) *) *) (* (* (* rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *) (* (* (* case: ifP => sa1. *) *) *) (* (* (* rewrite (eqP sa1) /= !prptnl0p. *) *) *) (* (* (* Search _ rdivp size. *) *) *) (* (* (* have -> : lift 0 0 = 1. *) *) *) (* (* (* by move=> n; apply/ord_inj. *) *) *) (* (* (* admit. *) *) *) (* (* (* admit. *) *) *) (* (* (* move=> i j. *) *) *) (* (* (* rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *) (* (* (* case: ifP => sa1. *) *) *) (* (* (* rewrite (eqP sa1) /= prptnl0p. *) *) *) (* (* (* admit. *) *) *) (* (* (* admit. *) *) *) (* (* (* move=> i. *) *) *) (* (* (* rewrite !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *) (* (* (* case: ifP => sa1; rewrite prptnl_monic. *) *) *) (* (* (* rewrite (eqP sa1) /= prptnl0p. *) *) *) (* (* (* admit. *) *) *) (* (* exact: (hm 0). *) *) (* (* (* move=> f g. *) *) *) (* (* (* rewrite minor2 !mxE !pmulP -prptnl_sub !lshift0 !rshift1. *) *) *) (* (* (* case: ifP=> sa. *) *) *) (* (* (* rewrite (eqP sa) /= !prptnl0p size_addl. *) *) *) (* (* (* rewrite size_proper_mul. *) *) *) (* (* (* rewrite !size_prptnl. *) *) *) (* (* (* rewrite size_proper_mul. *) *) *) (* (* (* Search _ size rdivp. *) *) *) (* (* (* rewrite /minor. *) *) *) (* (* (* simpl. *) *) *) (* (* (* move=> i j. *) *) *) (* (* (* case: ifP=> hij. *) *) *) (* (* (* rewrite (eqP hij). *) *) *) (* (* (* rewrite !mxE !pmulP !rshift1 !lshift0 -prptnl_sub. *) *) *) (* (* (* case: ifP => sa. *) *) *) (* (* (* set q := rdivp _ _. *) *) *) (* (* (* set d := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *) *) (* (* (* admit. *) *) *) (* (* (* admit. *) *) *) (* (* (* admit. *) *) *) (* (* congr bareiss_rec. *) *) (* (* apply/matrixP=> i j; rewrite !mxE big_ord1 !pmulP !mxE lshift0 -prptnl_sub !rshift1. *) *) (* (* have [sa0|an0] := boolP (size a == 0)%N. *) *) (* (* rewrite (eqP sa0); move: sa0; rewrite size_poly_eq0 => /eqP -> /=. *) *) (* (* by rewrite !rdivp0 mul0r prptnlp0. *) *) (* (* have a0 : a != 0 by rewrite -size_poly_eq0. *) *) (* (* set d := M _ _; set N := M _ _; set c := M _ _; set l := M _ _. *) *) (* (* have hdvd : rdvdp a (d * N - c * l) by admit. *) *) (* (* have := (rdivp_eq am ('X^(size a).*2.+1)). *) *) (* (* set q := rdivp _ _; set r := rmodp _ _; set M' := rdivp _ _. *) *) (* (* move=> Hqr. *) *) (* (* have H1 : M' * 'X^(size a).*2.+1 = (d * N - c * l) * q + M' * r. *) *) (* (* rewrite Hqr mulrDr. *) *) (* (* congr (_ + _). *) *) (* (* rewrite mulrC -mulrA mulrC. *) *) (* (* congr (_ * _). *) *) (* (* rewrite /M' mulrC rdivpK //. *) *) (* (* move: am. *) *) (* (* by rewrite monicE => /eqP ->; rewrite expr1n mulr1. *) *) (* (* have := (ltn_rmodpN0 'X^(size a).*2.+1 a0); rewrite -/r => Hr. *) *) (* (* have q0 : q != 0. *) *) (* (* apply/eqP => q0; move: Hqr Hr. *) *) (* (* rewrite q0 !mul0r add0r => <-. *) *) (* (* by rewrite size_polyXn -addnn -!addnS -{3}[size a]addn0 leq_add2l. *) *) (* (* have laq0 : lead_coef q * lead_coef a != 0. *) *) (* (* have H : GRing.lreg (lead_coef a). *) *) (* (* move: am. *) *) (* (* rewrite monicE => /eqP ->. *) *) (* (* exact: lreg1. *) *) (* (* by rewrite mulrC (mulrI_eq0 _ H) lead_coef_eq0. *) *) (* (* have Hsize : size q = (size a).+3. *) *) (* (* have := (size_polyXn R (size a).*2.+1). *) *) (* (* rewrite Hqr size_addl size_proper_mul //. *) *) (* (* rewrite -addnn -addSn => /eqP. *) *) (* (* rewrite -eqSS -!addSn prednK /=. *) *) (* (* by rewrite eqn_add2r => /eqP. *) *) (* (* by rewrite addn_gt0 !lt0n an0 orbT. *) *) (* (* move: q0. *) *) (* (* rewrite -size_poly_eq0. *) *) (* (* case: (size q) => // n _. *) *) (* (* exact: (ltn_addl n Hr). *) *) (* (* have Hm' : size M' <= (size a).+2. *) *) (* (* (* rewrite /M'. *) *) *) (* (* (* apply/(leq_trans (leq_rdivp (d * N - c * l) a)). *) *) *) (* (* (* rewrite /d /N /c /l. *) *) *) (* (* (* rewrite size_addl. *) *) *) (* (* (* case hij: (i == j). *) *) *) (* (* (* rewrite (eqP hij). *) *) *) (* (* (* rewrite size_proper_mul. *) *) *) (* (* (* move: (hs 0 0). *) *) *) (* (* (* rewrite eqxx => /eqP ->. *) *) *) (* (* (* move: (hs (lift 0 j) (lift 0 j)). *) *) *) (* (* (* rewrite eqxx => /eqP ->. *) *) *) (* (* (* rewrite addnS /=. *) *) *) (* (* (* move: (hs i j). *) *) *) (* (* (* done. *) *) *) (* (* admit. *) *) (* (* (* exact: (key_invariant Hs i j). *) *) *) (* (* have H2 : size (M' * r) <= (size a).*2.+1. *) *) (* (* rewrite (leq_trans (size_mul_leq M' r)) // -addnn. *) *) (* (* have := (leq_add Hm' Hr). *) *) (* (* rewrite !addSn addnS ltnS => HH. *) *) (* (* have H : (size M' + size r).-1 <= (size M' + size r). *) *) (* (* by case: (size M' + size r)%N. *) *) (* (* exact: (leq_trans H HH). *) *) (* (* rewrite (test H1 H2). *) *) (* (* case sa: (size a == 1)%N. *) *) (* (* by rewrite (eqP sa) prptnl0p -addnn mulrC. *) *) (* (* rewrite -Hsize -prptnl_mul Hsize mulrC. *) *) (* (* f_equal. *) *) (* (* rewrite -addnn !addSn -!addnS prednK. *) *) (* (* rewrite prednK //. *) *) (* (* by case: (size a) an0. *) *) (* (* by case: (size a) an0 sa => //= [[]]. *) *) (* (* Qed. *) *) (* End poly_op. *) (* (* Test computations *) *) (* (* *) (* WARNING never use compute, but vm_compute, *) (* otherwise it's painfully slow *) (* *) *) (* Require Import ZArith Zinfra. *) (* Section test. *) (* Definition excp n (M: Matrix [cringType Z of Z]) := ex_char_poly_mx n M. *) (* Definition idZ n := @ident _ [cringType Z of Z] n. *) (* Definition cpmxid2 := (excp 2 (idZ 2)). *) (* Definition cpid2 := (exBareiss_rec 2 [:: 1%Z] cpmxid2). *) (* Eval vm_compute in cpid2. *) (* Definition detid2 := horner_seq cpid2 0%Z. *) (* Eval vm_compute in detid2. *) (* Definition M2 := cM 19%Z [:: 3%Z] [:: (-2)%Z] (cM 26%Z [::] [::] (@eM _ _)). *) (* Definition cpmxM2 := excp 2 M2. *) (* Definition cpM2 := exBareiss 2 cpmxM2. *) (* Eval vm_compute in cpM2. *) (* Eval vm_compute in ex_bdet 2 M2. *) (* (* Random 3x3 matrix *) *) (* Definition M3 := *) (* cM 10%Z [:: (-42%Z); 13%Z] [:: (-34)%Z; 77%Z] *) (* (cM 15%Z [:: 76%Z] [:: 98%Z] *) (* (cM 49%Z [::] [::] (@eM _ _))). *) (* Time Eval vm_compute in ex_bdet 3 M3. *) (* (* Random 10x10 matrix *) *) (* Definition M10 := cM (-7)%Z [:: (-12)%Z ; (-15)%Z ; (-1)%Z ; (-8)%Z ; (-8)%Z ; 19%Z ; (-3)%Z ; (-8)%Z ; 20%Z] [:: 5%Z ; (-14)%Z ; (-12)%Z ; 19%Z ; 20%Z ; (-5)%Z ; (-3)%Z ; 8%Z ; 16%Z] (cM 1%Z [:: 16%Z ; (-18)%Z ; 8%Z ; (-13)%Z ; 18%Z ; (-6)%Z ; 10%Z ; 6%Z] [:: 5%Z ; 4%Z ; 0%Z ; 4%Z ; (-18)%Z ; (-19)%Z ; (-2)%Z ; 3%Z] (cM (-8)%Z [:: 1%Z ; (-10)%Z ; 12%Z ; 0%Z ; (-14)%Z ; 18%Z ; (-5)%Z] [:: (-14)%Z ; (-10)%Z ; 15%Z ; 0%Z ; 13%Z ; (-12)%Z ; (-16)%Z] (cM (-13)%Z [:: (-2)%Z ; (-14)%Z ; (-11)%Z ; 15%Z ; (-1)%Z ; 8%Z] [:: 6%Z ; 9%Z ; (-19)%Z ; (-19)%Z ; (-16)%Z ; (-10)%Z] (cM (-12)%Z [:: 1%Z ; (-5)%Z ; 16%Z ; 5%Z ; 6%Z] [:: 16%Z ; (-20)%Z ; 19%Z ; 16%Z ; 5%Z] (cM 2%Z [:: (-10)%Z ; (-3)%Z ; (-17)%Z ; 18%Z] [:: 4%Z ; (-4)%Z ; 20%Z ; (-7)%Z] (cM 4%Z [:: (-8)%Z ; 2%Z ; 9%Z] [:: 17%Z ; 10%Z ; 10%Z] (cM (-15)%Z [:: 16%Z ; 3%Z] [:: 5%Z ; (-1)%Z] (cM 3%Z [:: 4%Z] [:: (-12)%Z] ((@eM _ _)))))))))). *) (* Time Eval vm_compute in ex_bdet 10 M10. *) (* (* *) (* (* Random 20x20 matrix *) *) (* Definition M20 := cM (-17)%Z [:: 4%Z ; 9%Z ; 4%Z ; (-7)%Z ; (-4)%Z ; 16%Z ; (-13)%Z ; (-6)%Z ; (-4)%Z ; (-9)%Z ; 18%Z ; 7%Z ; 3%Z ; (-14)%Z ; 8%Z ; (-17)%Z ; 17%Z ; (-2)%Z ; 8%Z] [:: 0%Z ; 10%Z ; 17%Z ; (-7)%Z ; 3%Z ; 18%Z ; (-3)%Z ; 6%Z ; 2%Z ; (-7)%Z ; (-3)%Z ; 16%Z ; 7%Z ; (-9)%Z ; 15%Z ; (-17)%Z ; (-9)%Z ; (-18)%Z ; 9%Z] (cM 13%Z [:: (-3)%Z ; 9%Z ; 7%Z ; 4%Z ; 18%Z ; 2%Z ; 7%Z ; 9%Z ; (-10)%Z ; 18%Z ; 4%Z ; 13%Z ; (-16)%Z ; (-5)%Z ; 6%Z ; (-14)%Z ; 3%Z ; 12%Z] [:: 14%Z ; (-15)%Z ; 14%Z ; (-7)%Z ; 11%Z ; 10%Z ; (-10)%Z ; 9%Z ; (-4)%Z ; (-7)%Z ; (-4)%Z ; 7%Z ; (-10)%Z ; 15%Z ; (-4)%Z ; 12%Z ; (-18)%Z ; 4%Z] (cM 16%Z [:: (-5)%Z ; 8%Z ; 4%Z ; 8%Z ; 4%Z ; (-18)%Z ; 10%Z ; 3%Z ; (-12)%Z ; 12%Z ; 8%Z ; 11%Z ; (-12)%Z ; (-1)%Z ; 12%Z ; (-5)%Z ; (-10)%Z] [:: 1%Z ; (-15)%Z ; (-3)%Z ; (-3)%Z ; 6%Z ; (-3)%Z ; 18%Z ; 6%Z ; (-6)%Z ; (-10)%Z ; 15%Z ; 11%Z ; 6%Z ; (-4)%Z ; (-4)%Z ; 9%Z ; (-3)%Z] (cM (-12)%Z [:: 1%Z ; 6%Z ; 7%Z ; 5%Z ; 0%Z ; (-2)%Z ; 2%Z ; 14%Z ; 15%Z ; (-10)%Z ; (-14)%Z ; (-6)%Z ; 3%Z ; 17%Z ; (-11)%Z ; (-8)%Z] [:: (-15)%Z ; (-8)%Z ; 5%Z ; 18%Z ; 15%Z ; (-14)%Z ; 13%Z ; 17%Z ; 12%Z ; 16%Z ; (-18)%Z ; 13%Z ; 14%Z ; 17%Z ; (-8)%Z ; (-9)%Z] (cM (-17)%Z [:: (-12)%Z ; (-14)%Z ; (-7)%Z ; (-1)%Z ; 14%Z ; (-14)%Z ; (-13)%Z ; (-4)%Z ; 18%Z ; 13%Z ; (-9)%Z ; 15%Z ; (-10)%Z ; 18%Z ; 14%Z] [:: 8%Z ; (-14)%Z ; 9%Z ; 16%Z ; (-3)%Z ; (-8)%Z ; 9%Z ; (-9)%Z ; (-13)%Z ; 4%Z ; 15%Z ; 15%Z ; 6%Z ; (-14)%Z ; (-6)%Z] (cM 9%Z [:: 4%Z ; (-6)%Z ; 5%Z ; (-3)%Z ; (-6)%Z ; 18%Z ; 2%Z ; 10%Z ; 9%Z ; 17%Z ; (-12)%Z ; (-9)%Z ; 1%Z ; (-2)%Z] [:: (-10)%Z ; (-2)%Z ; 17%Z ; 14%Z ; 1%Z ; (-16)%Z ; 17%Z ; 18%Z ; (-3)%Z ; 4%Z ; (-14)%Z ; 17%Z ; 10%Z ; 7%Z] (cM 16%Z [:: (-15)%Z ; (-15)%Z ; (-18)%Z ; (-12)%Z ; 15%Z ; 7%Z ; (-11)%Z ; (-7)%Z ; (-8)%Z ; (-3)%Z ; (-17)%Z ; (-17)%Z ; (-12)%Z] [:: (-8)%Z ; 4%Z ; 12%Z ; (-7)%Z ; (-11)%Z ; 13%Z ; (-16)%Z ; 7%Z ; 16%Z ; (-1)%Z ; 16%Z ; 3%Z ; (-9)%Z] (cM (-15)%Z [:: 0%Z ; (-12)%Z ; 0%Z ; 16%Z ; 13%Z ; (-5)%Z ; 4%Z ; 1%Z ; 13%Z ; 11%Z ; 0%Z ; 16%Z] [:: 0%Z ; (-17)%Z ; (-10)%Z ; (-6)%Z ; 7%Z ; (-1)%Z ; 17%Z ; 8%Z ; 8%Z ; (-15)%Z ; (-16)%Z ; (-18)%Z] (cM 5%Z [:: 8%Z ; (-17)%Z ; (-15)%Z ; 0%Z ; 8%Z ; 1%Z ; (-2)%Z ; 14%Z ; 14%Z ; (-1)%Z ; (-7)%Z] [:: 14%Z ; (-11)%Z ; (-4)%Z ; (-18)%Z ; (-10)%Z ; (-11)%Z ; (-10)%Z ; (-6)%Z ; (-14)%Z ; (-13)%Z ; 5%Z] (cM (-7)%Z [:: 1%Z ; (-3)%Z ; (-7)%Z ; (-1)%Z ; 2%Z ; 14%Z ; 13%Z ; 7%Z ; 17%Z ; 7%Z] [:: 0%Z ; 1%Z ; (-7)%Z ; 12%Z ; (-1)%Z ; (-5)%Z ; (-12)%Z ; (-7)%Z ; 8%Z ; (-4)%Z] (cM 15%Z [:: (-18)%Z ; (-17)%Z ; 6%Z ; 1%Z ; (-13)%Z ; (-12)%Z ; 4%Z ; 13%Z ; 11%Z] [:: 12%Z ; 2%Z ; (-7)%Z ; (-18)%Z ; 0%Z ; 13%Z ; (-15)%Z ; (-16)%Z ; (-2)%Z] (cM 5%Z [:: (-9)%Z ; (-11)%Z ; 14%Z ; (-6)%Z ; (-11)%Z ; (-15)%Z ; (-12)%Z ; (-4)%Z] [:: (-12)%Z ; 8%Z ; (-8)%Z ; (-14)%Z ; 9%Z ; 3%Z ; 14%Z ; 3%Z] (cM (-18)%Z [:: 16%Z ; (-1)%Z ; 3%Z ; 11%Z ; 9%Z ; (-9)%Z ; 14%Z] [:: (-2)%Z ; (-7)%Z ; (-1)%Z ; 6%Z ; (-16)%Z ; 1%Z ; 6%Z] (cM 3%Z [:: (-8)%Z ; (-1)%Z ; (-1)%Z ; 15%Z ; 10%Z ; 6%Z] [:: 3%Z ; 7%Z ; 15%Z ; 12%Z ; 8%Z ; 5%Z] (cM (-14)%Z [:: (-2)%Z ; (-5)%Z ; 8%Z ; (-9)%Z ; 10%Z] [:: 12%Z ; 0%Z ; (-3)%Z ; 11%Z ; (-2)%Z] (cM 6%Z [:: (-8)%Z ; (-4)%Z ; (-9)%Z ; (-1)%Z] [:: 2%Z ; 5%Z ; (-8)%Z ; 0%Z] (cM (-14)%Z [:: (-8)%Z ; (-2)%Z ; 16%Z] [:: 11%Z ; 2%Z ; (-2)%Z] (cM 16%Z [:: (-14)%Z ; 9%Z] [:: (-17)%Z ; 8%Z] (cM (-18)%Z [:: (-11)%Z] [:: (-14)%Z] ((@eM _ _)))))))))))))))))))). *) (* Time Eval vm_compute in ex_bdet 20 M20. *) (* = 75728050107481969127694371861%Z *) (* : CZmodule.Pack (Phant Z_comRingType) (CRing.class Z_cringType) *) (* Z_cringType *) (* Finished transaction in 63. secs (62.825904u,0.016666s) *) (* *) *) (* End test. *) (* (* Extraction Language Haskell. *) *) (* (* Extraction "Bareiss" ex_bdet. *) *) coqeal-2.1.0/refinements/binint.v000066400000000000000000000423731475512565300167750ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From elpi Require Import derive. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. From mathcomp Require Import path choice fintype tuple finset bigop order. From mathcomp Require Import ssralg zmodp ssrnum ssrint. From CoqEAL Require Import hrel param refinements pos. (******************************************************************************) (* Attempt to refine SSReflect integers (ssrint) are to a new type *) (* paremetrized by positive numbers (represented by a sigma type) and natural *) (* numbers. This gives simpler proofs than in binint, but in order for this *) (* to be useful the parametricity part of the library must be used to change *) (* the representation of positive numbers and naturals to more efficient *) (* representations (e.g. N) which has not been done yet. *) (* *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Import GRing.Theory Order.Theory Num.Theory Refinements Op. (******************************************************************************) (** PART I: Defining generic datastructures and programming with them *) (******************************************************************************) Section binint_op. Variable N P : Type. Local Open Scope computable_scope. Inductive Z := Zpos of N | Zneg of P. Definition Zmatch T (n : Z) f g : T := match n with Zpos p => f p | Zneg n => g n end. Context `{zero_of N, one_of N, sub_of N, add_of N, mul_of N, exp_of N N, mod_of N, leq_of N, lt_of N, eq_of N}. Context `{one_of P, sub_of P, add_of P, mul_of P, exp_of P P, eq_of P, leq_of P, lt_of P}. Context `{cast_of N P, cast_of P N}. Context `{spec_of N nat, spec_of P pos}. Context `{implem_of nat N, implem_of pos P}. #[export] Instance zeroZ : zero_of Z := Zpos 0. #[export] Instance oneZ : one_of Z := Zpos 1. #[export] Instance addZ : add_of Z := fun x y : Z => match x, y with | Zpos x, Zpos y => Zpos (x + y) | Zneg x, Zneg y => Zneg (x + y) | Zpos x, Zneg y => if (cast y <= x) then Zpos (x - cast y) else Zneg (cast (cast y - x)) | Zneg x, Zpos y => if (cast x <= y) then Zpos (y - cast x) else Zneg (cast (cast x - y)) end. #[export] Instance oppZ : opp_of Z := fun x : Z => match x with | Zpos x => if (x == 0)%C then 0%C else Zneg (cast x) | Zneg x => Zpos (cast x) end. #[export] Instance subZ : sub_of Z := fun x y : Z => match x, y with | Zpos x, Zneg y => Zpos (x + cast y) | Zneg x, Zpos y => if (y == 0)%C then Zneg x else Zneg (x + cast y) | Zpos x, Zpos y => if (y <= x) then Zpos (x - y) else Zneg (cast (y - x)) | Zneg x, Zneg y => if ((cast x : N) <= (cast y : N)) then Zpos (cast y - cast x) else Zneg (cast ((cast x : N) - cast y)) end. #[export] Instance eqZ : eq_of Z := fun x y : Z => match x, y with | Zpos x, Zpos y => (x == y) | Zneg x, Zneg y => (x == y) | _, _ => false end. #[export] Instance mulZ : mul_of Z := fun x y : Z => match x, y with | Zpos x, Zpos y => Zpos (x * y) | Zneg x, Zpos y => if (y == 0)%C then 0%C else Zneg (x * cast y) | Zpos x, Zneg y => if (x == 0)%C then 0%C else Zneg (cast x * y) | Zneg x, Zneg y => Zpos (cast x * cast y) end. #[export] Instance expZ : exp_of Z N := fun x n => if (n == 0)%C then 1%C else match x with | Zpos x => Zpos (x ^ n) | Zneg x => if (n %% (1 + 1) == 0)%C then Zpos (cast (x ^ (cast n : P))) else Zneg (x ^ (cast n : P)) end. #[export] Instance leqZ : leq_of Z := fun x y : Z => match x, y with | Zpos x, Zpos y => (x <= y) | Zneg x, Zneg y => (y <= x) | Zneg _, Zpos _ => true | Zpos _, Zneg _ => false end. #[export] Instance ltZ : lt_of Z := fun x y : Z => match x, y with | Zpos x, Zpos y => (x < y) | Zneg x, Zneg y => (y < x) | Zneg _, Zpos _ => true | Zpos _, Zneg _ => false end. #[export] Instance cast_NZ : cast_of N Z := fun n : N => Zpos n. #[export] Instance cast_PZ : cast_of P Z := fun n : P => Zpos (cast n). #[export] Instance cast_ZN : cast_of Z N := fun z => if z is Zpos n then n else 0. #[export] Instance cast_ZP : cast_of Z P := fun z => cast (cast_ZN z). #[export] Instance specZ : spec_of Z int := fun x => (match x with | Zpos p => (spec p : nat)%:Z | Zneg n => - (spec (cast n : N): nat)%:Z end)%R. #[export] Instance implemZ : implem_of int Z := fun x => (match x with | Posz n => Zpos (implem n) | Negz n => Zneg (implem (posS n)) end). End binint_op. Elpi derive.param2 Z. Elpi derive.param2 Zmatch. Elpi derive.param2 zeroZ. Elpi derive.param2 oneZ. Elpi derive.param2 addZ. Elpi derive.param2 oppZ. Elpi derive.param2 subZ. Elpi derive.param2 eqZ. Elpi derive.param2 mulZ. Elpi derive.param2 expZ. Elpi derive.param2 leqZ. Elpi derive.param2 ltZ. Elpi derive.param2 cast_NZ. Elpi derive.param2 cast_PZ. Elpi derive.param2 cast_ZN. Elpi derive.param2 cast_ZP. (* Elpi derive.param2 int. *) (* Elpi derive.param2 sum. *) (* Definition specZ_simpl := Eval cbv in specZ. *) (* Elpi derive.param2 specZ_simpl. *) (* Realizer specZ as specZ_R := specZ_simpl_R. *) (******************************************************************************) (** PART II: Proving correctness properties of the previously defined objects *) (******************************************************************************) Section binint_theory. Notation Znp := (Z nat pos). Definition Z_of_int (m : int) : Znp := match m with | Posz m => Zpos _ m | Negz m => Zneg _ (posS m) end. Definition int_of_Z (m : Znp) : int := match m with | Zpos p => p%:Z | Zneg p => -(val p)%:Z end. Lemma Z_of_intK : pcancel Z_of_int (some \o int_of_Z). Proof. by rewrite /Z_of_int /int_of_Z => [[[]|]]. Qed. Local Open Scope rel_scope. Definition Rint : int -> Znp -> Type := fun_hrel int_of_Z. Local Instance zero_nat : zero_of nat := 0%N. Local Instance one_nat : one_of nat := 1%N. Local Instance add_nat : add_of nat := addn. Local Instance sub_nat : sub_of nat := subn. Local Instance mul_nat : mul_of nat := muln. Local Instance exp_nat : exp_of nat nat := expn. Local Instance mod_nat : mod_of nat := modn. Local Instance leq_nat : leq_of nat := ssrnat.leq. Local Instance lt_nat : lt_of nat := ssrnat.ltn. Local Instance eq_nat : eq_of nat := eqtype.eq_op. Local Instance spec_nat : spec_of nat nat := spec_id. Local Instance spec_ps : spec_of pos pos := spec_id. Local Instance implem_nat : implem_of nat nat := implem_id. Local Instance implem_ps : implem_of pos pos := implem_id. Lemma RintE n x : refines Rint n x -> n = int_of_Z x. Proof. by rewrite refinesE. Qed. Local Instance Rint_0 : refines Rint 0 0%C. Proof. by rewrite refinesE. Qed. Local Instance Rint_1 : refines Rint 1 1%C. Proof. by rewrite refinesE. Qed. Local Instance Rint_Posz : refines (Logic.eq ==> Rint) Posz cast. Proof. by rewrite refinesE=> n n' <-. Qed. Local Instance Rint_pos_to_int : refines (Logic.eq ==> Rint) pos_to_int cast. Proof. by rewrite refinesE=> n n' <-; rewrite /pos_to_int natz. Qed. Local Instance Rint_int_to_nat : refines (Rint ==> Logic.eq) int_to_nat cast. Proof. rewrite refinesE=> a b rab; rewrite [a]RintE {a rab}. case: b => [n|[n n_gt0]] //=; rewrite /cast /cast_ZP /cast_ZN /int_to_nat. by rewrite ltz_nat; have [->|] // := posnP n. by rewrite le_gtF // oppr_le0 ltW. Qed. Local Instance Rint_int_to_pos : refines (Rint ==> Logic.eq) int_to_pos cast. Proof. rewrite refinesE => a b rab; rewrite /int_to_pos. by rewrite [int_to_nat a]refines_eq {a rab}. Qed. Lemma eqSub (n m : nat) : int_of_Z (if (m <= n)%C then Zpos pos (n - m)%N else Zneg nat (cast (m - n)%N)) = (Posz n) - (Posz m). Proof. have [mn|nm] /= := leqP m n. have := mn. rewrite -[((_<=_)%N)]/(_<=_)%C => ->. by rewrite /= -subzn. rewrite [((_<=_)%C)]/(_<=_)%N ifN_eq=> /=. by rewrite insubdK -?topredE /= ?subn_gt0 // -?subzn 1?ltnW // opprB. by have := nm; rewrite lt0n_neq0 // subn_gt0. Qed. Local Instance Rint_add : refines (Rint ==> Rint ==> Rint) +%R +%C. Proof. rewrite refinesE /Rint /fun_hrel /add_op /= => _ x <- _ y <-. case: x y => [x|x] [y|y] //=; rewrite ?(add0r, addr0) //=; simpC. by rewrite (eqSub x (cast y)). by rewrite (eqSub y (cast x)) addrC. by rewrite insubdK -?topredE /= ?addn_gt0 ?valP // -opprB opprK addrC. Qed. Local Instance Rint_opp : refines (Rint ==> Rint) -%R -%C. Proof. rewrite refinesE /Rint /fun_hrel => _ x <-. by case: x => [[]|] //= n; rewrite ?insubdK ?opprK. Qed. Local Instance Rint_sub : refines (Rint ==> Rint ==> Rint) (fun x y => x - y) sub_op. Proof. rewrite refinesE /Rint /fun_hrel /sub_op => _ x <- _ y <-. case: x y=> [x|x] [y|y]; rewrite ?opprK //=; simpC. by rewrite (eqSub x y). have [->|y_neq0 /=] := (altP eqP); first by rewrite subr0. by rewrite !insubdK -?opprD -?topredE //= ?addn_gt0 ?valP ?lt0n. by rewrite (eqSub (cast y) (cast x)) addrC. Qed. Implicit Type n : nat. Implicit Type p : pos. Local Instance Rint_eq : refines (Rint ==> Rint ==> bool_R) eqtype.eq_op eq_op. Proof. have nat_nneg n p : bool_R (n == - (Posz (val p)) :> int) false. by rewrite gt_eqF // ltNz_nat -lt0n [(_ < _)%N]valP. rewrite refinesE=> _ x <- _ y <-; rewrite /eq_op /eqZ. case: x; case: y=> * /=; simpC; rewrite ?eqr_opp ?[- _ == _]eq_sym //; exact: bool_Rxx. Qed. Local Instance Rint_leq : refines (Rint ==> Rint ==> bool_R) Num.le leq_op. Proof. have nat_nleqneg n p : bool_R (n <= - (Posz (val p)) :> int) false. rewrite leNgt (@lt_le_trans _ _ 0) ?oppr_lt0 //=. apply: valP. have neg_leqnat n p : bool_R (- (Posz (val p)) <= n :> int) true. by rewrite lerNl (@le_trans _ _ 0) // oppr_le0 le0z_nat. rewrite refinesE=> _ x <- _ y <-; rewrite /leq_op /leqZ. case: x y => [x|x] [y|y] /=; rewrite -?[((_<=_)%C)]/(_<=_)%N ?lerN2 //; exact: bool_Rxx. Qed. Local Instance Rint_lt : refines (Rint ==> Rint ==> bool_R) Num.lt lt_op. Proof. rewrite refinesE /Rint /fun_hrel /eq_op => _ x <- _ y <-. have -> : (int_of_Z x < int_of_Z y) = (x < y)%C. case: x y => [x|x] [y|y] //=. - by rewrite ltNge (@le_trans _ _ 0) // oppr_le0. - by rewrite (@lt_le_trans _ _ 0) // oppr_lt0; apply: valP. by rewrite ltrN2. exact: bool_Rxx. Qed. Local Instance Rint_mul : refines (Rint ==> Rint ==> Rint) *%R *%C. Proof. rewrite refinesE /Rint /fun_hrel /mul_op => _ x <- _ y <-. case: x y => [x|x] [y|y] //=; simpC; last by rewrite mulrNN. have [->|y_neq0 /=] := (altP eqP); first by rewrite mul0r. by rewrite mulrN !insubdK -?topredE /= ?muln_gt0 ?valP ?andbT ?lt0n. have [->|y_neq0 /=] := (altP eqP); first by rewrite mulr0. by rewrite mulNr !insubdK -?topredE /= ?muln_gt0 ?valP ?andbT ?lt0n. Qed. Local Instance Rint_exp : refines (Rint ==> eq ==> Rint) (@GRing.exp _) exp_op. Proof. rewrite refinesE /Rint /fun_hrel /exp_op /expZ=> _ x <- _ n ->. case: n=> [|n] //=. rewrite /exp_op /exp_nat /exp_pos. case: x=> [x|[x xgt0]] //=; first by rewrite -natz natrX natz. rewrite /cast /cast_pos_nat val_insubd /cast_nat_pos val_insubd /=. rewrite expn_gt0 xgt0 /=. have expn_opp1 : (- 1) ^+ n.+1 = (if (n.+1 %% (1 + 1) == 0)%C then 1 else - 1) :> int. rewrite /eq_op /eq_nat /mod_op /mod_nat /add_op /add_nat /one_op /one_nat. rewrite addn1 modn2 -signr_odd. by case: (odd n.+1). case: ifP=> [neven|nodd] /=. by rewrite exprNn -natz natrX natz expn_opp1 neven mul1r. by rewrite val_insubd expn_gt0 xgt0 /= exprNn -natz natrX natz expn_opp1 nodd mulN1r. Qed. Local Instance Rint_specZ_r x : refines Rint (spec x) x. Proof. by rewrite !refinesE; case: x. Qed. Local Instance Rint_specZ_l : refines (Rint ==> Logic.eq) spec_id spec. Proof. by rewrite refinesE => a a' ra; rewrite [spec _]RintE. Qed. Local Instance Rint_implem : refines (Logic.eq ==> Rint) implem_id implem. Proof. rewrite refinesE=> _ x ->. by case: x. Qed. (*************************************************************************) (* PART III: Parametricity part *) (*************************************************************************) Section binint_parametricity. Section binint_nat_pos. Variables N P : Type. Variables (Rnat : nat -> N -> Type) (Rpos : pos -> P -> Type). Definition RZNP := (Rint \o Z_R Rnat Rpos)%rel. Context `{zero_of N, one_of N, sub_of N, add_of N, mul_of N, exp_of N N, mod_of N, leq_of N, eq_of N, lt_of N}. Context `{one_of P, sub_of P, add_of P, mul_of P, exp_of P P, eq_of P, leq_of P, lt_of P}. Context `{cast_of N P, cast_of P N}. Context `{spec_of N nat, spec_of P pos}. Context `{implem_of nat N, implem_of pos P}. Context `{!refines Rnat 0%N 0%C, !refines Rnat 1%N 1%C}. Context `{!refines Rpos pos1 1%C}. Context `{!refines (Rnat ==> Rnat ==> Rnat) addn +%C}. Context `{!refines (Rpos ==> Rpos ==> Rpos) add_pos +%C}. Context `{!refines (Rnat ==> Rnat ==> Rnat) subn sub_op}. Context `{!refines (Rpos ==> Rpos ==> Rpos) sub_pos sub_op}. Context `{!refines (Rnat ==> Rnat ==> Rnat) muln *%C}. Context `{!refines (Rpos ==> Rpos ==> Rpos) mul_pos *%C}. Context `{!refines (Rnat ==> Rnat ==> Rnat) expn exp_op}. Context `{!refines (Rpos ==> Rpos ==> Rpos) exp_pos exp_op}. Context `{!refines (Rnat ==> Rnat ==> Rnat) modn mod_op}. Context `{!refines (Rnat ==> Rnat ==> bool_R) ssrnat.leq leq_op}. Context `{!refines (Rnat ==> Rnat ==> bool_R) ssrnat.ltn lt_op}. Context `{!refines (Rpos ==> Rpos ==> bool_R) leq_pos leq_op}. Context `{!refines (Rpos ==> Rpos ==> bool_R) lt_pos lt_op}. Context `{!refines (Rnat ==> Rpos) (insubd pos1) cast}. Context `{!refines (Rpos ==> Rnat) val cast}. Context `{!refines (Rnat ==> Rnat ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (Rpos ==> Rpos ==> bool_R) eqtype.eq_op eq_op}. Context `{forall x, refines Rnat (spec x) x, forall x, refines Rpos (spec x) x}. (* Context `{!refines (Rnat ==> nat_R) spec_id spec, *) (* !refines (Rpos ==> pos_R) spec_id spec}. *) Context `{!refines (Rnat ==> Logic.eq) spec_id spec, !refines (Rpos ==> Logic.eq) spec_id spec}. Context `{!refines (Logic.eq ==> Rnat) implem_id implem, !refines (Logic.eq ==> Rpos) implem_id implem}. Local Notation Z := (Z N P). #[export] Instance RZNP_zeroZ : refines RZNP 0 0%C. Proof. param_comp zeroZ_R. Qed. #[export] Instance RZNP_oneZ : refines RZNP 1 1%C. Proof. param_comp oneZ_R. Qed. #[export] Instance RZNP_castNZ : refines (Rnat ==> RZNP) Posz cast. Proof. param_comp cast_NZ_R. Qed. #[export] Instance RZNP_castPZ : refines (Rpos ==> RZNP) pos_to_int cast. Proof. param_comp cast_PZ_R. Qed. #[export] Instance RZNP_castZN: refines (RZNP ==> Rnat) int_to_nat cast. Proof. rewrite /cast; param_comp cast_ZN_R. Qed. #[export] Instance RZNP_castZP: refines (RZNP ==> Rpos) int_to_pos cast. Proof. rewrite /cast; param_comp cast_ZP_R. Qed. #[export] Instance RZNP_addZ : refines (RZNP ==> RZNP ==> RZNP) +%R +%C. Proof. param_comp addZ_R. Qed. #[export] Instance RZNP_mulZ : refines (RZNP ==> RZNP ==> RZNP) *%R *%C. Proof. param_comp mulZ_R. Qed. #[export] Instance RZNP_oppZ : refines (RZNP ==> RZNP) -%R -%C. Proof. param_comp oppZ_R. Qed. #[export] Instance RZNP_subZ : refines (RZNP ==> RZNP ==> RZNP) (fun x y => x - y) sub_op. Proof. param_comp subZ_R. Qed. #[export] Instance RZNP_expZ : refines (RZNP ==> Rnat ==> RZNP) (@GRing.exp _) exp_op. Proof. param_comp expZ_R. Qed. #[export] Instance RZNP_eqZ : refines (RZNP ==> RZNP ==> bool_R) eqtype.eq_op (@Op.eq_op Z _). Proof. param_comp eqZ_R. Qed. #[export] Instance RZNP_leqZ : refines (RZNP ==> RZNP ==> bool_R) Num.le (@Op.leq_op Z _). Proof. param_comp leqZ_R. Qed. #[export] Instance RZNP_ltZ : refines (RZNP ==> RZNP ==> bool_R) Num.lt (@Op.lt_op Z _). Proof. param_comp ltZ_R. Qed. (* #[export] Instance RZNP_specZ_l : refines (RZNP ==> int_R) spec_id spec. *) (* Proof. param_comp specZ_R. Qed. *) #[export] Instance RZNP_specZ : refines (RZNP ==> Logic.eq) spec_id spec. Proof. eapply refines_trans; tc. rewrite refinesE=> x y rxy. case: rxy=> [n m rnm|p q rpq]; rewrite /spec /=; apply: congr1. exact: refinesP. apply: congr1; exact: refinesP. Qed. #[export] Instance RZNP_implemZ : refines (Logic.eq ==> RZNP) implem_id implem. Proof. eapply refines_trans; tc. rewrite refinesE=> _ x ->. case: x=> n /=. apply: Zpos_R. have heq : refines eq n n by rewrite refinesE. exact: refinesP. apply: Zneg_R. have heq : refines eq (posS n) (posS n) by rewrite refinesE. exact: refinesP. Qed. End binint_nat_pos. End binint_parametricity. End binint_theory. From CoqEAL Require Import binnat. Section testint. Goal (0 == 0 :> int). by coqeal. Abort. Goal (1 == 1 :> int). by coqeal. Abort. Goal (- 1%:Z == - 1%:Z). by coqeal. Abort. Goal (10%:Z - 5%:Z == 1 + 4%:Z). rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. by coqeal. Abort. Goal (-(1 + 2%:Z * 4%:Z) == -(1 + 2%:Z * 4%:Z)). rewrite -[X in (X == _)]/(spec_id _). rewrite [spec_id _]refines_eq /=. by coqeal. Abort. Goal (1000%:Z == 998%:Z + 2%:Z). by coqeal. Abort. Goal (1000%:Z == 2%:Z * 500%:Z). by coqeal. Abort. End testint. coqeal-2.1.0/refinements/binnat.v000066400000000000000000000372131475512565300167620ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) Require Import ZArith Lia. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. From CoqEAL Require Import hrel param refinements pos. (******************************************************************************) (** The binary naturals of Coq is a refinement of SSReflects naturals *) (* *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import Refinements.Op. (* Notation for when we export this file *) Notation N := N. Notation positive := positive. Section positive_op. Definition positive_of_pos (p : pos) : positive := Pos.of_nat (val p). Definition pos_of_positive (p : positive) : pos := insubd pos1 (Pos.to_nat p). #[export] Instance spec_positive : spec_of positive pos := pos_of_positive. #[export] Instance implem_positive : implem_of pos positive := positive_of_pos. #[export] Instance one_positive : one_of positive := xH. #[export] Instance add_positive : add_of positive := Pos.add. #[export] Instance sub_positive : sub_of positive := Pos.sub. #[export] Instance mul_positive : mul_of positive := Pos.mul. #[export] Instance le_positive : leq_of positive := Pos.leb. #[export] Instance lt_positive : lt_of positive := Pos.ltb. #[export] Instance eq_positive : eq_of positive := Pos.eqb. #[export] Instance exp_positive : exp_of positive positive := Pos.pow. End positive_op. Section positive_theory. Local Open Scope rel_scope. Lemma positive_of_posK : cancel positive_of_pos pos_of_positive. Proof. move=> n /=; rewrite /positive_of_pos /pos_of_positive /=. apply: val_inj; rewrite Nat2Pos.id ?insubdK -?topredE ?valP //. by apply/eqP; rewrite -lt0n valP. Qed. (* Why is this not in ssrnat? *) Lemma to_natE : forall (p : positive), Pos.to_nat p = nat_of_pos p. Proof. by elim=> //= p <-; rewrite ?Pos2Nat.inj_xI ?Pos2Nat.inj_xO NatTrec.trecE -mul2n. Qed. Lemma to_nat_gt0 p : 0 < Pos.to_nat p. Proof. by rewrite to_natE; elim: p => //= p; rewrite NatTrec.trecE double_gt0. Qed. Hint Resolve to_nat_gt0 : core. Lemma pos_of_positiveK : cancel pos_of_positive positive_of_pos. Proof. move=> n /=; rewrite /positive_of_pos /pos_of_positive /=. by rewrite val_insubd to_nat_gt0 Pos2Nat.id. Qed. Definition Rpos := fun_hrel pos_of_positive. Lemma RposE (p : pos) (x : positive) : refines Rpos p x -> p = pos_of_positive x. Proof. by rewrite refinesE. Qed. Lemma RposI (p : pos) (x : positive) : refines Rpos p x -> x = positive_of_pos p. Proof. by move=> /RposE ->; rewrite pos_of_positiveK. Qed. #[export] Instance Rpos_spec_pos_r x : refines Rpos (spec x) x. Proof. by rewrite !refinesE. Qed. (* #[export] Instance Rpos_spec_pos_l : refines (Rpos ==> pos_R) spec_id spec. *) (* Proof. *) (* rewrite refinesE=> x x'. *) (* rewrite -[Rpos]refinesE=> rx. *) (* rewrite [spec _]RposE [y in pos_of_positive y]RposI positive_of_posK /spec_id. *) (* exact: pos_Rxx. *) (* Qed. *) #[export] Instance Rpos_spec : refines (Rpos ==> Logic.eq) spec_id spec. Proof. by rewrite refinesE. Qed. #[export] Instance Rpos_implem : refines (Logic.eq ==> Rpos) implem_id implem. Proof. rewrite refinesE=> _ x ->. case: x=> n ngt0. by rewrite /Rpos /fun_hrel positive_of_posK. Qed. #[export] Instance Rpos_1 : refines Rpos (pos1 : pos) (1%C : positive). Proof. by rewrite !refinesE; apply: val_inj; rewrite /= insubdK. Qed. #[export] Instance Rpos_add : refines (Rpos ==> Rpos ==> Rpos) add_pos +%C. Proof. rewrite refinesE => _ x <- _ y <-; apply: val_inj. rewrite !val_insubd Pos2Nat.inj_add. by move: (Pos2Nat.is_pos x) (Pos2Nat.is_pos y) => /leP -> /leP ->. Qed. #[export] Instance Rpos_mul : refines (Rpos ==> Rpos ==> Rpos) mul_pos *%C. Proof. rewrite refinesE => _ x <- _ y <-; apply: val_inj. rewrite !val_insubd Pos2Nat.inj_mul. by move: (Pos2Nat.is_pos x) (Pos2Nat.is_pos y) => /leP -> /leP ->. Qed. #[export] Instance Rpos_sub : refines (Rpos ==> Rpos ==> Rpos) sub_pos sub_op. Proof. rewrite refinesE => _ x <- _ y <-; apply: val_inj; rewrite !val_insubd. move: (Pos2Nat.is_pos x) (Pos2Nat.is_pos y) => /leP -> /leP ->. have [/leP h|/leP h] := (ltnP (Pos.to_nat y) (Pos.to_nat x)). by have := (Pos2Nat.inj_sub x y); rewrite Pos2Nat.inj_lt => ->. rewrite /sub_op /sub_positive Pos.sub_le ?Pos2Nat.inj_le //. by rewrite subn_gt0 !ltnNge; move/leP: h ->. Qed. #[export] Instance Rpos_leq : refines (Rpos ==> Rpos ==> bool_R) leq_pos leq_op. Proof. rewrite refinesE=> _ x <- _ y <-; rewrite /leq_op /le_positive /leq_pos !val_insubd. move: (Pos2Nat.is_pos x) (Pos2Nat.is_pos y) => /leP -> /leP ->. by case: (Pos.leb_spec0 _ _); move /Pos2Nat.inj_le /leP; [move ->|rewrite -eqbF_neg; move/eqP ->]. Qed. #[export] Instance Rpos_lt : refines (Rpos ==> Rpos ==> bool_R) lt_pos lt_op. Proof. rewrite refinesE => /= _ x <- _ y <-; rewrite /lt_pos !val_insubd. move: (Pos2Nat.is_pos x) (Pos2Nat.is_pos y) => /leP -> /leP ->. have -> : (Pos.to_nat x < Pos.to_nat y) = (x < y)%C. by apply/ltP/idP => [|h]; rewrite -Pos2Nat.inj_lt -Pos.ltb_lt. exact: bool_Rxx. Qed. #[export] Instance Rpos_eq : refines (Rpos ==> Rpos ==> bool_R) eq_pos eq_op. Proof. rewrite refinesE=> _ x <- _ y <-; rewrite /eq_op /eq_positive /eq_pos. case: (Pos.eqb_spec _ _)=> [->|h]. by rewrite eqxx. suff H : (pos_of_positive x == pos_of_positive y) = false. by rewrite H. by apply/negP=> [/eqP /(can_inj pos_of_positiveK)]. Qed. Lemma pos2nat_inj_exp x y : Pos.to_nat (x ^ y) = Pos.to_nat x ^ Pos.to_nat y. Proof. have pos2nat_pow_xO a b (hab : Pos.to_nat (a ^ b) = Pos.to_nat a ^ Pos.to_nat b) : Pos.to_nat (a ^ b~0) = (Pos.to_nat a ^ Pos.to_nat b) ^ 2. by rewrite -Z2Nat.inj_pos Pos2Z.inj_pow Pos2Z.inj_xO Z.mul_comm Z.pow_mul_r // Z.pow_2_r -Pos2Z.inj_pow Z2Nat.inj_mul // Z2Nat.inj_pos multE hab mulnn. elim: y=> [y ihy|y ihy|]. by rewrite Pos2Nat.inj_xI multE expnS [in _ ^ _]mulnC expnM Pos.xI_succ_xO Pos.pow_succ_r Pos2Nat.inj_mul multE pos2nat_pow_xO. by rewrite Pos2Nat.inj_xO multE mulnC expnM pos2nat_pow_xO. by rewrite Pos2Nat.inj_1 expn1 Pos.pow_1_r. Qed. #[export] Instance Rpos_exp : refines (Rpos ==> Rpos ==> Rpos) exp_pos exp_op. Proof. rewrite refinesE /exp_op /exp_positive=> _ x <- _ y <-. apply: val_inj. by rewrite !val_insubd expn_gt0 !to_nat_gt0 pos2nat_inj_exp. Qed. End positive_theory. #[export] Typeclasses Opaque pos_of_positive positive_of_pos. #[global] Opaque pos_of_positive positive_of_pos. Section binnat_op. #[export] Instance zero_N : zero_of N := N.zero. #[export] Instance one_N : one_of N := N.one. #[export] Instance add_N : add_of N := N.add. Definition succN (n : N) : N := (1 + n)%C. #[export] Instance sub_N : sub_of N := N.sub. #[export] Instance exp_N : exp_of N N := N.pow. #[export] Instance mul_N : mul_of N := N.mul. #[export] Instance div_N : div_of N := N.div. #[export] Instance mod_N : mod_of N := N.modulo. #[export] Instance eq_N : eq_of N := N.eqb. #[export] Instance leq_N : leq_of N := N.leb. #[export] Instance lt_N : lt_of N := N.ltb. #[export] Instance cast_positive_N : cast_of positive N := Npos. #[export] Instance cast_N_positive : cast_of N positive := fun n => if n is Npos p then p else 1%C. #[export] Instance spec_N : spec_of N nat := nat_of_bin. #[export] Instance implem_N : implem_of nat N := bin_of_nat. End binnat_op. Section binnat_theory. Local Open Scope rel_scope. Definition Rnat : nat -> N -> Type := fun_hrel nat_of_bin. Lemma RnatE (n : nat) (x : N) : refines Rnat n x -> n = x. Proof. by rewrite refinesE. Qed. #[export] Instance Rnat_spec_r x : refines Rnat (spec x) x. Proof. by rewrite refinesE. Qed. #[export] Instance Rnat_spec_l : refines (Rnat ==> nat_R) spec_id spec. Proof. rewrite refinesE=> x x' rx. rewrite [spec _]RnatE /spec_id [y in nat_R y _]RnatE. exact: nat_Rxx. Qed. #[export] Instance Rnat_spec : refines (Rnat ==> Logic.eq) spec_id spec. Proof. by rewrite refinesE. Qed. #[export] Instance Rnat_implem : refines (Logic.eq ==> Rnat) implem_id implem. Proof. rewrite !refinesE => x _ <-. by rewrite /Rnat /fun_hrel /implem /implem_N bin_of_natK. Qed. #[export] Instance Rnat_0 : refines Rnat 0 0%C. Proof. by rewrite refinesE. Qed. #[export] Instance Rnat_1 : refines Rnat 1%nat 1%C. Proof. by rewrite refinesE. Qed. Lemma nat_of_add_bin b1 b2 : (b1 + b2)%num = b1 + b2 :> nat. Proof. by case: b1 b2 => [|p] [|q]; rewrite ?addn0 //= nat_of_add_pos. Qed. #[export] Instance Rnat_add : refines (Rnat ==> Rnat ==> Rnat) addn +%C. Proof. by rewrite refinesE => _ x <- _ y <-; rewrite /Rnat /fun_hrel nat_of_add_bin. Qed. #[export] Instance Rnat_S : refines (Rnat ==> Rnat) S succN. Proof. by rewrite !refinesE => m n rmn; rewrite -add1n /succN; apply: refinesP. Qed. Lemma nat_of_binK : forall x, N.of_nat (nat_of_bin x) = x. Proof. by case => //= p; apply: Nnat.N2Nat.inj; rewrite Nnat.Nat2N.id /= to_natE. Qed. #[export] Instance Rnat_sub : refines (Rnat ==> Rnat ==> Rnat) subn sub_op. Proof. rewrite refinesE => _ x <- _ y <-. by apply: Nnat.Nat2N.inj; rewrite Nnat.Nat2N.inj_sub !nat_of_binK. Qed. Lemma nat_of_mul_bin b1 b2 : (b1 * b2)%num = b1 * b2 :> nat. Proof. by case: b1 b2 => [|p] [|q]; rewrite ?muln0 //= nat_of_mul_pos. Qed. #[export] Instance Rnat_mul : refines (Rnat ==> Rnat ==> Rnat) muln mul_op. Proof. rewrite refinesE => _ x <- _ y <-; rewrite /Rnat /fun_hrel /=. by rewrite nat_of_mul_bin. Qed. #[export] Instance Rnat_div_eucl : refines (Rnat ==> Rnat ==> prod_R Rnat Rnat) edivn N.div_eucl. Proof. rewrite refinesE /Rnat /fun_hrel=> _ x <- _ y <-. rewrite edivn_def /=. case: x=> [|x] /=; first by rewrite div0n mod0n. case: y=> [|y] //=. have hspec := N.pos_div_eucl_spec x (N.pos y). have hrem := N.pos_div_eucl_remainder x (N.pos y). destruct N.pos_div_eucl. rewrite -[nat_of_pos _]/(nat_of_bin (N.pos _)) hspec /= {hspec}. rewrite nat_of_add_bin nat_of_mul_bin. have rem_lt_div : (n0 < N.pos y)%N. have pos_ne0 : N.pos y <> 0%num by []. have /= := hrem pos_ne0. rewrite /N.lt Nnat.N2Nat.inj_compare /= to_natE. move/nat_compare_lt/ltP. case: n0 {hrem}=> //= p. by rewrite to_natE. rewrite modnMDl modn_small ?rem_lt_div // divnMDl /= -?to_natE ?to_nat_gt0 //. by rewrite divn_small ?addn0 // ?to_natE. Qed. (* chunk of proof extracted from below to avoid tc generating spurious universe constraints *) Lemma Rnat_div_subproof x x' (rx : refines Rnat x x') y y' (ry : refines Rnat y y') : refines (prod_R Rnat Rnat) (edivn x y) (N.div_eucl x' y'). Proof. tc. Qed. #[export] Instance Rnat_div : refines (Rnat ==> Rnat ==> Rnat) divn div_op. Proof. apply refines_abstr2; rewrite /divn /div_op /div_N /N.div=> x x' rx y y' ry. exact: (refines_apply (refines_fst_R _ _) (Rnat_div_subproof _ _)). Qed. #[export] Instance Rnat_mod : refines (Rnat ==> Rnat ==> Rnat) modn mod_op. Proof. apply refines_abstr2; rewrite /mod_op /mod_N /N.modulo=> x x' rx y y' ry. rewrite modn_def. exact: (refines_apply (refines_snd_R _ _) (Rnat_div_subproof _ _)). Qed. #[export] Instance Rnat_exp : refines (Rnat ==> Rnat ==> Rnat) expn exp_op. Proof. rewrite refinesE => _ x <- _ y <-; rewrite /Rnat /fun_hrel /=. rewrite /exp_op /exp_N /N.pow. case: x y => [|x] [|y] //. rewrite exp0n //=; elim: y => //= p. by rewrite natTrecE double_gt0. have nat_of_binposE p : nat_of_bin (N.pos p) = Pos.to_nat p. elim: p=> [p ihp|p ihp|] /=; last (by rewrite Pos2Nat.inj_1); by rewrite ?(Pos2Nat.inj_xI, Pos2Nat.inj_xO) multE NatTrec.doubleE to_natE mul2n. by rewrite !nat_of_binposE pos2nat_inj_exp. Qed. #[export] Instance Rnat_eq : refines (Rnat ==> Rnat ==> bool_R) eqtype.eq_op eq_op. Proof. rewrite refinesE=> _ x <- _ y <-; rewrite /eq_op /eq_N. case: (N.eqb_spec _ _) => [->|/eqP hneq]. by rewrite eqxx. suff H : (nat_of_bin x == nat_of_bin y) = false. by rewrite H. by apply/negP => [/eqP /(can_inj nat_of_binK)]; apply/eqP. Qed. #[export] Instance Rnat_leq : refines (Rnat ==> Rnat ==> bool_R) ssrnat.leq leq_op. Proof. rewrite refinesE=> _ x <- _ y <-; rewrite /leq_op /leq_N /leq. case: (N.leb_spec0 _ _)=> [/N.sub_0_le|]=> h. by rewrite [x - y]RnatE [(_ - _)%C]h /= eqxx. suff H : (nat_of_bin x - nat_of_bin y == 0) = false. by rewrite H. apply/negP=> /eqP; rewrite [x - y]RnatE [0]RnatE. by move/(can_inj nat_of_binK)/N.sub_0_le. Qed. #[export] Instance Rnat_lt : refines (Rnat ==> Rnat ==> bool_R) ltn lt_op. Proof. apply refines_abstr2 => x x' rx y y' ry; rewrite refinesE /Rnat /fun_hrel. rewrite /lt_op /lt_N N.ltb_antisym /ltn /= ltnNge [(y <= x)%N]refines_eq. exact: bool_Rxx. (* Cyril: this was wrong to do it like that, we should come back and fix *) Qed. #[export] Instance Rnat_cast_positive_N : refines (Rpos ==> Rnat) val (cast : positive -> N). Proof. rewrite refinesE /cast /Rnat /fun_hrel => x x' rx. by rewrite [x]RposE val_insubd to_nat_gt0 to_natE. Qed. #[export] Instance Rnat_cast_N_positive : refines (Rnat ==> Rpos) (insubd pos1) (cast : N -> positive). Proof. rewrite refinesE=> x x' rx; rewrite [x]RnatE. case: x' {x rx} => [|p] /=; last by rewrite -to_natE. rewrite /insubd insubF //= /cast; apply refinesP. apply Rpos_1. Qed. Lemma Rnat_eqE (c d : N) : (c == d)%C = (spec_N c == spec_N d). Proof. symmetry; eapply refines_eq. refines_apply. refines_abstr. Qed. Lemma Rnat_ltE (c d : N) : (c < d)%C = (spec_N c < spec_N d). Proof. symmetry; eapply refines_eq. change (spec_N c < spec_N d) with (rel_of_simpl ltn (spec_N c) (spec_N d)). refines_apply1; first refines_apply1. refines_abstr. Qed. Lemma Rnat_ltP x y : reflect (x < y)%num (spec_N x < spec_N y). Proof. by apply: (iffP idP); rewrite -Rnat_ltE /lt_op /lt_N; apply N.ltb_lt. Qed. Lemma Rnat_leE (c d : N) : (c <= d)%C = (spec_N c <= spec_N d)%N. Proof. symmetry; eapply refines_eq. refines_apply. refines_abstr. Qed. Lemma Rnat_eqxx (c : N) : (c == c)%C. Proof. by rewrite Rnat_eqE. Qed. Definition Rnat_E := (Rnat_eqE, Rnat_ltE, Rnat_leE). Lemma map_spec_N_inj : injective (map spec_N). Proof. apply inj_map => m n Hmn. rewrite -(nat_of_binK m) -(nat_of_binK n). by rewrite /spec_N in Hmn; rewrite Hmn. Qed. Lemma Nat2Pos_xI m : ((Pos.of_nat m.+1)~1)%positive = Pos.of_nat ((m.+1).*2.+1). Proof. rewrite -muln2 [RHS]Nat2Pos.inj_succ // Nat2Pos.inj_mul //. simpl (Pos.of_nat 2); lia. Qed. Lemma Nat2Pos_xO m : ((Pos.of_nat m.+1)~0)%positive = Pos.of_nat ((m.+1).*2). Proof. rewrite -muln2 Nat2Pos.inj_mul //. simpl (Pos.of_nat 2); lia. Qed. Lemma pos_of_natE m n : pos_of_nat m n = Pos.of_nat (maxn 1 (m.*2.+1 - n)). Proof. elim: m n => [|m IHm] n; first by rewrite /= double0 (maxn_idPl (leq_subr _ _)). simpl. case: n => [|n]; last case: n => [|n]; last by rewrite IHm. - rewrite subn0 IHm. have->: (m.*2.+1 - m = m.+1)%N. rewrite -addnn subSn; first by rewrite addnK. exact: leq_addr. by rewrite !(maxn_idPr _) // Nat2Pos_xI. - rewrite subn1 IHm. have->: (m.*2.+1 - m = m.+1)%N. rewrite -addnn subSn; first by rewrite addnK. exact: leq_addr. by rewrite !(maxn_idPr _) // Nat2Pos_xO. Qed. Lemma bin_of_natE : bin_of_nat =1 N.of_nat. move=> n. by rewrite -[bin_of_nat n]nat_of_binK bin_of_natK. Qed. End binnat_theory. #[export] Typeclasses Opaque nat_of_bin bin_of_nat. #[global] Opaque nat_of_bin bin_of_nat. Section test. Lemma test : 10000%num * 10000%num * (99999999%num + 1) = 10000000000000000%num. Proof. by rewrite [X in X = _]RnatE; compute; reflexivity. Qed. Lemma test' : 10000%num * 10000%num * (99999999%num + 1) = 10000000000000000%num. Proof. by apply/eqP; rewrite [_ == _]refines_eq. Qed. End test. coqeal-2.1.0/refinements/binord.v000066400000000000000000000114571475512565300167660ustar00rootroot00000000000000Require Import ZArith. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. From CoqEAL Require Import hrel param refinements binnat. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import Refinements.Op zmodp. Local Open Scope ring_scope. Section binord_op. Definition binord := fun (_ : nat) => N. #[export] Instance zero_ord n : zero_of (binord n) := N.zero. #[export] Instance one_ord n : one_of (binord n.+1) := if (n == 0)%N then N.zero else N.one. #[export] Instance opp_ord n : opp_of (binord n) := fun x => N.modulo ((implem n) - x) (implem n). #[export] Instance add_ord n : add_of (binord n) := fun x y => N.modulo (x + y) (implem n). #[export] Instance sub_ord n : sub_of (binord n) := fun x y => N.modulo (x + (N.modulo ((implem n) - y) (implem n))) (implem n). #[export] Instance mul_ord n : mul_of (binord n) := fun x y => N.modulo (x * y) (implem n). #[export] Instance exp_ord n : exp_of (binord n) N := fun x y => N.modulo (x ^ y) (implem n). #[export] Instance eq_ord n : eq_of (binord n) := N.eqb. #[export] Instance leq_ord n : leq_of (binord n) := N.leb. #[export] Instance lt_ord n : lt_of (binord n) := N.ltb. #[export] Instance implem_ord n : implem_of 'I_n (binord n) := fun x => implem (x : nat). End binord_op. Section binord_theory. Local Open Scope rel_scope. Definition Rord n1 n2 (rn : nat_R n1 n2) : 'I_n1 -> binord n2 -> Type := fun x y => Rnat x y. #[export] Instance Rord_0 n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn)) 0%R 0%C. Proof. by rewrite refinesE. Qed. #[export] Instance Rord_1 n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn)) Zp1 1%C. Proof. rewrite refinesE /Rord /Zp1 /inZp /= modn_def (nat_R_eq rn). by case: n2 rn. Qed. Local Instance refines_nat_R_S n1 n2 : refines nat_R n1 n2 -> refines nat_R n1.+1 n2.+1. Proof. rewrite refinesE; exact: S_R. Qed. Local Instance refines_implem_eq A B (R : A -> B -> Type) `{implem_of A B, !refines (eq ==> R) implem_id implem} x y : refines eq x y -> refines R x (implem y). Proof. move=> eqxy. rewrite -[x]/(implem_id _). exact: refines_apply. Qed. Local Arguments Rord /. Local Arguments opp_op /. Local Arguments opp_ord /. Local Arguments N.sub : simpl nomatch. #[export] Instance Rord_opp n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn)) -%R -%C. Proof. rewrite refinesE=> x x' hx /=. exact: refinesP. Qed. Local Arguments add_op /. Local Arguments add_ord /. #[export] Instance Rord_add n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) +%R +%C. Proof. rewrite refinesE=> x x' hx y y' hy /=. exact: refinesP. Qed. Local Arguments sub_op /. Local Arguments sub_ord /. #[export] Instance Rord_sub n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) (fun x y => x - y) sub_op. Proof. rewrite refinesE=> x x' hx y y' hy /=. exact: refinesP. Qed. Local Arguments mul_op /. Local Arguments mul_ord /. #[export] Instance Rord_mul n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> Rord (S_R rn)) (@Zp_mul _) *%C. Proof. rewrite refinesE=> x x' hx y y' hy /=. exact: refinesP. Qed. Local Arguments eq_op /. Local Arguments eq_ord /. #[export] Instance Rord_eq n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) eqtype.eq_op eq_op. Proof. rewrite refinesE=> x x' hx y y' hy /=. have -> : (x == y) = (x == y :> nat) by []. exact: refinesP. Qed. Local Arguments leq_op /. Local Arguments leq_ord /. #[export] Instance Rord_leq n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) (fun x y => (x <= y)%N) leq_op. Proof. rewrite refinesE=> x x' hx y y' hy /=. exact: refinesP. Qed. Local Arguments lt_op /. Local Arguments lt_ord /. Local Opaque ltn. #[export] Instance Rord_lt n1 n2 (rn : nat_R n1 n2) : refines (Rord (S_R rn) ==> Rord (S_R rn) ==> bool_R) (fun x y => ltn x y) lt_op. Proof. rewrite refinesE=> x x' hx y y' hy /=. try change (pred_of_simpl (ltn x) y) with (rel_of_simpl ltn x y). exact: refinesP. Qed. Local Arguments implem_id /. Local Arguments implem /. Local Arguments implem_ord /. #[export] Instance Rord_implem n1 n2 (rn : nat_R n1 n2) : refines (ordinal_R rn ==> Rord rn) implem_id implem. Proof. rewrite refinesE=> x y rxy /=. rewrite -[implem_N]/implem. have hxy : refines eq (nat_of_ord x) (nat_of_ord y). rewrite refinesE. case: rxy=> m1 m2 rm _ _ _ /=. by rewrite (nat_R_eq rm). exact: refinesP. Qed. #[export] Instance Rnat_nat_of_ord n1 n2 (rn : nat_R n1 n2) : refines (Rord rn ==> Rnat) (@nat_of_ord n1) id. Proof. by rewrite refinesE. Qed. End binord_theory. coqeal-2.1.0/refinements/binrat.v000066400000000000000000000567631475512565300170010ustar00rootroot00000000000000(** * A refinement of Mathcomp's rationals [rat] with [bigQ] from Coq standard library. *) Require Import ZArith QArith Lia. From Bignums Require Import BigQ. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat order. From mathcomp Require Import ssralg ssrnum ssrint rat div intdiv. From CoqEAL.refinements Require Import hrel refinements param binint. Import Refinements.Op. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Local Open Scope Z_scope. Delimit Scope Z_scope with coqZ. Import GRing.Theory Order.Theory Num.Theory. Section classes. Class max_of C := max_op : C -> C -> C. Class min_of C := min_op : C -> C -> C. End classes. (** ** Link between [Z] (Coq standard lib) and [int] (Mathcomp) *) Section Zint. (** *** Various lemmas about [nat_of_pos] *) Lemma nat_of_pos_inj x y : nat_of_pos x = nat_of_pos y -> x = y. Proof. rewrite -!binnat.to_natE; apply Pos2Nat.inj. Qed. Lemma nat_of_pos_gt0 p : (0 < nat_of_pos p)%N. Proof. by elim: p =>//= p IHp; rewrite NatTrec.doubleE double_gt0. Qed. Lemma nat_of_pos_gtr0 p : (0 < Posz (nat_of_pos p))%R. Proof. by rewrite -[0%R]/(Posz 0) ltz_nat nat_of_pos_gt0. Qed. Lemma Posz_nat_of_pos_neq0 p : Posz (nat_of_pos p) == 0%R = false. Proof. rewrite -binnat.to_natE. case E: (Pos.to_nat _)=>//; exfalso; move: E. by move: (binnat.to_nat_gt0 p); case (Pos.to_nat _). Qed. (** *** Conversion from [Z] to [int] *) Definition Z2int (z : BinNums.Z) := match z with | Z0 => 0%:Z | Z.pos p => (nat_of_pos p)%:Z | Z.neg n => (- (nat_of_pos n)%:Z)%R end. (** *** Conversion from [int] to [Z] *) Definition int2Z (n : int) : BinNums.Z := match n with | Posz O => Z0 | Posz n => Z.pos (Pos.of_nat n) | Negz n => Z.neg (Pos.of_nat n.+1) end. Lemma Z2int_inj x y : Z2int x = Z2int y -> x = y. Proof. rewrite /Z2int. case x, y=>//. { move=>[] H. by rewrite -[Z0]/(Z.of_nat 0%N) H -binnat.to_natE positive_nat_Z. } { rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=. case E: (Pos.to_nat _)=>//=. by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. } { rewrite -binnat.to_natE; case E: (Pos.to_nat _)=>//=. by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. } { by move=>[] /nat_of_pos_inj ->. } { rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=. case (Pos.to_nat p0)=>//=. by move=>[] H; move: (binnat.to_nat_gt0 p); rewrite H ltnn. } { rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=. case E: (Pos.to_nat _)=>//=. by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. } { rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=. case E: (Pos.to_nat p)=>//=. by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. } rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=. case E: (Pos.to_nat p)=>//=. { by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. } case E': (Pos.to_nat p0)=>//= [] [] H. by move: E'; rewrite -H -E=>/Pos2Nat.inj ->. Qed. Lemma int2ZK : cancel int2Z Z2int. Proof. case => [n|n]; case: n => [|n] //=. case: n => [//|n]. { by rewrite -binnat.to_natE -Nat2Pos.inj_succ // Nat2Pos.id. } case: n => [//|n]. { by rewrite -binnat.to_natE -!Nat2Pos.inj_succ // Nat2Pos.id. } Qed. Lemma Z2intK : cancel Z2int int2Z. Proof. case => [|p|p] //=. { have Pp := nat_of_pos_gt0 p. by rewrite /= -(prednK Pp) (prednK Pp) -binnat.to_natE Pos2Nat.id. } rewrite /int2Z. have Pp := nat_of_pos_gt0 p. rewrite -(prednK Pp) {Pp} /= -!binnat.to_natE. rewrite -[in RHS](Pos2Nat.id p). set n := Pos.to_nat p. by case: n. Qed. (** *** [Z2int] is a morphism for arithmetic operations *) Lemma Z2int_opp n : Z2int (- n) = (- (Z2int n))%R. Proof. by case n=>// p /=; rewrite GRing.opprK. Qed. Lemma Z2int_abs x : Z2int (Z.abs x) = `|Z2int x|%nat. Proof. by case: x => // p /=; rewrite abszN. Qed. Lemma Z2int_add x y : Z2int (x + y) = (Z2int x + Z2int y)%R. Proof. rewrite /Z2int /GRing.add /= /intZmod.addz /Z.add; case x, y=>//. { rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz. by case (Pos.to_nat p)=>// n; rewrite subn0. } { by rewrite addn0. } { (try by rewrite nat_of_add_pos) || by rewrite nat_of_addn_gt0. } { rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz. move: (Z.pos_sub_discr p p0); case (Z.pos_sub _ _). { move<-; rewrite -binnat.to_natE; case (Pos.to_nat _)=>// n. by rewrite ltnSn subnn. } { move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add. case (Pos.to_nat p0); [by rewrite Nat.add_0_l addn0|move=> n]. rewrite ifT; [by rewrite plusE addKn|]. by rewrite plusE; apply ltn_addr; rewrite ltnSn. } move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add. case (Pos.to_nat p'). { rewrite Nat.add_0_r; case (Pos.to_nat p)=>// n. by rewrite ltnSn subnn. } move=> n. case E: (Pos.to_nat p)=>/=; [by rewrite subn0|]. rewrite ifF. { by rewrite plusE addnS -addSn addKn. } by rewrite plusE addnS -addSn -ltn_subRL subnn ltn0. } { rewrite /GRing.opp /= /intZmod.oppz -binnat.to_natE. by case (Pos.to_nat p); [rewrite addn0|move=>n; rewrite subn0]. } { rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz. move: (Z.pos_sub_discr p p0); case E': (Z.pos_sub _ _). { move<-; rewrite -binnat.to_natE Z.pos_sub_diag; case (Pos.to_nat _)=>// n. by rewrite ltnSn subnn. } { move=> ->. rewrite -!binnat.to_natE Pos2Nat.inj_add Z.pos_sub_lt; last first. { by apply Pos.lt_add_diag_r. } rewrite -binnat.to_natE Pos2Nat.inj_sub ?Pos2Nat.inj_add; last first. { by apply Pos.lt_add_diag_r. } rewrite plusE minusE addKn; case (Pos.to_nat _). { by rewrite addn0; case (Pos.to_nat p0)=>// n; rewrite ltnSn subnn. } move=> n. case E: (Pos.to_nat p0 + n.+1)%N. { by exfalso; move: E; rewrite addnS. } rewrite -E ifF. { f_equal. have H: (Pos.to_nat p0 + n.+1 - n.+1 = Pos.to_nat p0 + n.+1 - n.+1)%N. { done. } move: H; rewrite {2}E addnK=>->. by rewrite subnS subSn /= ?subKn //; move: E; rewrite addnS=>[] [] <-; rewrite leq_addl. } by rewrite addnS -ltn_subRL subnn ltn0. } move=> ->; rewrite Z.pos_sub_gt; [|by apply Pos.lt_add_diag_r]. rewrite -!binnat.to_natE !Pos2Nat.inj_sub; [|by apply Pos.lt_add_diag_r]. rewrite Pos2Nat.inj_add; case (Pos.to_nat p). { by rewrite plusE minusE !add0n subn0. } by move=> n; rewrite plusE minusE addKn ifT // leq_addr. } rewrite -!binnat.to_natE Pos2Nat.inj_add /GRing.opp /= /intZmod.oppz plusE. case (Pos.to_nat p). { by rewrite add0n; case (Pos.to_nat p0)=>// n; rewrite ltn0 subn0. } move=> n; case (Pos.to_nat p0); [by rewrite addn0 ltn0 subn0|]. by move=> n'; rewrite addSn -addnS. Qed. Lemma Z2int_mul_nat_of_pos (x : BinNums.Z) (y : positive) : (Z2int x * nat_of_pos y)%R = Z2int (Z.mul x (BinNums.Zpos y)). Proof. rewrite /Z2int; case Ex: x. { by rewrite mul0r Z.mul_0_l. } { by rewrite /= -!binnat.to_natE Pos2Nat.inj_mul. } by rewrite /= mulNr -!binnat.to_natE Pos2Nat.inj_mul. Qed. Lemma Z2int_mul x y : Z2int (x * y) = (Z2int x * Z2int y)%R. Proof. case y=>/=. { by rewrite GRing.mulr0 Z.mul_0_r. } { by move=> p; rewrite Z2int_mul_nat_of_pos. } move=> p. by rewrite GRing.mulrN Z2int_mul_nat_of_pos -Z2int_opp Zopp_mult_distr_r. Qed. Lemma divE x y : Nat.div x y = divn x y. Proof. case: y => [//|y]. rewrite /Nat.div. move: (Nat.divmod_spec x y 0 y). case: Nat.divmod => q r /(_ (le_n _)) []. rewrite Nat.mul_0_r Nat.sub_diag !Nat.add_0_r Nat.mul_comm => + Hr /=. rewrite multE minusE plusE => /(f_equal (fun x => divn x y.+1)) ->. rewrite divnMDl // divn_small ?addn0 //. rewrite ltn_subLR; [|exact/ssrnat.leP]. by rewrite -addSnnS addnC addnS ltnS leq_addr. Qed. (* Mathcomp's divz and Z.div don't match for negative values. *) Lemma Z2int_div x y : Z.le 0 x -> Z.le 0 y -> Z2int (Z.div x y) = (Z2int x %/ Z2int y)%Z. Proof. case: x => [|x|//] _; [by rewrite intdiv.div0z|]. case: y => [|y|//] _; [by rewrite intdiv.divz0|]. rewrite -!positive_nat_Z -Nat2Z.inj_div; last first. rewrite !positive_nat_Z /= /divz gtr0_sgz ?mul1r; last first. { exact: nat_of_pos_gt0. } rewrite divE !binnat.to_natE absz_nat /Z2int. move: (Zle_0_nat (nat_of_pos x %/ nat_of_pos y)). rewrite -[X in _ = Posz X]Nat2Z.id. by case: Z.of_nat => //= p _; rewrite binnat.to_natE. Qed. Lemma Z2int_le x y : (Z2int x <= Z2int y)%R <-> Z.le x y. Proof. rewrite /Z2int; case Ex: x; case Ey: y=> //. { rewrite oppr_ge0; split; move=> H; exfalso; move: H; [|by rewrite /Z.le]. apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. } { split; move=> H; exfalso; move: H; [|by rewrite /Z.le]. apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. } { rewrite -!binnat.to_natE /Num.Def.ler /=. by rewrite -!positive_nat_Z -Nat2Z.inj_le; split => /ssrnat.leP. } { split; move=> H; exfalso; move: H; [|by rewrite /Z.le]. apply /negP; rewrite -ltNge. by apply: (@lt_trans _ _ 0%R); rewrite ?oppr_lt0; apply nat_of_pos_gt0. } { rewrite oppr_le0; split; by rewrite /Z.le. } { split=>_; [by rewrite /Z.le|]. by apply: (@le_trans _ _ 0%R); [apply oppr_le0|apply ltW, nat_of_pos_gt0]. } rewrite lerN2; split. { rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /= => /ssrnat.leP. by rewrite -Pos.compare_antisym -Pos2Nat.inj_le -Pos.compare_le_iff. } rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /=. rewrite -Pos.compare_antisym => H; apply/ssrnat.leP. by rewrite -Pos2Nat.inj_le -Pos.compare_le_iff. Qed. Lemma Z2int_lt x y : (Z2int x < Z2int y)%R <-> Z.lt x y. Proof. rewrite -lezD1 -[1%R]/(Z2int 1) -Z2int_add Z2int_le; lia. Qed. Lemma nat_of_pos_Z_to_pos x : nat_of_pos x = `|Z2int (Z.pos x)|%N. Proof. by rewrite /absz /Z2int. Qed. Lemma Zabs_natE n : Z.abs_nat n = `|Z2int n|%N. Proof. case: n => //= p; first by rewrite binnat.to_natE. by rewrite abszN absz_nat binnat.to_natE. Qed. Lemma Z2int_Z_of_nat n : Z2int (Z.of_nat n) = n. Proof. by case: n => //= n; rewrite Pos.of_nat_succ -binnat.to_natE Nat2Pos.id. Qed. (** *** Various lemmas about gcd *) Lemma dvdnP m n : reflect (Z.divide (Z.of_nat m) (Z.of_nat n)) (m %| n). Proof. apply: (iffP idP) => H. { rewrite dvdn_eq in H; rewrite -(eqP H) /Z.divide; exists (Z.of_nat (n %/ m)). by rewrite Nat2Z.inj_mul. } { have [q Hq] := H; apply/dvdnP; exists `|Z2int q|%N; apply/Nat2Z.inj. have [Zq|NZq] := Z_zerop q. { by rewrite Zq /= in Hq *. } case: m Hq H => [|m] Hq H. { by rewrite Zmult_comm /= in Hq; rewrite mulnC /=. } rewrite Nat2Z.inj_mul -Zabs_natE Zabs2Nat.id_abs Z.abs_eq //. have H0 : (0 <= q * Z.of_nat m.+1) by rewrite -Hq; apply Zle_0_nat. by apply: Zmult_le_0_reg_r H0. } Qed. Lemma ZgcdE n d : Z.gcd n (Z.pos d) = Z.of_nat (div.gcdn `|Z2int n| (nat_of_pos d)). Proof. apply: Z.gcd_unique. { exact: Zle_0_nat. } { apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP. by rewrite Zabs_natE dvdn_gcdl. } { apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP. by rewrite Zabs_natE /= dvdn_gcdr. } move=> q Hn Hd; apply/Z.divide_abs_l; rewrite -Zabs2Nat.id_abs; apply/dvdnP. rewrite Zabs_natE dvdn_gcd. apply/andP; split; apply/dvdnP; rewrite -!Zabs_natE !Zabs2Nat.id_abs. { by apply/Z.divide_abs_l/Z.divide_abs_r. } { by apply/Z.divide_abs_l; rewrite -binnat.to_natE positive_nat_Z. } Qed. Lemma ZgcdE' n m : Z.gcd n m = Z.of_nat (gcdn `|Z2int n| `|Z2int m|). Proof. case m. { rewrite Z.gcd_0_r {2}/absz {2}/Z2int /= gcdn0 -Zabs2Nat.id_abs; f_equal. rewrite /Z.abs_nat /absz /Z2int. case n=>// p; rewrite -!binnat.to_natE //. case (Pos.to_nat _); [by rewrite GRing.oppr0|move=> n']. by rewrite /GRing.opp /=. } { by move=> p; rewrite ZgcdE nat_of_pos_Z_to_pos. } by move=> p; rewrite -Z.gcd_opp_r /= ZgcdE abszN /absz. Qed. Lemma Z_ggcd_1_r n : Z.ggcd n 1 = (1, (n, 1))%coqZ. Proof. move: (Z.ggcd_gcd n 1) (Z.ggcd_correct_divisors n 1); rewrite Z.gcd_1_r. case (Z.ggcd _ _)=> g ab /= ->; case ab=> a b []. by rewrite !Z.mul_1_l => <- <-. Qed. Lemma Z_ggcd_coprime a b : let '(g, (a', b')) := Z.ggcd a b in g <> 0%coqZ -> coprime `|Z2int a'| `|Z2int b'|. Proof. move: (Z.ggcd_gcd a b) (Z.ggcd_correct_divisors a b). case (Z.ggcd _ _)=> g ab; case ab=> a' b' /= Hg [] Ha Hb Pg. rewrite /coprime; apply/eqP /Nat2Z.inj; rewrite -ZgcdE' /=. suff ->: a' = (a / g)%coqZ. { suff ->: b' = (b / g)%coqZ; [by apply Z.gcd_div_gcd|]. by rewrite Hb Z.mul_comm Z_div_mult_full. } by rewrite Ha Z.mul_comm Z_div_mult_full. Qed. Lemma Z2int_lcm x y : Z.le 0 x -> Z.le 0 y -> Z2int (Z.lcm x y) = lcmn `|Z2int x| `|Z2int y|. Proof. case: x => [|x|//] _; [by rewrite /= lcm0n|]. case: y => [|y|//] _; [by rewrite /= lcmn0|]. rewrite /Z.lcm Z2int_abs Z2int_mul Z2int_div //. rewrite ZgcdE' abszM; apply: f_equal; apply/eqP. rewrite -(@eqn_pmul2r (gcdn `|Z2int (Z.pos x)| `|Z2int (Z.pos y)|)); last first. { rewrite gcdn_gt0; apply/orP; left; rewrite absz_gt0 /= eqz_nat. apply: lt0n_neq0; exact: nat_of_pos_gt0. } rewrite muln_lcm_gcd. rewrite -(absz_nat (gcdn _ _)) -mulnA -abszM. rewrite Z2int_Z_of_nat /=. by rewrite intdiv.divzK // /mem /in_mem /intdiv.dvdz /= dvdn_gcdr. Qed. End Zint. (** ** Link between [bigQ] (Coq standard lib) and [rat] (Mathcomp) *) Section binrat_theory. Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *) (** *** Conversion from [bigQ] to [rat] *) Program Definition bigQ2rat_def (bq : bigQ) := let q := Qred (BigQ.to_Q bq) in ((Z2int (Qnum q))%:Q / (Z2int (Z.pos (Qden q)))%:Q)%R. Fact bigQ2rat_key : unit. Proof. by []. Qed. Program Definition bigQ2rat := locked_with bigQ2rat_key bigQ2rat_def. Canonical bigQ2rat_unlockable := [unlockable fun bigQ2rat]. (** *** Conversion from [rat] to [bigQ] *) Definition rat2bigQ (q : rat) : bigQ := let n := BigZ.of_Z (int2Z (numq q)) in let d := BigN.N_of_Z (int2Z (denq q)) in (n # d)%bigQ. (** *** Refinement relation *) Definition r_ratBigQ := fun_hrel bigQ2rat. (** *** Main instances *) #[export] Instance zero_bigQ : zero_of bigQ := 0%bigQ. #[export] Instance one_bigQ : one_of bigQ := 1%bigQ. #[export] Instance opp_bigQ : opp_of bigQ := BigQ.opp. #[export] Instance add_bigQ : add_of bigQ := BigQ.add_norm. #[export] Instance sub_bigQ : sub_of bigQ := BigQ.sub_norm. #[export] Instance mul_bigQ : mul_of bigQ := BigQ.mul_norm. #[export] Instance inv_bigQ : inv_of bigQ := BigQ.inv_norm. #[export] Instance div_bigQ : div_of bigQ := BigQ.div_norm. #[export] Instance eq_bigQ : eq_of bigQ := BigQ.eq_bool. #[export] Instance lt_bigQ : lt_of bigQ := fun p q => if BigQ.compare p q is Lt then true else false. #[export] Instance le_bigQ : leq_of bigQ := fun p q => if BigQ.compare q p is Lt then false else true. #[export] Instance max_bigQ : max_of bigQ := BigQ.max. #[export] Instance min_bigQ : min_of bigQ := BigQ.min. #[export] Instance cast_of_nat_bigQ : cast_of nat bigQ := BigQ.of_Z \o Z.of_nat. #[export] Instance spec_bigQ : spec_of bigQ rat := bigQ2rat. (** *** Proofs of refinement *) #[export] Instance refine_ratBigQ_zero : refines r_ratBigQ 0%R 0%C. Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed. #[export] Instance refine_ratBigQ_one : refines r_ratBigQ 1%R 1%C. Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed. #[export] Instance refine_ratBigQ_opp : refines (r_ratBigQ ==> r_ratBigQ) -%R -%C. Proof. rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite BigQ.strong_spec_opp Qred_opp [in LHS]/Qnum /=. by rewrite Z2int_opp mulrNz mulNr. Qed. Lemma Z2int_Qred n d : ((Z2int (Qnum (Qred (n # d))))%:Q / (nat_of_pos (Qden (Qred (n # d))))%:Q = (Z2int n)%:Q / (Z2int (Z.pos d))%:Q)%R. Proof. rewrite -(fracqE (Z2int n, Z2int (Z.pos d))) -[RHS]divq_num_den. rewrite /Qred. move: (Z.ggcd_gcd n (Z.pos d)) (Z.ggcd_correct_divisors n (Z.pos d)). move: (Z_ggcd_coprime n (Z.pos d)). case: Z.ggcd => g [n' d'] /=. case: g => [|g|g]. { by move=> _ _ [_]; rewrite Z.mul_0_l. } { move=> coprime_n'_d' => _ [->]. rewrite (nat_of_pos_Z_to_pos d) => /[dup] posd' ->. have d'n0 : `|Z2int d'| != 0%R. { rewrite normr_eq0. case: d' posd' {coprime_n'_d'} => // d' _. by rewrite Posz_nat_of_pos_neq0. } rewrite !Z2int_mul abszM PoszM gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le]. rewrite fracqMM ?Posz_nat_of_pos_neq0 // abszE. move: (@valq_frac (Z2int n', `|Z2int d'|) d'n0). rewrite scalqE // mul1r => [[neq deq]]. have -> : nat_of_pos (Z.to_pos d') = `|Z2int d'| :> int. { rewrite nat_of_pos_Z_to_pos Z2Pos.id ?abszE //. by case: d' posd' {coprime_n'_d' d'n0 neq deq}. } rewrite [X in (X%:~R / _)%R]neq [X in (_ / X%:~R)%R]deq. rewrite (_ : gcdn _ _ = 1%nat) ?mul1r //; exact/eqP/coprime_n'_d'. } by move: (Z.gcd_nonneg n (Z.pos d)) => + _ => /[swap] <-. Qed. Lemma BigQ_red_den_nonzero q : match BigQ.red q with BigQ.Qz _ => True | BigQ.Qq _ d => (BigN.to_Z d) <> Z0 end. Proof. case: q => [//|n d] /=. rewrite /BigQ.norm. rewrite BigN.spec_compare. case: Z.compare_spec => [| |//] Hgcd. { rewrite /BigQ.check_int BigN.spec_compare. case Z.compare_spec => [//| |//] Hd. apply: BigNumPrelude.Zlt0_not_eq. move: Hd; exact: Z.lt_trans. } rewrite /BigQ.check_int BigN.spec_compare. case Z.compare_spec => [//| |//] Hd. apply: BigNumPrelude.Zlt0_not_eq. move: Hd; exact: Z.lt_trans. Qed. Lemma r_ratBigQ_red x y : r_ratBigQ x y -> match BigQ.red y with | BigQ.Qz n => numq x = Z2int (BigZ.to_Z n) /\ denq x = 1%R | BigQ.Qq n d => numq x = Z2int (BigZ.to_Z n) /\ denq x = Z2int (BigN.to_Z d) end. Proof. case: (ratP x) => nx dx nx_dx_coprime {x}. rewrite /r_ratBigQ /fun_hrel unlock -BigQ.strong_spec_red. have ry_red : Qred (BigQ.to_Q (BigQ.red y)) = BigQ.to_Q (BigQ.red y). { by rewrite BigQ.strong_spec_red Qcanon.Qred_involutive. } have ry_dneq0 := BigQ_red_den_nonzero y. case: (BigQ.red y) ry_dneq0 ry_red => [ny _ _|ny dy dy_neq0]. { rewrite /BigQ.to_Q /Qnum /Qden mulr1. move=> /(f_equal ( *%R^~ dx.+1%:~R)%R). rewrite mulfVK ?mulrz_neq0 // -intrM => /intr_inj nx_eq. have dx_1 : (dx.+1 = 1)%nat. { by move: nx_dx_coprime => /eqP <-; rewrite -nx_eq abszM /= gcdnC gcdnMl. } by rewrite -nx_eq dx_1 mulr1. } rewrite /BigQ.to_Q ifF ?BigN.spec_eqb ?Z.eqb_neq //. rewrite Qcanon.Qred_iff ZgcdE -[1%coqZ]/(Z.of_nat 1%nat) => /Nat2Z.inj. rewrite /Qnum /Qden nat_of_pos_Z_to_pos => /eqP ny_dy_coprime. move=> /eqP; rewrite rat_eqE !coprimeq_num // !coprimeq_den //=. rewrite !gtr0_sg ?nat_of_pos_gtr0 // !mul1r => /andP[/eqP <-]. rewrite ifF; [|exact/eqP/eqP/lt0r_neq0/nat_of_pos_gtr0]. rewrite -!abszE !absz_nat => /eqP[<-]; split=> [//|]. rewrite -[LHS]/(Z2int (Z.pos (Z.to_pos (BigN.to_Z dy)))) Z2Pos.id //. exact: BigQ.N_to_Z_pos. Qed. #[export] Instance refine_ratBigQ_add : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) +%R +%C. Proof. rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite (Qred_complete _ _ (BigQ.spec_add_norm _ _)). case: (BigQ.to_Q a) => na da {a}. case: (BigQ.to_Q b) => nb db {b}. rewrite /Qplus !Z2int_Qred. rewrite Z2int_add !Z2int_mul /= nat_of_mul_pos. rewrite intrD PoszM !intrM. by rewrite [RHS]addf_div // intq_eq0 Posz_nat_of_pos_neq0. Qed. #[export] Instance refine_ratBigQ_sub : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) (fun x y => x - y)%R sub_op. Proof. apply refines_abstr2=> a b rab c d rcd. rewrite /sub_op /sub_bigQ /BigQ.sub_norm; eapply refines_apply; tc. Qed. #[export] Instance refine_ratBigQ_mul : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) *%R *%C. Proof. rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite (Qred_complete _ _ (BigQ.spec_mul_norm _ _)). case: (BigQ.to_Q a) => na da {a}. case: (BigQ.to_Q b) => nb db {b}. rewrite /Qmult !Z2int_Qred /=. rewrite Z2int_mul nat_of_mul_pos. rewrite PoszM !intrM. by rewrite [RHS]mulf_div. Qed. #[export] Instance refine_ratBigQ_inv : refines (r_ratBigQ ==> r_ratBigQ)%rel GRing.inv inv_op. Proof. rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite (Qred_complete _ _ (BigQ.spec_inv_norm _)). case: (BigQ.to_Q a) => na da {a}. rewrite /Qinv [Qnum (na # da)]/=. case: na => [|na|na]. { by rewrite /= !mul0r invr0. } { by rewrite [Qden (_ # da)]/= !Z2int_Qred invf_div. } rewrite [Qden (_ #da)]/= !Z2int_Qred invf_div. by rewrite -!Pos2Z.opp_pos !Z2int_opp !mulrNz mulNr invrN mulrN. Qed. #[export] Instance refine_ratBigQ_div : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel (fun x y => x / y)%R div_op. Proof. apply: refines_abstr2 => x1 x2 rx y1 y2 ry. rewrite /div_op /div_bigQ /BigQ.div_norm. exact: refines_apply. Qed. #[export] Instance refine_ratBigQ_eq : refines (r_ratBigQ ==> r_ratBigQ ==> eq) eqtype.eq_op eq_op. Proof. rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite /eq_op /eq_bigQ BigQ.spec_eq_bool. case: (BigQ.to_Q a) => na da {a}. case: (BigQ.to_Q b) => nb db {b}. rewrite /Qeq_bool !Z2int_Qred /=. do ?[rewrite /Zeq_bool -Z.eqb_compare]. (* remove line when requiring Rocq >= 9.0 *) rewrite GRing.eqr_div ?intq_eq0 ?Posz_nat_of_pos_neq0 //. rewrite !nat_of_pos_Z_to_pos. rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..]. rewrite -!intrM -!Z2int_mul eqr_int. by case: Z.eqb_spec => [->|eq]; apply/eqP => // eq'; apply/eq/Z2int_inj. Qed. #[export] Instance refine_ratBigQ_eq' : refines (r_ratBigQ ==> r_ratBigQ ==> bool_R)%rel eqtype.eq_op eq_op. Proof. rewrite refinesE => x1 x2 rx y1 y2 ry. move: refine_ratBigQ_eq; rewrite refinesE => /(_ _ _ rx _ _ ry) <-. case: (_ == _); constructor. Qed. #[export] Instance refine_ratBigQ_lt : refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.lt lt_op. Proof. rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite /lt_op /lt_bigQ BigQ.spec_compare. case: (BigQ.to_Q a) => na da {a}. case: (BigQ.to_Q b) => nb db {b}. rewrite !Z2int_Qred /= /Qcompare /= -Z.ltb_compare. rewrite ltr_pdivrMr ?ltr0z ?nat_of_pos_gtr0 //. rewrite mulrAC ltr_pdivlMr ?ltr0z ?nat_of_pos_gtr0 //. rewrite !nat_of_pos_Z_to_pos. rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..]. rewrite -!intrM -!Z2int_mul ltr_int. case: ltP. { by move=> /(proj1 (Z2int_lt _ _)) /(proj2 (Z.ltb_lt _ _)) => ->. } by move=> /(proj1 (Z2int_le _ _)) /(proj2 (Z.ltb_ge _ _)) => ->. Qed. #[export] Instance refine_ratBigQ_le : refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.le leq_op. Proof. rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=. rewrite /leq_op /le_bigQ BigQ.spec_compare. case: (BigQ.to_Q a) => na da {a}. case: (BigQ.to_Q b) => nb db {b}. rewrite !Z2int_Qred /= /Qcompare /=. rewrite ler_pdivrMr ?ltr0z ?nat_of_pos_gtr0 //. rewrite mulrAC ler_pdivlMr ?ltr0z ?nat_of_pos_gtr0 //. rewrite !nat_of_pos_Z_to_pos. rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..]. rewrite -!intrM -!Z2int_mul ler_int. case: leP. { move=> /(proj1 (Z2int_le _ _)) /Zle_compare. by rewrite Z.compare_antisym; case: Z.compare. } by move=> /(proj1 (Z2int_lt _ _)) /Zlt_compare; case: Z.compare. Qed. #[export] Instance refine_ratBigQ_max : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.max max_op. Proof. apply: refines_abstr2 => x1 x2 rx y1 y2 ry. have H := refines_apply (refines_apply refine_ratBigQ_lt rx) ry. move: H => /refines_bool_eq; rewrite maxElt refinesE => ->. rewrite /lt_op /lt_bigQ /max_op /max_bigQ /BigQ.max. by case: (_ ?= _)%bigQ. Qed. #[export] Instance refine_ratBigQ_min : refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.min min_op. Proof. apply: refines_abstr2 => x1 x2 rx y1 y2 ry. have H := refines_apply (refines_apply refine_ratBigQ_lt ry) rx. move: H => /refines_bool_eq; rewrite minEle leNgt refinesE => ->. rewrite /lt_op /lt_bigQ /min_op /min_bigQ /BigQ.min. rewrite !BigQ.spec_compare -QArith_base.Qcompare_antisym. by case: QArith_base.Qcompare. Qed. #[export] Instance refine_ratBigQ_of_nat : refines (nat_R ==> r_ratBigQ)%rel (fun n => n%:~R%R) cast_op. Proof. rewrite refinesE => n _ /nat_R_eq <-; rewrite /r_ratBigQ unlock /fun_hrel. rewrite /= Z_ggcd_1_r /= BigZ.spec_of_Z mulr1. by apply/eqP; rewrite eqr_int Z2int_Z_of_nat. Qed. #[export] Instance refine_ratBigQ_spec : refines (eq ==> r_ratBigQ)%rel spec spec_id. Proof. by rewrite refinesE => x _ <-. Qed. #[export] Instance refine_ratBigQ_bigQ2rat a : refines r_ratBigQ (bigQ2rat a) a. Proof. by rewrite refinesE. Qed. End binrat_theory. coqeal-2.1.0/refinements/boolF2.v000066400000000000000000000075171475512565300166360ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice. From mathcomp Require Import fintype bigop finset prime fingroup ssralg zmodp finalg. From CoqEAL Require Import hrel param refinements. Import Refinements.Op. Section operations. #[export] Instance zero_bool : zero_of bool := false. #[export] Instance one_bool : one_of bool := true. #[export] Instance opp_bool : opp_of bool := id. #[export] Instance add_bool : add_of bool := xorb. #[export] Instance sub_bool : sub_of bool := xorb. #[export] Instance mul_bool : mul_of bool := andb. #[export] Instance inv_bool : inv_of bool := id. #[export] Instance eq_bool : eq_of bool := eqtype.eq_op. End operations. Section definition. Local Open Scope ring_scope. Local Open Scope rel_scope. Definition F2_of_bool (x : bool) : 'F_2 := x%:R. Definition Rbool := fun_hrel F2_of_bool. #[export] Instance Rbool_zero : refines Rbool 0 0%C. Proof. by rewrite refinesE. Qed. #[export] Instance Rbool_one : refines Rbool 1 1%C. Proof. by rewrite refinesE. Qed. #[export] Instance Rbool_opp : refines (Rbool ==> Rbool) -%R -%C. Proof. rewrite refinesE => x. by case; rewrite /Rbool /F2_of_bool /fun_hrel /= => <-; apply/val_inj. Qed. #[export] Instance Rbool_add : refines (Rbool ==> Rbool ==> Rbool) +%R +%C. Proof. rewrite refinesE /Rbool /F2_of_bool /fun_hrel. by move=> x [] <- y [] <-; apply/val_inj. Qed. (* TODO: lemma for sub *) #[export] Instance Rbool_sub : refines (Rbool ==> Rbool ==> Rbool) (fun x y => x - y) sub_op. Proof. rewrite refinesE /Rbool /F2_of_bool /fun_hrel. by move=> x [] <- y [] <-; apply/val_inj. Qed. #[export] Instance Rbool_mul : refines (Rbool ==> Rbool ==> Rbool) *%R *%C. Proof. rewrite refinesE /Rbool /F2_of_bool /fun_hrel. by move=> x [] <- y [] <-; apply/val_inj. Qed. #[export] Instance Rbool_inv : refines (Rbool ==> Rbool) GRing.inv inv_bool. Proof. rewrite refinesE => x. by case; rewrite /Rbool /F2_of_bool /fun_hrel /= => <-; apply/val_inj. Qed. #[export] Instance Rbool_eq : refines (Rbool ==> Rbool ==> bool_R) eqtype.eq_op eq_op. Proof. by rewrite refinesE /Rbool /F2_of_bool /fun_hrel=> x [] <- y [] <-. Qed. (* Lemma inj_bool_trans : injective bool_of_F2. Proof. move=> [x Hx] [y Hy]; move: x y Hx Hy. case; do 3?case=> //; move=> Hx Hy _; exact: val_inj. Qed. Definition bool_trans_struct := Trans inj_bool_trans. Lemma bool_trans0 : bool_trans 0 = false. Proof. by []. Qed. Lemma oppbE : {morph bool_trans : x / - x >-> id x}. Proof. by move=> x; rewrite /bool_trans /= GRing.oppr_eq0. Qed. Lemma addbE : {morph bool_trans : x y / x + y >-> xorb x y}. Proof. move=> [x Hx] [y Hy]; move: x y Hx Hy. case; do 3?case=> //; move=> Hx Hy _; exact: val_inj. Qed. (* CZmodule structure *) Definition bool_czMixin := @CZmodMixin [zmodType of 'F_2] bool false id xorb bool_trans_struct bool_trans0 oppbE addbE. Canonical Structure bool_czType := Eval hnf in CZmodType 'F_2 bool bool_czMixin. Lemma bool_trans1 : bool_trans 1 = true. Proof. by []. Qed. Lemma mulbE : {morph bool_trans : x y / x * y >-> andb x y}. Proof. move=> x y; rewrite /bool_trans /= GRing.mulf_eq0. by case: (x == 0); case: (y == 0). Qed. Definition bool_cringMixin := CRingMixin bool_trans1 mulbE. Canonical Structure bool_cringType := Eval hnf in CRingType 'F_2 bool_cringMixin. Lemma cunitE : (forall x : 'F_2, (x \is a GRing.unit) = xpred1 true (bool_trans x)). Proof. by move=> x; rewrite GRing.unitfE /bool_trans eqb_id. Qed. Lemma invbE : {morph bool_trans : x / x^-1 >-> id x}. Proof. by do 3?case. Qed. Definition bool_cunitRingMixin := @CUnitRingMixin [unitRingType of 'F_2] bool_cringType (xpred1 true) id cunitE invbE. Canonical Structure bool_cunitRingType := Eval hnf in CUnitRingType 'F_2 bool_cunitRingMixin. *) End definition. coqeal-2.1.0/refinements/examples/000077500000000000000000000000001475512565300171305ustar00rootroot00000000000000coqeal-2.1.0/refinements/examples/irred.v000066400000000000000000000240451475512565300204310ustar00rootroot00000000000000From HB Require Import structures. Require Import mathcomp.ssreflect.ssreflect. From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype tuple. From mathcomp Require Import bigop binomial finset finfun zmodp ssralg countalg finalg poly polydiv. From mathcomp Require Import perm fingroup. From CoqEAL Require Import hrel pos param refinements binnat boolF2 seqpoly poly_op trivial_seq poly_div boolF2. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Import FinRing.Theory. Import Pdiv.Field. Import Refinements.Op Poly.Op. Local Open Scope ring_scope. Section npoly. Variable n : nat. Variable R : ringType. Record npolynomial : predArgType := Npolynomial { poly_of_npoly :> {poly R}; _ : (size poly_of_npoly <= n)%N }. HB.instance Definition _ := [isSub of npolynomial for poly_of_npoly]. HB.instance Definition _ := [Choice of pos by <:]. Definition npoly_of of (phant R) := npolynomial. Local Notation npoly_ofR := (npoly_of (Phant R)). HB.instance Definition _ := SubType.on npoly_ofR. HB.instance Definition _ := [Equality of npoly_ofR by <:]. End npoly. Notation "'{poly_' n R }" := (npoly_of n (Phant R)) (at level 0, n at level 1, format "'{poly_' n R }"). Section npoly_theory. Context {n : nat} (R : ringType). Lemma size_npoly (p : {poly_n R}) : (size p <= n)%N. Proof. exact: valP p. Qed. Hint Resolve size_npoly : core. Lemma npoly_inj : injective (@poly_of_npoly n R). Proof. exact: val_inj. Qed. Hint Resolve npoly_inj : core. Canonical npoly (E : nat -> R) : {poly_n R} := @Npolynomial _ _ (\poly_(i < n) E i) (size_poly _ _). Fact size_npoly0 : size (0 : {poly R}) <= n. Proof. by rewrite size_poly0. Qed. Definition npoly0 := Npolynomial (size_npoly0). Definition NPoly (p : {poly R}) : {poly_n R} := npoly (nth 0 p). Definition npoly_of_seq := NPoly \o Poly. Lemma npolyP (p q : {poly_n R}) : nth 0 p =1 nth 0 q <-> p = q. Proof. by split => [/polyP/val_inj|->]. Qed. Lemma coef_NPoly (p : {poly R}) i : (NPoly p)`_i = if i < n then p`_i else 0. Proof. by rewrite /= coef_poly. Qed. Lemma big_coef_npoly (p : {poly_n R}) i : n <= i -> p`_i = 0. Proof. by move=> i_big; rewrite nth_default // (leq_trans _ i_big). Qed. End npoly_theory. #[export] Hint Resolve size_npoly npoly_inj : core. Section fin_npoly. Variable R : finRingType. Variable n : nat. Implicit Types p q : {poly_n R}. HB.instance Definition _ := [Countable of (npolynomial n R) by <:]. Definition npoly_enum : seq {poly_n R} := if n isn't n.+1 then [:: npoly0 _] else pmap insub [seq \poly_(i < n.+1) c (inord i) | c : (R ^ n.+1)%type]. Lemma npoly_enum_uniq : uniq npoly_enum. Proof. rewrite /npoly_enum; case: n=> [|k] //. rewrite pmap_sub_uniq // map_inj_uniq => [|f g eqfg]; rewrite ?enum_uniq //. apply/ffunP => /= i; have /(congr1 (fun p : {poly _} => p`_i)) := eqfg. by rewrite !coef_poly ltn_ord inord_val. Qed. Lemma mem_npoly_enum p : p \in npoly_enum. Proof. rewrite /npoly_enum; case: n => [|k] // in p *. by case: p => [p sp] /=; rewrite in_cons -val_eqE /= -size_poly_leq0 sp. rewrite mem_pmap_sub; apply/mapP. eexists [ffun i : 'I__ => p`_i]; first by rewrite mem_enum. apply/polyP => i; rewrite coef_poly. have [i_small|i_big] := ltnP; first by rewrite ffunE /= inordK. by rewrite nth_default // 1?(leq_trans _ i_big) // size_npoly. Qed. HB.instance Definition _ := isFinite.Build (npolynomial n R) (Finite.uniq_enumP npoly_enum_uniq mem_npoly_enum). HB.instance Definition _ := Finite.on {poly_n R}. Lemma card_npoly : #|{poly_n R}| = (#|R| ^ n)%N. Proof. rewrite cardE enumT unlock /= /npoly_enum; case: n => [|k] //=. rewrite size_pmap_sub (@eq_in_count _ _ predT) ?count_predT; last first. by move=> _ /mapP /= [f _ ->]; rewrite size_poly. by rewrite size_map -cardE card_ffun card_ord. Qed. End fin_npoly. Section Irreducible. Variable R : finIdomainType. Variable p : {poly R}. Definition irreducibleb := ((1 < size p) && [forall q : {poly_((size p).-1) R}, (Pdiv.Ring.rdvdp q p)%R ==> (sizep q <= 1)])%N. Lemma irreducibleP : reflect (irreducible_poly p) irreducibleb. Proof. rewrite /irreducibleb /irreducible_poly. apply: (iffP idP) => [/andP[sp /'forall_implyP /= Fp]|[sp Fpoly]]. have sp_gt0 : size p > 0 by case: size sp. have p_neq0 : p != 0 by rewrite -size_poly_eq0; case: size sp. split => // q sq_neq1 dvd_qp; rewrite -dvdp_size_eqp // eqn_leq dvdp_leq //=. apply: contraNT sq_neq1; rewrite -ltnNge => sq_lt_sp. have q_small: (size q <= (size p).-1)%N by rewrite -ltnS prednK. rewrite Pdiv.Idomain.dvdpE in dvd_qp. have /= := Fp (Npolynomial q_small) dvd_qp. rewrite leq_eqVlt ltnS => /orP[//|]; rewrite size_poly_leq0 => /eqP q_eq0. by rewrite -Pdiv.Idomain.dvdpE q_eq0 dvd0p (negPf p_neq0) in dvd_qp. have sp_gt0 : size p > 0 by case: size sp. rewrite sp /=; apply/'forall_implyP => /= q; rewrite -Pdiv.Idomain.dvdpE=> dvd_qp. have [/eqP->//|/Fpoly/(_ dvd_qp)/eqp_size sq_eq_sp] := boolP (sizep q == 1%N). by have := size_npoly q; rewrite sq_eq_sp -ltnS prednK ?ltnn. Qed. End Irreducible. Module Import nat_ops. #[export] Instance zero_nat : zero_of nat := 0%N. #[export] Instance one_nat : one_of nat := 1%N. #[export] Instance add_nat : add_of nat := addn. #[export] Instance sub_nat : sub_of nat := subn. #[export] Instance mul_nat : mul_of nat := muln. #[export] Instance exp_nat : exp_of nat nat := expn. #[export] Instance leq_nat : leq_of nat := ssrnat.leq. #[export] Instance lt_nat : lt_of nat := ssrnat.ltn. #[export] Instance eq_nat : eq_of nat := eqtype.eq_op. #[export] Instance spec_nat : spec_of nat nat := spec_id. #[export] Instance implem_nat : implem_of nat nat := implem_id. End nat_ops. Section card. Context (T' : Type) (N : Type). Context (enumT' : seq T') `{zero_of N} `{one_of N} `{add_of N}. Definition card' (P' : pred T') : N := size_op [seq s <- enumT' | P' s]. End card. Elpi derive.param2 card'. Lemma size_seqE T (s : seq T) : (@size_seq _ _ 0%N 1%N addn) s = size s. Proof. by elim: s => //= x s ->; rewrite [(_ + _)%C]addn1. Qed. Lemma card'_perm (T : eqType) (s s' : seq T) (P : pred T) : perm_eq s s' -> card' s P = card' s' P :> nat. Proof. move=> peq_ss'; rewrite /card' /size_op !size_seqE. by apply/perm_size/seq.permP=> x; rewrite !count_filter; apply/seq.permP. Qed. Lemma card'E (T : finType) (P : pred T) : card' (@Finite.enum _) P = #|P|. Proof. by rewrite cardE; rewrite /card' /size_op/= size_seqE. Qed. Local Open Scope rel_scope. Section enumerable. Context (T : finType) (T' : Type) (RT : T -> T' -> Type). Variable (N : Type) (rN : nat -> N -> Type). Context (enumT' : seq T') {enumR : refines (perm_eq \o list_R RT) (@Finite.enum T) enumT'}. Context `{zero_of N} `{one_of N} `{add_of N}. Context `{!refines rN 0%N 0%C}. Context `{!refines rN 1%N 1%C}. Context `{!refines (rN ==> rN ==> rN) addn add_op}. Context (P : pred T) (P' : pred T'). #[export] Instance refines_card : (forall x x' `{!refines RT x x'}, refines (bool_R \o @unify _) (P x) (P' x')) -> refines rN #|[pred x | P x]| (card' enumT' P'). Proof. move=> RP; have := refines_comp_unify (RP _ _ _) => /refines_abstr => {}RP. have [s [rs1 rs2]] := refines_split2 enumR. by rewrite -card'E (@card'_perm _ _ s) //; param card'_R. Qed. End enumerable. Local Open Scope rel_scope. Section enum_boolF2. Definition enum_boolF2 : seq bool := [:: false; true]. End enum_boolF2. Elpi derive.param2 enum_boolF2. #[export] Instance refines_enum_boolF2 : refines (perm_eq \o list_R Rbool) (Finite.enum 'F_2) (enum_boolF2). Proof. rewrite -enumT; refines_trans; last first. by rewrite refinesE; do !constructor. rewrite refinesE /= uniq_perm ?enum_uniq //. by move=> i; rewrite mem_enum /= !inE; case: i => [[|[|[]]] ?]. Qed. Section enum_npoly. Context (N : Type) (n : N) (A : Type) (P : Type). Context (iter : forall T, N -> (T -> T) -> T -> T). Context (enum : seq A) (poly_of_seq : seq A -> P). Definition enum_npoly : seq P := let extend e := e ++ flatten [seq map (cons x) e | x <- enum] in map poly_of_seq (iter n extend [::[::]]). End enum_npoly. Lemma enum_npolyE (n : nat) (R : finRingType) s : perm_eq (Finite.enum R) s -> perm_eq (Finite.enum {poly_n R}) (enum_npoly n iter s (@npoly_of_seq _ _)). Proof. rewrite -!enumT => Rs; rewrite uniq_perm ?enum_uniq //=. admit. move=> /= p; symmetry; rewrite mem_enum inE /=. apply/mapP => /=; exists p; last first. apply/npolyP => i; rewrite coef_poly /= coef_Poly. by case: ltnP => // ?; rewrite big_coef_npoly. elim: n => [|n IHn] in p *. rewrite inE; case: p => [p /=]; rewrite size_poly_leq0 => /eqP->. by rewrite polyseq0. rewrite /= mem_cat. Admitted. Elpi derive.param2 enum_npoly. Section RnpolyC. Context (A : finRingType). Context (C : Type) (rAC : A -> C -> Type). Context (N : Type) (rN : nat -> N -> Type). Context (n : nat) (n' : N) `{!refines rN n n'}. Context (iter' : forall T, N -> (T -> T) -> T -> T) {iterR : forall T T' RT, refines (rN ==> (RT ==> RT) ==> RT ==> RT) (@iter T) (@iter' T')}. Context (enumC : seq C) {enumR : refines (perm_eq \o list_R rAC) (@Finite.enum A) enumC}. Definition Rnpoly : {poly_n A} -> {poly A} -> Type := fun p q => p = q :> {poly A}. Definition RnpolyC : {poly_n A} -> seqpoly C -> Type := (Rnpoly \o RseqpolyC rAC)%rel. #[export] Instance refines_enum_npoly : refines (perm_eq \o list_R RnpolyC) (Finite.enum {poly_n A}) (enum_npoly n' iter' enumC id). Proof. have [s [sP ?]] := refines_split2 enumR. eapply refines_trans; tc. by rewrite refinesE; apply/enum_npolyE/sP. param enum_npoly_R. Admitted. #[export] Instance refines_RnpolyCpoly (x : {poly_n A}) (y : seqpoly C) `{!refines RnpolyC x y} : refines (RseqpolyC rAC) (poly_of_npoly x) y. Admitted. End RnpolyC. #[export] Instance refines_iter T T' RT : refines (Rnat ==> (RT ==> RT) ==> RT ==> RT) (@iter T) (@iter T'). Proof. param iter_R. Admitted. Section LaurentsProblem. #[export] Instance refines_predn : refines (Rnat ==> Rnat) predn (fun n => (n - 1)%C). Admitted. Lemma test_irred : irreducible_poly ('X^5 + 'X^2 + 1 : {poly 'F_2}). Proof. apply/irreducibleP; rewrite /irreducibleb -[size _]/(sizep _). rewrite -[[forall _, _]]/(_ == _) /= /Pdiv.Ring.rdvdp. by coqeal. Qed. End LaurentsProblem. coqeal-2.1.0/refinements/hpoly.v000066400000000000000000001022141475512565300166340ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv. From CoqEAL Require Import param refinements pos hrel poly_op. (******************************************************************************) (** This file implements sparse polynomials in sparse Horner normal form. *) (* *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op Poly.Op. (******************************************************************************) (** PART I: Defining generic datastructures and programming with them *) (******************************************************************************) Section hpoly. Context {A N pos : Type}. Inductive hpoly A := Pc : A -> hpoly | PX : A -> pos -> hpoly -> hpoly. Section hpoly_op. Context `{zero_of A, one_of A, add_of A, sub_of A, opp_of A, mul_of A, eq_of A}. Context `{one_of pos, add_of pos, sub_of pos, eq_of pos, lt_of pos}. Context `{zero_of N, one_of N, eq_of N, leq_of N, lt_of N, add_of N, sub_of N}. Context `{cast_of N pos, cast_of pos N}. Context `{spec_of N nat}. Local Open Scope computable_scope. Fixpoint normalize (p : hpoly A) : hpoly A := match p with | Pc c => Pc c | PX a n p => match normalize p with | Pc c => PX a n (Pc c) | PX b m q => if (b == 0)%C then PX a (m + n) q else PX a n (PX b m q) end end. Fixpoint from_seq (p : seq A) : hpoly A := match p with | [::] => Pc 0 | [:: c] => Pc c | x :: xs => PX x 1 (from_seq xs) end. #[export] Instance cast_hpoly : cast_of A (hpoly A) := fun x => Pc x. #[export] Instance zero_hpoly : zero_of (hpoly A) := Pc 0. #[export] Instance one_hpoly : one_of (hpoly A) := Pc 1. Fixpoint map_hpoly A B (f : A -> B) (p : hpoly A) : hpoly B := match p with | Pc c => Pc (f c) | PX a n p => PX (f a) n (map_hpoly f p) end. #[export] Instance opp_hpoly : opp_of (hpoly A) := map_hpoly -%C. #[export] Instance scale_hpoly : scale_of A (hpoly A) := fun a => map_hpoly [eta *%C a]. Fixpoint addXn_const (n : N) a (q : hpoly A) := match q with | Pc b => if (n == 0)%C then Pc (a + b) else PX b (cast n) (Pc a) | PX b m q' => let cn := cast n in if (n == 0)%C then PX (a + b) m q' else if (n == cast m)%C then PX b m (addXn_const 0 a q') else if (n < cast m)%C then PX b cn (PX a (m - cn) q') else PX b m (addXn_const (n - cast m)%C a q') end. Fixpoint addXn (n : N) p q {struct p} := match p, q with | Pc a , q => addXn_const n a q | PX a n' p', Pc b => if (n == 0)%C then PX (a + b) n' p' else PX b (cast n) (PX a n' p') | PX a n' p', PX b m q' => if (n == 0)%C then if (n' == m)%C then PX (a + b) n' (addXn 0 p' q') else if (n' < m)%C then PX (a + b) n' (addXn 0 p' (PX 0 (m - n') q')) else PX (a + b) m (addXn (cast (n' - m)) p' q') else addXn (n + cast n') p' (addXn_const 0 b (addXn_const n a (PX 0 m q'))) end. (* (* This definition is nicer but Coq doesn't like it *) *) (* Fixpoint add_hpoly_op p q := match p, q with *) (* | Pc a, Pc b => Pc (a + b) *) (* | PX a n p, Pc b => PX (a + b) n p *) (* | Pc a, PX b n p => PX (a + b) n p *) (* | PX a n p, PX b m q => *) (* if (m == n)%C then PX (a + b) n (add_hpoly_op p q) *) (* else if n < m then PX (a + b) n (add_hpoly_op p (PX 0 (m - n) q)) *) (* else PX (a + b) m (add_hpoly_op q (PX 0 (n - m) p)) *) (* end. *) #[export] Instance add_hpoly : add_of (hpoly A) := addXn 0. #[export] Instance sub_hpoly : sub_of (hpoly A) := fun p q => p + - q. #[export] Instance shift_hpoly : shift_of (hpoly A) N := fun n p => if (n == 0)%C then p else PX 0 (cast n) p. #[export] Instance mul_hpoly : mul_of (hpoly A) := fix f p q := match p, q with | Pc a, q => a *: q | p, Pc b => map_hpoly (fun x => (x * b)%C) p | PX a n p, PX b m q => shift_hpoly (cast (n + m)) (f p q) + shift_hpoly (cast m) (a *: q) + (shift_hpoly (cast n) (map_hpoly (fun x => (x * b)%C) p) + Pc (a * b)) end. #[export] Instance exp_hpoly : exp_of (hpoly A) N := fun p n => iter (spec n) (mul_hpoly p) 1. Fixpoint eq0_hpoly (p : hpoly A) : bool := match p with | Pc a => (a == 0)%C | PX a n p' => (eq0_hpoly p') && (a == 0)%C end. #[export] Instance eq_hpoly : eq_of (hpoly A) := fun p q => eq0_hpoly (p - q). (* Alternative definition, should be used with normalize: *) (* Fixpoint eq_hpoly_op p q {struct p} := match p, q with *) (* | Pc a, Pc b => (a == b)%C *) (* | PX a n p', PX b m q' => (a == b)%C && (cast n == cast m) && (eq_hpoly_op p' q') *) (* | _, _ => false *) (* end. *) #[export] Instance size_hpoly : size_of (hpoly A) N := fix f p := if eq0_hpoly p then 0%C else match p with | Pc a => 1%C | PX a n p' => if eq0_hpoly p' then 1%C else (cast n + f p')%C end. #[export] Instance lead_coef_hpoly : lead_coef_of A (hpoly A) := fix f p := match p with | Pc a => a | PX a n p' => let b := f p' in if (b == 0)%C then a else b end. #[export] Instance split_hpoly : split_of (hpoly A) N := fix f m p:= if (m == 0)%C then (p, Pc 0)%C else match p with | Pc a => (Pc 0, Pc a) | PX a n p' => if (cast n <= m)%C then let (p1, p2) := f (m - cast n)%C p' in (p1, PX a n p2) else (shift_hpoly (cast n - m)%C p', Pc a) end. Definition head_hpoly (p : hpoly A) := match p with | Pc a => a | PX a n p' => a end. End hpoly_op. End hpoly. Elpi derive.param2 hpoly. Elpi derive.param2 normalize. Elpi derive.param2 from_seq. Elpi derive.param2 cast_hpoly. Elpi derive.param2 zero_hpoly. Elpi derive.param2 one_hpoly. Elpi derive.param2 map_hpoly. Elpi derive.param2 opp_hpoly. Elpi derive.param2 scale_hpoly. Elpi derive.param2 addXn_const. Elpi derive.param2 addXn. Elpi derive.param2 add_hpoly. Elpi derive.param2 sub_hpoly. Elpi derive.param2 shift_hpoly. Elpi derive.param2 mul_hpoly. Elpi derive.param2 exp_hpoly. (* Definition exp_hpoly' := Eval compute in @exp_hpoly. *) (* Elpi derive.param2 exp_hpoly'. *) (* Realizer @exp_hpoly as exp_hpoly_R := exp_hpoly'_R. *) Elpi derive.param2 eq0_hpoly. Elpi derive.param2 eq_hpoly. Elpi derive.param2 size_hpoly. Elpi derive.param2 lead_coef_hpoly. Elpi derive.param2 split_hpoly. Elpi derive.param2 head_hpoly. Section hpoly_more_op. Variable R : ringType. Context (pos N C: Type). Context `{zero_of C, one_of C, eq_of C}. Context `{spec_of C R, spec_of N nat}. Context `{cast_of pos N}. Fixpoint spec_hpoly_aux n (p : @hpoly pos C) : {poly R} := match p with | Pc c => match n with | O => if (c == 0)%C then 0 else if (c == 1)%C then 1 else (spec c)%:P | S O => if (c == 0)%C then 0 else if (c == 1)%C then 'X else (spec c) *: 'X | S m => if (c == 0)%C then 0 else if (c == 1)%C then 'X^(S m) else (spec c) *: 'X^(S m) end | PX a m p => let mon := match n with | O => if (a == 0)%C then 0 else if (a == 1)%C then 1 else (spec a)%:P | S O => if (a == 0)%C then 0 else if (a == 1)%C then 'X else (spec a) *: 'X | S k => if (a == 0)%C then 0 else if (a == 1)%C then 'X^(S k) else (spec a) *: 'X^(S k) end in if (eq0_hpoly p) then mon else let k := if (n == 0)%N then (spec (cast m : N) : nat) else (spec (cast m : N) + n)%N in if (a == 0)%C then (spec_hpoly_aux k p) else (spec_hpoly_aux k p) + mon end. #[export] Instance spec_hpoly : spec_of (hpoly C) {poly R} := spec_hpoly_aux 0%N. Lemma spec_aux_shift n p : spec_hpoly_aux n p = spec_hpoly_aux 0%N p * 'X^n. Proof. have shift_polyC (c : C) m : match m with | O => if (c == 0)%C then 0 else if (c == 1)%C then 1 else (spec c)%:P | S O => if (c == 0)%C then 0 else if (c == 1)%C then 'X : {poly R} else (spec c) *: 'X | S m => if (c == 0)%C then 0 else if (c == 1)%C then 'X^(S m) else (spec c) *: 'X^(S m) end = (if (c == 0)%C then 0 else if (c == 1)%C then 1 else (spec c)%:P) * 'X^m. case: m=> [|m] /=; first by rewrite expr0 mulr1. by case: m=> [|m] /=; rewrite ?expr1 -mul_polyC; case: ifP=> _; rewrite ?mul0r //; case: ifP=> _; rewrite ?mul1r. elim: p n=> [c n|c m p ih n] //=. case: ifP=> _ //. have -> : (if (n == 0)%N then (spec (cast m : N) : nat) else (spec (cast m : N) + n)%N) = (spec (cast m : N) + n)%N. by case: n=> [|n] /=; rewrite ?addn0. rewrite shift_polyC ih [in RHS]ih. by case: ifP=> c0; rewrite ?mulrDl -mulrA -exprD // c0. Qed. Lemma spec_aux_eq0 p : eq0_hpoly p -> spec_hpoly_aux 0%N p = 0. Proof. elim: p=> [c|c m p ih] /=; first by move->. move/andP=> heq0. by rewrite (proj1 heq0) (proj2 heq0). Qed. End hpoly_more_op. Arguments spec_hpoly / _ _ _ _ _ _ _ _ _ _ _ : assert. (******************************************************************************) (** PART II: Proving correctness properties of the previously defined objects *) (******************************************************************************) Section hpoly_theory. Variable A : ringType. Instance zeroA : zero_of A := 0%R. Instance oneA : one_of A := 1%R. Instance addA : add_of A := +%R. Instance oppA : opp_of A := -%R. Instance subA : sub_of A := fun x y => x - y. Instance mulA : mul_of A := *%R. Instance eqA : eq_of A := eqtype.eq_op. Instance specA : spec_of A A := spec_id. Instance zero_nat : zero_of nat := 0%N. Instance eq_nat : eq_of nat := eqtype.eq_op. Instance lt_nat : lt_of nat := ltn. Instance leq_nat : leq_of nat := ssrnat.leq. Instance add_nat : add_of nat := addn. Instance sub_nat : sub_of nat := subn. Instance spec_nat : spec_of nat nat := spec_id. Fixpoint to_poly (p : hpoly A) := match p with | Pc c => c%:P | PX a n p => to_poly p * 'X^(cast (n : pos)) + a%:P end. Definition to_hpoly : {poly A} -> (@hpoly pos A) := fun p => from_seq (polyseq p). (* This instance has to be declared here in order not to make form_seq confused *) Instance one_nat : one_of nat := 1%N. Lemma to_hpolyK : cancel to_hpoly to_poly. Proof. elim/poly_ind; rewrite /to_hpoly ?polyseq0 // => p c ih. rewrite -{1}cons_poly_def polyseq_cons. have [|pn0] /= := nilP. rewrite -polyseq0 => /poly_inj ->; rewrite mul0r add0r. apply/poly_inj; rewrite !polyseqC. by case c0: (c == 0); rewrite ?polyseq0 // polyseqC c0. by case: (polyseq p) ih => /= [<-| a l -> //]; rewrite mul0r add0r. Qed. Lemma ncons_add : forall m n (a : A) p, ncons (m + n) a p = ncons m a (ncons n a p). Proof. by elim=> //= m ih n a p; rewrite ih. Qed. Lemma normalizeK : forall p, to_poly (normalize p) = to_poly p. Proof. elim => //= a n p <-; case: (normalize p) => //= b m q. case: ifP => //= /eqP ->; case: n => [[]] //= n n0. by rewrite addr0 /cast /cast_pos_nat insubdK /= ?exprD ?mulrA ?addnS. Qed. Definition Rhpoly : {poly A} -> hpoly A -> Type := fun_hrel to_poly. (* This is OK here, but not everywhere *) Instance refines_eq_refl A' (x : A') : refines Logic.eq x x | 999. Proof. by rewrite refinesE. Qed. Lemma RhpolyE p q : refines Rhpoly p q -> p = to_poly q. Proof. by rewrite refinesE. Qed. Instance Rhpolyspec_r x : refines Rhpoly (to_poly x) x | 10000. Proof. by rewrite !refinesE; case: x. Qed. Fact normalize_lock : unit. Proof. exact tt. Qed. Definition normalize_id := locked_with normalize_lock (@id {poly A}). Lemma normalize_idE p : normalize_id p = p. Proof. by rewrite /normalize_id unlock. Qed. Local Open Scope rel_scope. Instance Rhpoly_normalize : refines (Rhpoly ==> Rhpoly) normalize_id normalize. Proof. by rewrite refinesE => p hp rp; rewrite /Rhpoly /fun_hrel normalizeK normalize_idE. Qed. Instance Rhpoly_cast : refines (eq ==> Rhpoly) (fun x => x%:P) cast. Proof. by rewrite refinesE=> _ x ->; rewrite /Rhpoly /fun_hrel /cast /cast_hpoly /=. Qed. (* zero and one *) Instance Rhpoly_0 : refines Rhpoly 0%R 0%C. Proof. by rewrite refinesE. Qed. Instance Rhpoly_1 : refines Rhpoly 1%R 1%C. Proof. by rewrite refinesE. Qed. Instance Rhpoly_opp : refines (Rhpoly ==> Rhpoly) -%R -%C. Proof. apply refines_abstr => p hp h1. rewrite [p]RhpolyE refinesE /Rhpoly /fun_hrel {p h1}. by elim: hp => /= [a|a n p ->]; rewrite polyCN // opprD mulNr. Qed. Instance Rhpoly_scale : refines (Logic.eq ==> Rhpoly ==> Rhpoly) *:%R *:%C. Proof. rewrite refinesE => /= a b -> p hp h1. rewrite [p]RhpolyE /Rhpoly /fun_hrel {a p h1}. elim: hp => [a|a n p ih] /=; first by rewrite polyCM mul_polyC. by rewrite ih polyCM -!mul_polyC mulrDr mulrA. Qed. Lemma addXn_constE n a q : to_poly (addXn_const n a q) = a%:P * 'X^n + to_poly q. Proof. elim: q n => [b [|n]|b m q' ih n] /=; simpC; first by rewrite polyCD expr0 mulr1. by rewrite /cast /cast_pos_nat insubdK. case: eqP => [->|/eqP n0] /=; first by rewrite polyCD expr0 mulr1 addrCA. case: eqP => [hn|hnc] /=; first by rewrite ih expr0 mulr1 -hn mulrDl -addrA. rewrite [(_ < _)%C]/((_ < _)%N) subn_eq0. case hnm: (n < cast m). rewrite /= /cast /cast_nat_pos /cast_pos_nat. rewrite insubdK -?topredE /= ?lt0n // mulrDl -mulrA -exprD addrCA -addrA. by rewrite ?insubdK -?topredE /= ?subn_gt0 ?lt0n ?subnK // ltnW. by rewrite /= ih mulrDl -mulrA -exprD subnK ?addrA // leqNgt hnm. Qed. Arguments addXn_const _ _ _ _ _ _ _ _ _ _ _ n a q : simpl never. Lemma addXnE n p q : to_poly (addXn n p q) = to_poly p * 'X^n + to_poly q. Proof. elim: p n q => [a n q|a n' p ih n [b|b m q]] /=; simpC; first by rewrite addXn_constE. case: eqP => [->|/eqP n0]; first by rewrite expr0 mulr1 /= polyCD addrA. by rewrite /= /cast /cast_pos_nat /cast_nat_pos insubdK // -topredE /= lt0n. case: eqP => [->|/eqP no]. rewrite expr0 mulr1 /leq_op /leq_pos /eq_op /eq_pos. case: ifP => [/eqP ->|hneq] /=. by rewrite ih expr0 mulr1 mulrDl polyCD -!addrA [_ + (a%:P + _)]addrCA. rewrite -[(_ < _)%C]/((_ < _)%N). case hnm: (val n' < val m); rewrite /= ih polyCD mulrDl -!addrA ?expr0. rewrite mulr1 /= addr0 -mulrA -exprD [_ + (a%:P + _)]addrCA /cast. by rewrite /cast_pos_nat insubdK ?subnK -?topredE /= ?subn_gt0 // ltnW. rewrite -mulrA -exprD [_ + (a%:P + _)]addrCA /cast /cast_pos_nat. rewrite insubdK ?subnK // -?topredE /=; first by rewrite leqNgt hnm. rewrite subn_gt0 ltnNge leq_eqVlt hnm Bool.orb_false_r {hnm}. move/negbT: hneq; apply: contra; move/eqP=> heq; apply/eqP; exact: val_inj. rewrite !ih !addXn_constE expr0 mulr1 /= addr0 mulrDl -mulrA -exprD addnC. by rewrite -!addrA [b%:P + (_ + _)]addrCA [b%:P + _]addrC. Qed. Instance Rhpoly_add : refines (Rhpoly ==> Rhpoly ==> Rhpoly) +%R (add_hpoly (N:=nat)). Proof. apply refines_abstr2 => p hp h1 q hq h2. rewrite [p]RhpolyE [q]RhpolyE refinesE /Rhpoly /fun_hrel {p q h1 h2}. by rewrite /add_op /add_hpoly addXnE expr0 mulr1. Qed. Lemma to_poly_scale_l a p : to_poly (a *: p)%C = a *: (to_poly p). Proof. elim: p=> [b|b n p ih] /=; rewrite /mul_op /mulA -mul_polyC polyCM //. by rewrite ih -mul_polyC mulrDr mulrA /mul_op /mulA. Qed. Lemma mulXnC (R : ringType) (p : {poly R}) n : p * 'X^n = 'X^n * p. Proof. apply/polyP=> i. by rewrite coefMXn coefXnM. Qed. Lemma to_poly_scale_r a p : to_poly (map_hpoly (fun x => (x * a)%C) p) = to_poly p * a%:P. Proof. elim: p=> [b|b n p ih] /=; rewrite /mul_op /mulA polyCM //. by rewrite ih mulrDl -mulrA mulXnC -mulrA. Qed. Lemma cast_nat_posK n : n > 0 -> cast_pos_nat (cast_nat_pos n) = n. Proof. by rewrite /cast_pos_nat /cast_nat_pos val_insubd=> ->. Qed. Instance Rhpoly_mul : refines (Rhpoly ==> Rhpoly ==> Rhpoly) *%R (mul_hpoly (N:=nat)). Proof. apply refines_abstr2=> p hp h1 q hq h2. rewrite [p]RhpolyE [q]RhpolyE refinesE /Rhpoly /fun_hrel {p q h1 h2}. elim: hp hq => [a [b|b m l']|a n l ih [b|b m l']] /=; first by rewrite polyCM. by rewrite polyCM to_poly_scale_l -mul_polyC mulrDr mulrA. by rewrite polyCM to_poly_scale_r mulrDl -mulrA mulXnC mulrA. rewrite [in (cast _)]/add_op /add_pos. case: n=> n lt0n; case: m=> m lt0m /=. rewrite /cast cast_nat_posK /cast_pos_nat ?addn_gt0 ?lt0n //= /shift_hpoly. simpC; rewrite !gtn_eqF ?addn_gt0 ?lt0n //=. rewrite mulrDr !mulrDl -mulrA -mulXnC -mulrA -exprD !mulrA !addXnE /= expr0. rewrite !mulr1 !addr0 ih /cast !cast_nat_posK ?addn_gt0 ?lt0n //=. rewrite to_poly_scale_l to_poly_scale_r -mul_polyC -[_ * b%:P * _]mulrA. by rewrite [b%:P * _]mulXnC mulrA polyCM addnC. Qed. Instance Rhpoly_exp : refines (Rhpoly ==> Logic.eq ==> Rhpoly) (@GRing.exp _) exp_op. Proof. apply refines_abstr2=> p sp hp m n; rewrite refinesE=> -> {m}. rewrite /exp_op /exp_hpoly. elim: n=> [|n ihn] /=; by rewrite ?(expr0, exprS); tc. Qed. Instance Rhpoly_sub : refines (Rhpoly ==> Rhpoly ==> Rhpoly) (fun x y => x - y) (sub_hpoly (N:=nat)). Proof. apply refines_abstr2 => p hp h1 q hq h2. by rewrite refinesE /sub_hpoly /Rhpoly /fun_hrel [_ - _]RhpolyE. Qed. Instance Rhpoly_shift : refines (Logic.eq ==> Rhpoly ==> Rhpoly) (shiftp (R:=A)) shift_op. Proof. rewrite refinesE=> _ n -> p hp h1. rewrite [p]RhpolyE /Rhpoly /fun_hrel {p h1} /shiftp /shift_hpoly. case: n=> [|n] /=; first by rewrite expr0 mulr1. by rewrite addr0 /cast cast_nat_posK ?ltn0Sn. Qed. (* Add to ssr? *) Lemma size_MXnaddC (R : ringType) (p : {poly R}) (c : R) n : size (p * 'X^n.+1 + c%:P) = if (p == 0) then size c%:P else (n.+1 + size p)%N. Proof. have [->|/eqP hp0] := eqP; first by rewrite mul0r add0r. rewrite size_addl polyseqMXn ?size_ncons // size_polyC. by case: (c == 0)=> //=; rewrite ltnS ltn_addl // size_poly_gt0. Qed. Instance Rhpoly_eq0 : refines (Rhpoly ==> bool_R) (fun p => 0 == p) eq0_hpoly. Proof. rewrite refinesE => p hp rp; rewrite [p]RhpolyE {p rp} eq_sym. have -> : (to_poly hp == 0) = (eq0_hpoly hp). elim: hp => [a|a n p ih] /=; first by rewrite polyC_eq0. rewrite /cast /cast_pos_nat /=; case: n=> n ngt0. rewrite /val_of_pos -[n]prednK // -size_poly_eq0 size_MXnaddC -ih prednK //. case: ifP=> /=; first by rewrite size_poly_eq0 polyC_eq0. by rewrite addn_eq0 size_poly_eq0 andbC=> ->. exact: bool_Rxx. Qed. Instance Rhpoly_eq : refines (Rhpoly ==> Rhpoly ==> bool_R) eqtype.eq_op (eq_hpoly (N:=nat)). Proof. apply refines_abstr2=> p hp h1 q hq h2. rewrite /eq_hpoly refinesE -subr_eq0 eq_sym [_ == _]refines_eq. exact: bool_Rxx. Qed. Instance Rhpoly_size : refines (Rhpoly ==> Logic.eq) (sizep (R:=A)) size_op. Proof. apply refines_abstr=> p hp h1. rewrite [p]RhpolyE refinesE {p h1} sizepE /size_op. elim: hp=> [a|a n p ih] /=; first by rewrite size_polyC; simpC; case: eqP. rewrite /cast /cast_pos_nat /=; case: n=> n ngt0. rewrite /val_of_pos -[n]prednK // size_MXnaddC ih prednK // eq_sym [_ == _]refines_eq. by case: ifP=> //=; simpC; rewrite size_polyC; case: ifP. Qed. Lemma lead_coef_MXnaddC (R : ringType) (p : {poly R}) (c : R) n : lead_coef (p * 'X^n.+1 + c%:P) = if (lead_coef p == 0) then c else lead_coef p. Proof. have [|/eqP hp0] := eqP. move/eqP; rewrite lead_coef_eq0; move/eqP=> ->. by rewrite mul0r add0r lead_coefC. rewrite lead_coefDl; first by rewrite lead_coef_Mmonic ?monicXn. rewrite size_polyC size_Mmonic ?monicXn -?lead_coef_eq0 //. rewrite size_polyXn !addnS -pred_Sn. case: (c == 0)=> //=. by rewrite ltnS ltn_addr // size_poly_gt0 -lead_coef_eq0. Qed. Instance Rhpoly_lead_coef : refines (Rhpoly ==> Logic.eq) lead_coef lead_coef_op. Proof. rewrite /lead_coef_op refinesE=> _ hp <-. elim: hp=> [a|a n p ih] /=; first by rewrite lead_coefC. rewrite -ih /cast /cast_pos_nat /=; case: n=> n ngt0. by rewrite /val_of_pos -[n]prednK // lead_coef_MXnaddC. Qed. Lemma rdivpXnSm (p : {poly A}) a n m : rdivp (p * 'X^n + a%:P) 'X^m.+1 = if (n <= m.+1)%C then rdivp p 'X^(m.+1 - n) else p * 'X^(n - m.+1). Proof. have [leqnSm|gtnSm] := leqP n m.+1. rewrite [(_ <= _)%C]leqnSm. rewrite [p in LHS](@rdivp_eq _ 'X^(m.+1 - n)) ?monicXn //. rewrite mulrDl -addrA -mulrA -exprD subnK ?rdivp_addl_mul_small //. by rewrite monicXn. rewrite size_polyXn (leq_ltn_trans (size_add _ _)) // gtn_max. rewrite (leq_ltn_trans (size_mul_leq _ _)) /=. by rewrite size_polyC; case: (a != 0). rewrite size_polyXn addnS -pred_Sn addnC -ltn_subRL [X in (_ < X)]subSn //. by rewrite -[X in (_ < X)](size_polyXn A) ltn_rmodp monic_neq0 ?monicXn. rewrite ifN -?ltnNge // -[in LHS](subnK (ltnW gtnSm)) exprD mulrA. by rewrite rdivp_addl_mul_small ?monicXn ?size_polyC ?size_polyXn; case: (a != 0). Qed. Lemma rmodpXnSm (p : {poly A}) a n m : rmodp (p * 'X^n + a%:P) 'X^m.+1 = if (n <= m.+1)%C then (rmodp p 'X^(m.+1 - n)) * 'X^n + a%:P else a%:P. Proof. have [leqnSm|gtnSm] := leqP n m.+1. rewrite [(_ <= _)%C]leqnSm. rewrite [p in LHS](@rdivp_eq _ 'X^(m.+1 - n)) ?monicXn //. rewrite mulrDl -addrA -mulrA -exprD subnK ?rmodp_addl_mul_small //. by rewrite monicXn. rewrite size_polyXn (leq_ltn_trans (size_add _ _)) // gtn_max. rewrite (leq_ltn_trans (size_mul_leq _ _)) /=. by rewrite size_polyC; case: (a != 0). rewrite size_polyXn addnS -pred_Sn addnC -ltn_subRL [X in (_ < X)]subSn //. by rewrite -[X in (_ < X)](size_polyXn A) ltn_rmodp monic_neq0 ?monicXn. rewrite ifN -?ltnNge // -[in LHS](subnK (ltnW gtnSm)) exprD mulrA. by rewrite rmodp_addl_mul_small ?monicXn ?size_polyC ?size_polyXn; case: (a != 0). Qed. Instance Rhpoly_split : refines (Logic.eq ==> Rhpoly ==> prod_R Rhpoly Rhpoly) (splitp (R:=A)) split_op. Proof. rewrite refinesE=> _ m -> p hp h1. rewrite [p]RhpolyE /Rhpoly /fun_hrel /splitp /split_op {p h1} /=. apply: prod_RI; rewrite /prod_hrel /=. elim: hp m=> [a [|m]|a n p ih [|m]] /=; first by rewrite expr0 rdivp1 rmodp1. rewrite rdivp_small ?rmodp_small ?polyC0 // size_polyC size_polyXn; by case: (a != 0). by rewrite expr0 rdivp1 rmodp1. rewrite rdivpXnSm rmodpXnSm. case: ifP=> hnSm /=. have -> /= := surjective_pairing (split_hpoly (m.+1 - cast n)%C p). by have [-> ->] := ih (m.+1 - cast n)%C. rewrite /shift_hpoly [(_ == _)%C]subn_eq0 ifN /=. rewrite polyC0 addr0 /cast cast_nat_posK //. by rewrite subn_gt0 ltnNge [(_ <= _)%N]hnSm. by rewrite [(_ <= _)%N]hnSm. Qed. Instance Rhpoly_head : refines (Rhpoly ==> Logic.eq) (fun p => p`_0) head_hpoly. Proof. rewrite refinesE=> _ hp <-. elim: hp=> [a|a n p ih]; rewrite [to_poly _]/=; first by rewrite coefC. rewrite coefD coefMXn coefC /cast /cast_pos_nat. case: n=> n ngt0 /=. by rewrite ngt0 add0r. Qed. Instance Rhpoly_spec_l : refines (Rhpoly ==> Logic.eq) spec_id (spec_hpoly (N:=nat) (C:=A)). Proof. rewrite refinesE /spec_id=> _ hp <-. have simp_polyC a : a%:P = (if a == 0 then 0 else if a == 1 then 1 else (specA a)%:P). case: ifP=> [/eqP a0|_]; first by rewrite a0 polyC0. case: ifP=> [/eqP a1|_]; first by rewrite a1 polyC1. by rewrite /specA /spec_id. elim: hp=> [a|a n p ih] /=; simpC. exact: simp_polyC. rewrite spec_aux_shift /spec_nat /spec_id ih /spec_hpoly. case: ifP=> p0. rewrite spec_aux_eq0 // mul0r add0r. exact: simp_polyC. case: ifP=> [/eqP a0|_]; first by rewrite a0 polyC0 addr0. by rewrite [in LHS]simp_polyC. Qed. (*************************************************************************) (* PART III: Parametricity part *) (*************************************************************************) Section hpoly_parametricity. Import Refinements.Op. Context (C : Type) (rAC : A -> C -> Type). Context (P : Type) (rP : pos -> P -> Type). Context (N : Type) (rN : nat -> N -> Type). Context `{zero_of C, one_of C, opp_of C, add_of C, sub_of C, mul_of C, eq_of C}. Context `{one_of P, add_of P, sub_of P, eq_of P, lt_of P}. Context `{zero_of N, one_of N, eq_of N, lt_of N, leq_of N, add_of N, sub_of N}. Context `{cast_of N P, cast_of P N}. Context `{spec_of C A, spec_of N nat}. Context `{!refines rAC 0%R 0%C, !refines rAC 1%R 1%C}. Context `{!refines (rAC ==> rAC) -%R -%C}. Context `{!refines (rAC ==> rAC ==> rAC) +%R +%C}. Context `{!refines (rAC ==> rAC ==> rAC) (fun x y => x - y) sub_op}. Context `{!refines (rAC ==> rAC ==> rAC) *%R *%C}. Context `{!refines (rAC ==> rAC ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rAC ==> Logic.eq) spec_id spec}. Context `{!refines rP pos1 1%C}. Context `{!refines (rP ==> rP ==> rP) add_pos +%C}. Context `{!refines (rP ==> rP ==> rP) sub_pos sub_op}. Context `{!refines (rP ==> rP ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rP ==> rP ==> bool_R) lt_pos lt_op}. Context `{!refines rN 0%N 0%C, !refines rN 1%N 1%C}. Context `{!refines (rN ==> rN ==> rN) addn +%C}. Context `{!refines (rN ==> rN ==> rN) subn sub_op}. Context `{!refines (rN ==> rN ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rN ==> rN ==> bool_R) ltn lt_op}. Context `{!refines (rN ==> rN ==> bool_R) ssrnat.leq leq_op}. Context `{!refines (rN ==> rP) cast_nat_pos cast}. Context `{!refines (rP ==> rN) cast_pos_nat cast}. Context `{!refines (rN ==> nat_R) spec_id spec}. Definition RhpolyC := (Rhpoly \o (hpoly_R rP rAC)). #[export] Instance RhpolyC_0 : refines RhpolyC 0%R 0%C. Proof. param_comp zero_hpoly_R. Qed. #[export] Instance RhpolyC_1 : refines RhpolyC 1%R 1%C. Proof. param_comp one_hpoly_R. Qed. #[export] Instance RhpolyCD : refines (RhpolyC ==> RhpolyC ==> RhpolyC) +%R (add_hpoly (N:=N)). Proof. param_comp add_hpoly_R. Qed. #[export] Instance RhpolyCN : refines (RhpolyC ==> RhpolyC) -%R -%C. Proof. param_comp opp_hpoly_R. Qed. #[export] Instance RhpolyC_sub : refines (RhpolyC ==> RhpolyC ==> RhpolyC) (fun x y => x - y) (sub_hpoly (N:=N)). Proof. param_comp sub_hpoly_R. Qed. #[export] Instance RhpolyCM : refines (RhpolyC ==> RhpolyC ==> RhpolyC) *%R (mul_hpoly (N:=N)). Proof. param_comp mul_hpoly_R. Qed. #[export] Instance RhpolyC_exp : refines (RhpolyC ==> rN ==> RhpolyC) (@GRing.exp _) exp_op. Proof. eapply refines_trans; tc. rewrite refinesE; do ?move=> ?*. eapply (@exp_hpoly_R _ _ _ _ _ rN)=> // *; exact: refinesP. Qed. #[export] Instance RhpolyC_size : refines (RhpolyC ==> rN) (sizep (R:=A)) size_hpoly. Proof. param_comp size_hpoly_R. Qed. #[export] Instance RhpolyC_lead_coef : refines (RhpolyC ==> rAC) lead_coef lead_coef_op. Proof. rewrite /lead_coef_op. param_comp lead_coef_hpoly_R. Qed. #[export] Instance RhpolyC_polyC : refines (rAC ==> RhpolyC) (fun a => a%:P) cast. Proof. param_comp cast_hpoly_R. Qed. #[export] Instance RhpolyC_eq : refines (RhpolyC ==> RhpolyC ==> bool_R) eqtype.eq_op (eq_hpoly (N:=N)). Proof. param_comp eq_hpoly_R. Qed. #[export] Instance RhpolyC_scale : refines (rAC ==> RhpolyC ==> RhpolyC) *:%R *:%C. Proof. param_comp scale_hpoly_R. Qed. #[export] Instance RhpolyC_shift : refines (rN ==> RhpolyC ==> RhpolyC) (shiftp (R:=A)) shift_hpoly. Proof. eapply refines_trans; tc. rewrite refinesE; do ?move=> ?*. eapply (@shift_hpoly_R _ _ _ _ _ rN)=> // *; exact: refinesP. Qed. #[export] Instance RhpolyCMXn p sp n rn : refines rN n rn -> refines RhpolyC p sp -> refines RhpolyC (p * 'X^n) (shift_op rn sp). Proof. by move=> hn hp; rewrite -[_ * 'X^_]/(shiftp _ _); tc. Qed. #[export] Instance RhpolyC_Xnmul p sp n rn : refines rN n rn -> refines RhpolyC p sp -> refines RhpolyC ('X^n * p) (shift_op rn sp). Proof. rewrite -mulXnC; exact: RhpolyCMXn. Qed. #[export] Instance RhpolyC_scaleXn c rc n rn : refines rN n rn -> refines rAC c rc -> refines RhpolyC (c *: 'X^n) (shift_op rn (cast rc)). Proof. move=> hn hc; rewrite -mul_polyC -[_ * 'X^_]/(shiftp _ _). exact: refines_apply. Qed. #[export] Instance RhpolyCMX p sp : refines RhpolyC p sp -> refines RhpolyC (p * 'X) (shift_op (1%C : N) sp). Proof. rewrite -['X]expr1; exact: RhpolyCMXn. Qed. #[export] Instance RhpolyC_Xmul p sp : refines RhpolyC p sp -> refines RhpolyC ('X * p) (shift_op (1%C : N) sp). Proof. rewrite -['X]expr1 -mulXnC; exact: RhpolyCMX. Qed. #[export] Instance RhpolyC_scaleX c rc : refines rAC c rc -> refines RhpolyC (c *: 'X) (shift_op (1%C : N) (cast rc)). Proof. rewrite -['X]expr1; exact: RhpolyC_scaleXn. Qed. #[export] Instance RhpolyC_split : refines (rN ==> RhpolyC ==> prod_R RhpolyC RhpolyC) (splitp (R:=A)) split_op. Proof. refines_trans. rewrite refinesE; do ?move=> ?*. eapply (@split_hpoly_R _ _ _ _ _ rN)=> // *; exact: refinesP. Qed. #[export] Instance RhpolyC_splitn n rn p sp : refines rN n rn -> refines RhpolyC p sp -> refines (prod_R RhpolyC RhpolyC) (splitp n p) (split_op rn sp). Proof. by move=> hn hp; exact: refines_apply. Qed. (* same as for seqpoly... maybe have a generic version + refinement instance in another file? *) Definition eq_prod_hpoly (x y : (@hpoly P C * @hpoly P C)) := (eq_hpoly (N:=N) x.1 y.1) && (eq_hpoly (N:=N) x.2 y.2). #[export] Instance refines_prod_RhpolyC_eq : refines (prod_R RhpolyC RhpolyC ==> prod_R RhpolyC RhpolyC ==> bool_R) eqtype.eq_op eq_prod_hpoly. Proof. rewrite refinesE=> x x' hx y y' hy. rewrite /eqtype.eq_op /eq_prod_hpoly /=. have -> : (x.1 == y.1) = (eq_hpoly (N:=N) x'.1 y'.1). exact: refines_eq. have -> : (x.2 == y.2) = (eq_hpoly (N:=N) x'.2 y'.2). exact: refines_eq. exact: bool_Rxx. Qed. #[export] Instance RhpolyC_X : refines RhpolyC 'X (shift_op (1%C : N) 1)%C. Proof. rewrite -['X]mul1r; exact: RhpolyCMX. Qed. #[export] Instance RhpolyC_Xn n rn : refines rN n rn -> refines RhpolyC 'X^n (shift_op rn 1)%C. Proof. move=> hn; rewrite -['X^_]mul1r; exact: RhpolyCMXn. Qed. (* #[export] Instance RhpolyC_horner : param (RhpolyC ==> rAC ==> rAC) *) (* (fun p x => p.[x]) (fun sp x => horner_seq sp x). *) (* Proof. admit. Qed. *) (* (* Proof. exact: param_trans. Qed. *) *) #[export] Instance RhpolyC_head : refines (RhpolyC ==> rAC) (fun p => p`_0) head_hpoly. Proof. param_comp head_hpoly_R. Qed. #[export] Instance RhpolyC_spec : refines (RhpolyC ==> eq) spec_id (spec_hpoly (N:=N) (C:=C)). Proof. eapply refines_trans; tc. rewrite refinesE=> hp hq rpq. elim: rpq=> {hp hq} [a c rac|a c rac n m rnm hp hq rpq] /=; rewrite ![(a == _)%C]refines_eq /specA [spec_id _]refines_eq //=. have -> : eq0_hpoly hp = eq0_hpoly hq. elim: rpq=> [x y rxy|x y rxy k l rkl p q rpq ih]; by rewrite /= [(_ == _)%C]refines_eq ?ih. rewrite /spec_nat [spec_id _]refines_eq. by rewrite ![spec_hpoly_aux (spec _) _]spec_aux_shift=> ->. Qed. End hpoly_parametricity. End hpoly_theory. From mathcomp Require Import ssrint. From CoqEAL Require Import binnat binint. Section testpoly. Goal (0 == 0 :> {poly int}). by coqeal. Abort. Goal (0 == (0 : {poly {poly {poly int}}})). (* by coqeal. *) Abort. Goal (1 == 1 :> {poly int}). by coqeal. Abort. Goal (1 == (1 : {poly {poly {poly int}}})). (* by coqeal. *) Abort. Goal ((1 + 2%:Z *: 'X + 3%:Z *: 'X^2) + (1 + 2%:Z%:P * 'X + 3%:Z%:P * 'X^2) == (1 + 1 + (2%:Z + 2%:Z) *: 'X + (3%:Z + 3%:Z)%:P * 'X^2)). rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. (* by coqeal. *) Abort. Goal (- 1 == - (1: {poly {poly int}})). by coqeal. Abort. Goal (- (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2) == -1 - 2%:Z%:P * 'X - 3%:Z *: 'X^2). by coqeal. Abort. Goal (1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) == 0). by rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. Abort. Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z *: 'X^2). by coqeal. Abort. (* (1 + xy) * x = x + x^2y *) Goal ((1 + 'X * 'X%:P) * 'X == 'X + 'X^2 * 'X%:P :> {poly {poly int}}). rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. (* by coqeal. *) Abort. Goal (sizep ('X^2 : {poly int}) == sizep (- 3%:Z *: 'X^(sizep ('X : {poly int})))). by coqeal. Abort. Definition test := [coqeal simpl of sizep (1 + 2%:Z *: 'X + 3%:Z *: 'X^2)]. Goal (sizep (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) = 3%N). by coqeal. Qed. Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int}))) == 1 + 4%:Z *: 'X + 4%:Z *: 'X^(sizep (10%:Z *: 'X))). by coqeal. Abort. Goal (splitp 2 (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) == (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)). by coqeal. Abort. Goal (splitp (sizep ('X : {poly int})) (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) == (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)). by coqeal. Abort. End testpoly. coqeal-2.1.0/refinements/hrel.v000066400000000000000000000054241475512565300164400ustar00rootroot00000000000000 (** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset bigop. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Declare Scope rel_scope. Delimit Scope rel_scope with rel. (***************************) (* Heterogeneous Relations *) (***************************) Section hrel. Definition sub_hrel A B (R R' : A -> B -> Type) := forall (x : A) (y : B), R x y -> R' x y. Notation "X <= Y" := (sub_hrel X%rel Y%rel) : rel_scope. Inductive eq_hrel A B (R R' : A -> B -> Type) := EqHrel of (R <= R')%rel & (R' <= R)%rel. Notation "X <=> Y" := (eq_hrel X Y) (format "X <=> Y", at level 95) : rel_scope. Lemma eq_hrelRL A B (R R' : A -> B -> Type) : (R <=> R')%rel -> (R <= R')%rel. Proof. by case. Qed. Lemma eq_hrelLR A B (R R' : A -> B -> Type) : (R <=> R')%rel -> (R' <= R)%rel. Proof. by case. Qed. Definition comp_hrel A B C (R : A -> B -> Type) (R' : B -> C -> Type) : A -> C -> Type := fun a c => sigT (fun b => R a b * R' b c)%type. Notation "X \o Y" := (comp_hrel X Y) : rel_scope. Lemma comp_hrelP A B C (R : A -> B -> Type) (R' : B -> C -> Type) (b : B) (a : A) (c : C) : R a b -> R' b c -> (R \o R')%rel a c. Proof. by exists b. Qed. Definition prod_hrel A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) : A * B -> A' * B' -> Type := fun x y => (rA x.1 y.1 * rB x.2 y.2)%type. Lemma comp_eqr A B (R : A -> B -> Type) : (R \o eq <= R)%rel. Proof. by move=> x y [y' [? <-]]. Qed. Lemma comp_eql A B (R : A -> B -> Type) : (eq \o R <= R)%rel. Proof. by move=> x y [y' [<-]]. Qed. Definition fun_hrel A B (f : B -> A) : A -> B -> Type := fun a b => f b = a. Definition ofun_hrel A B (f : B -> option A) : A -> B -> Type := fun a b => f b = Some a. Definition hrespectful (A B C D : Type) (R : A -> B -> Type) (R' : C -> D -> Type) : (A -> C) -> (B -> D) -> Type := fun f g => forall (x : A) (y : B), R x y -> R' (f x) (g y). Notation " R ==> S " := (@hrespectful _ _ _ _ R%rel S%rel) (right associativity, at level 55) : rel_scope. Lemma sub_hresp_comp A B C (R1 R1' : A -> B -> Prop) (R2 R2' : B -> C -> Prop) : (((R1 ==> R1') \o (R2 ==> R2')) <= ((R1 \o R2) ==> (R1' \o R2')))%rel. Proof. move=> f h [g [rfg rgh]] x z [y [rxy ryz]]; exists (g y). by split; [apply: rfg | apply: rgh]. Qed. End hrel. Notation "X \o Y" := (comp_hrel X%rel Y%rel) : rel_scope. Notation "X <= Y" := (sub_hrel X%rel Y%rel) : rel_scope. Notation "X <=> Y" := (eq_hrel X%rel Y%rel) (format "X <=> Y", at level 95) : rel_scope. Notation " R ==> S " := (@hrespectful _ _ _ _ R%rel S%rel) (right associativity, at level 55) : rel_scope. coqeal-2.1.0/refinements/karatsuba.v000066400000000000000000000130071475512565300174570ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv. From CoqEAL Require Import hrel param refinements poly_op. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op Poly.Op. Local Open Scope ring_scope. Local Open Scope rel. Section karatsuba_generic. Variable polyA N : Type. Context `{add_of polyA, mul_of polyA, sub_of polyA}. Context `{shiftp : shift_of polyA N, sizep : size_of polyA N}. Context `{splitp : split_of polyA N}. Context `{one_of N, add_of N, mul_of N, leq_of N}. Context `{spec_of N nat, implem_of nat N}. Fixpoint karatsuba_rec n (p q : polyA) := match n with | 0 => (p * q)%C | n'.+1 => let sp := sizep p in let sq := sizep q in if (sp <= 1 + 1)%C || (sq <= 1 + 1)%C then (p * q)%C else let m := implem (minn (spec sp)./2 (spec sq)./2) in let (p1,p2) := splitp m p in let (q1,q2) := splitp m q in let p1q1 := karatsuba_rec n' p1 q1 in let p2q2 := karatsuba_rec n' p2 q2 in let p12 := (p1 + p2)%C in let q12 := (q1 + q2)%C in let p12q12 := karatsuba_rec n' p12 q12 in (shiftp ((1 + 1) * m)%C p1q1 + shiftp m (p12q12 - p1q1 - p2q2) + p2q2)%C end. Definition karatsuba p q := karatsuba_rec (maxn (spec (sizep p)) (spec (sizep q))) p q. End karatsuba_generic. Elpi derive.param2 karatsuba_rec. Elpi derive.param2 karatsuba. Section karatsuba_correctness. Local Open Scope rel_scope. Variable R : ringType. Instance add_polyR : add_of {poly R} := +%R. Instance mul_polyR : mul_of {poly R} := *%R. Instance sub_polyR : sub_of {poly R} := fun x y => (x - y)%R. Instance size_polyR : size_of {poly R} nat := sizep (R:=R). Instance shift_polyR : shift_of {poly R} nat := shiftp (R:=R). Instance split_polyR : split_of {poly R} nat := splitp (R:=R). Local Instance one_nat : one_of nat := 1%N. Local Instance add_nat : add_of nat := addn. Local Instance mul_nat : mul_of nat := muln. Local Instance leq_nat : leq_of nat := ssrnat.leq. Local Instance spec_nat : spec_of nat nat := spec_id. Local Instance implem_nat : implem_of nat nat := implem_id. Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec (N:=nat) n p q = p * q. Proof. elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _. rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)). rewrite /shift_op /shift_polyR /shiftp /implem /implem_nat /implem_id. simpC. rewrite !ih !(mulrDl, mulrDr, mulNr) mulnC exprM. rewrite -[in X in X + _]addrA -opprD [X in X + _ - _]addrC [in LHS]addrACA. by rewrite addrK !(commr_polyXn, mulrA, addrA). Qed. Lemma karatsubaE (p q : {poly R}) : karatsuba (N:=nat) p q = p * q. Proof. exact: karatsuba_recE. Qed. Section karatsuba_param. Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). Context (N : Type) (rN : nat -> N -> Type). Context `{add_of polyC, mul_of polyC, sub_of polyC}. Context `{one_of N, add_of N, mul_of N, leq_of N}. Context `{spec_of N nat, implem_of nat N}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) (fun x y => x - y)%R sub_op}. Context `{!refines rN 1%N 1%C}. Context `{!refines (rN ==> rN ==> rN) addn +%C}. Context `{!refines (rN ==> rN ==> rN) muln *%C}. Context `{!refines (rN ==> rN ==> bool_R) ssrnat.leq leq_op}. Context `{!refines (rN ==> nat_R) spec_id spec, !refines (nat_R ==> rN) implem_id implem}. Context `{!shift_of polyC N}. Context `{!refines (rN ==> RpolyC ==> RpolyC) shift_polyR shift_op}. Context `{!size_of polyC N}. Context `{!refines (RpolyC ==> rN) size_polyR size_op}. Context `{!split_of polyC N}. Context `{!refines (rN ==> RpolyC ==> prod_R RpolyC RpolyC) split_polyR split_op}. #[export] Instance RpolyC_karatsuba_rec : refines (nat_R ==> RpolyC ==> RpolyC ==> RpolyC) (karatsuba_rec (polyA:={poly R}) (N:=nat)) (karatsuba_rec (polyA:=polyC) (N:=N)). Proof. param karatsuba_rec_R. Qed. #[export] Instance RpolyC_karatsuba : refines (RpolyC ==> RpolyC ==> RpolyC) (karatsuba (polyA:={poly R}) (N:=nat)) (karatsuba (polyA:=polyC) (N:=N)). Proof. param karatsuba_R. Qed. #[export] Instance RpolyC_karatsuba_mul p sp q sq : refines RpolyC p sp -> refines RpolyC q sq -> refines RpolyC (p * q) (karatsuba (N:=N) sp sq). Proof. move=> hp hq. rewrite refinesE -karatsubaE. exact: refinesP. Qed. End karatsuba_param. End karatsuba_correctness. From mathcomp Require Import ssrint. From CoqEAL Require Import binnat binint seqpoly. Section karatsuba_test. Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z%:P * 'X^2). by coqeal. Abort. Goal (Poly [:: 1; 2%:Z] * Poly [:: 1; 2%:Z]) == Poly [:: 1; 4%:Z; 4%:Z]. by coqeal. Abort. Fixpoint bigseq (x : int) (n : nat) : seq int := match n with | 0 => [:: x] | n'.+1 => x :: bigseq (x+1) n' end. Fixpoint bigpoly (x : int) (n : nat) : {poly int} := match n with | 0 => x%:P | n.+1 => x%:P + (bigpoly (x+1) n) * 'X end. Let p1 := Eval compute in bigseq 1%N 10. Let p2 := Eval compute in bigseq 2%N 10. Let q1 := Eval simpl in bigpoly 1%N 10. Let q2 := Eval simpl in bigpoly 2%N 10. (* TODO: Translate Poly directly? *) Goal (Poly p1 * Poly p2 == Poly p2 * Poly p1). by coqeal. Abort. Goal (q1 * q2 == q2 * q1). by coqeal. Abort. End karatsuba_test. coqeal-2.1.0/refinements/multipoly.v000066400000000000000000002361371475512565300175530ustar00rootroot00000000000000(** Authors: Erik Martin-Dorel and Pierre Roux, 2016-2017 *) Require Import ZArith NArith FMaps FMapAVL. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. From mathcomp Require Import choice finfun tuple fintype order ssralg bigop. From CoqEAL Require Import hrel. From CoqEAL Require Import refinements. From CoqEAL Require Import param binord binnat. From CoqEAL Require Import seqmx (* for zipwith and eq_seq *). From CoqEAL Require Import ssrcomplements. (* Multivariate polynomials from https://github.com/math-comp/multinomials.git *) From mathcomp.multinomials Require Import mpoly freeg. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. (** * CoqEAL refinement for effective multivariate polynomials built on FMaps *) (** N.B.: Do not use {vm_,native_}compute directly on the various [..._eff] functions as FMaps contain proof terms about balancing of binary trees. Rather surround the polynomial expression with a call to list_of_mpoly_eff. *) Import Refinements.Op. Local Open Scope ring_scope. (** BEGIN FIXME this is redundant with PR CoqEAL/CoqEAL#3 *) Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *) #[export] Hint Resolve nil_R : core. (** END FIXME this is redundant with PR CoqEAL/CoqEAL#3 *) (** Tip to leverage a Boolean condition *) Definition sumb (b : bool) : {b = true} + {b = false} := if b is true then left erefl else right erefl. Definition Rord0 {n1} : 'I_n1 -> nat -> Type := fun x y => x = y :> nat. Lemma Rord0_eq (n1 : nat) i i' : refines (@Rord0 n1) i i' -> i = i' :> nat. Proof. by rewrite refinesE =>->. Qed. (** ** Part 1: Generic operations *) Section effmpoly_generic. (** Monomials *) (** [mnmd i d] represents the monomial X_i^d *) Definition mnmd {n} (i : 'I_n) (d : nat) := [multinom (if (i == j :> nat) then d else 0%N) | j < n]. Definition mpvar {T : ringType} {n} (c : T) d i : {mpoly T[n]} := c *: 'X_[mnmd i d]. Definition seqmultinom := seq binnat.N. Definition mnm0_seq {n} : seqmultinom := nseq n 0%num. Definition mnmd_seq {n} (i : nat) (d : binnat.N) : seqmultinom := nseq i 0%num ++ [:: d] ++ nseq (n - i - 1) 0%num. (** Multiplication of multinomials *) Definition mnm_add_seq (m1 m2 : seqmultinom) := map (fun xy => xy.1 + xy.2)%C (zip m1 m2). Definition mdeg_eff : seqmultinom -> binnat.N := foldl +%C 0%C. Fixpoint mnmc_lt_seq_aux (s1 s2 : seq binnat.N) {struct s1} : bool := match s1, s2 with | [::], [::] => false | [::], _ => true | x1 :: s1', [::] => false | x1 :: s1', x2 :: s2' => (x1 < x2)%C || (x1 == x2)%C && mnmc_lt_seq_aux s1' s2' end. Definition mnmc_lt_seq (s1 s2 : seq binnat.N) : bool := mnmc_lt_seq_aux (mdeg_eff s1 :: s1) (mdeg_eff s2 :: s2). Definition mnmc_eq_seq := eq_seq (fun n m : binnat.N => n == m)%C. Lemma mnmc_eq_seqP s1 s2 : reflect (mnmc_eq_seq s1 s2) (s1 == s2). Proof. move: s2; elim s1 => {s1}[|a1 s1 Hind] s2. { now case s2 => [|n l]; apply (iffP idP). } case s2 => {s2}[|a2 s2]; [by apply (iffP idP)|]. specialize (Hind s2); rewrite /mnmc_eq_seq /=; apply (iffP idP). { move/eqP => [Hs Ha]; rewrite Hs Rnat_eqxx /=. exact/Hind/eqP. } by move/andP => [Ha Hs]; apply/eqP; f_equal; apply /eqP => //; apply/Hind. Qed. End effmpoly_generic. Module MultinomOrd <: OrderedType. Definition t := seqmultinom. Definition eq : t -> t -> Prop := mnmc_eq_seq. Definition lt : t -> t -> Prop := mnmc_lt_seq. Lemma intro_eq x y : (mnmc_lt_seq x y = false) -> (mnmc_lt_seq y x = false) -> mnmc_eq_seq x y. Proof. rewrite /mnmc_lt_seq /=. rewrite !Rnat_ltE !Rnat_eqE. case Hlt : (_ < _)=>//=; case Hlt' : (_ < _)=>//=; move: Hlt Hlt'. rewrite !ltnNge !negb_false_iff !eqn_leq =>->->/=. elim: x y => [|hx tx Hind]; case=> // hy ty. rewrite /= !Rnat_ltE !Rnat_eqE. case (ltnP (spec_N hx) (spec_N hy)) => //= Hxy; case (ltnP (spec_N hy) (spec_N hx)) => //= Hyx. have Exy : (spec_N hx == spec_N hy). by apply/eqP/anti_leq; rewrite Hyx. rewrite /mnmc_eq_seq /= Rnat_eqE Exy; rewrite eq_sym in Exy; rewrite Exy /=. exact: Hind. Qed. (** Remark: only compare is used in implementation (eq_dec isn't). *) Definition compare (x y : t) : Compare lt eq x y := match sumb (mnmc_lt_seq x y) with | left prf => LT prf | right prf => match sumb (mnmc_lt_seq y x) with | left prf' => GT prf' | right prf' => EQ (intro_eq prf prf') end end. Lemma eq_dec (x y : t) : {eq x y} + {~ eq x y}. Proof. by rewrite /eq; case (mnmc_eq_seq x y); [left|right]. Qed. Lemma eq_refl : forall x : t, eq x x. Proof. by move=> x; apply/mnmc_eq_seqP/eqP. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. Proof. move=> x y /mnmc_eq_seqP/eqP =>->; apply eq_refl. Qed. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Proof. by move=> x y z /mnmc_eq_seqP/eqP =>->. Qed. Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. move=> x y z; rewrite /lt /mnmc_lt_seq. set x' := _ :: x; set y' := _ :: y; set z' := _ :: z. clearbody x' y' z'; clear x y z; move: x' y' z'. elim => [|hx tx Hind] y z; [by case y => // hy ty; case z|]. case y => // hy ty; case z => // hz tz. move/orP; rewrite !Rnat_E => -[Hxy|Hxy]. { move/orP; rewrite !Rnat_E => -[Hyz|Hyz]; apply/orP; rewrite !Rnat_E; left; [by move: Hyz; apply ltn_trans|]. move/andP in Hyz; destruct Hyz as [Hyz Hyz']. by move/eqP in Hyz; rewrite -Hyz. } move/andP in Hxy; destruct Hxy as [Hxy Hxy']; move/eqP in Hxy. rewrite /mnmc_lt_seq_aux !Rnat_E Hxy. move/orP => [Hyz|Hyz]; apply/orP; [by left|right]. move/andP in Hyz; destruct Hyz as [Hyz Hyz']; rewrite Hyz /=. by move: Hyz'; apply Hind. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Proof. move=> x y; rewrite /lt /mnmc_lt_seq /=; move/orP; elim. { move=> Hlt Heq; move: Heq Hlt; move/mnmc_eq_seqP/eqP->. by rewrite Rnat_E ltnn. } move/andP; case=>_. move=> Hlt /mnmc_eq_seqP/eqP Heq; move: Hlt; rewrite Heq. elim y => [//|h t Hind] /orP [H|H]; [by move: H; rewrite Rnat_E ltnn|]. move/andP in H; apply Hind, H. Qed. End MultinomOrd. (** Generic implementation of multivariate polynomials that can be instanciated with e.g. [M := FMapList.Make MultinomOrd] or [M := FMapAVL.Make MultinomOrd] *) Module FMapMultipoly (M : Sfun MultinomOrd). Arguments M.empty {elt}. Definition effmpoly := M.t. Module E := MultinomOrd. Module P := WProperties_fun E M. Module F := P.F. Section MoreProps. Definition singleton T key (val : T) := M.add key val M.empty. Lemma singleton_mapsto {T} k k' (e e' : T) : M.MapsTo k e (singleton k' e') -> (k = k' /\ e = e'). Proof. rewrite F.add_mapsto_iff; elim; move=> [Hk He]; [split; [|by[]]|]. by move/mnmc_eq_seqP/eqP in Hk. by move: He; rewrite F.empty_mapsto_iff. Qed. Lemma singleton_in_iff {T} y k (e : T) : M.In y (singleton k e) <-> E.eq k y. Proof. split; [move/F.add_in_iff|move=> H; apply/F.add_in_iff]. by intuition; move/F.empty_in_iff in H. by left. Qed. (* Variants of stdlib lemmas in Type *) Lemma add_mapsto_iff_dec {T} (m : M.t T) (x y : M.key) (e e' : T) : (M.MapsTo y e' (M.add x e m) <=> {(E.eq x y) * (e = e')} + {(~ E.eq x y) * (M.MapsTo y e' m)})%type. Proof. split. destruct (E.eq_dec x y); [left|right]. split; auto. symmetry; apply (F.MapsTo_fun (e':=e) H). exact: M.add_1. split; auto; apply M.add_3 with x e; auto. case; case => H1 H2. - rewrite H2; exact: M.add_1. - exact: M.add_2. Qed. Lemma MIn_sig T (k : M.key) (m : M.t T) : M.In k m -> {e | M.MapsTo k e m}. Proof. move=> HIn. case Ee : (M.find k m) => [e|]. by exists e; apply: M.find_2. by move/F.in_find_iff in HIn. Qed. Lemma map_mapsto_iff_dec {T T'} (m : M.t T) (x : M.key) (b : T') (f : T -> T') : M.MapsTo x b (M.map f m) <=> {a : T | b = f a /\ M.MapsTo x a m}. Proof. split. case_eq (M.find x m) => [e He|] H. exists e. split. apply (F.MapsTo_fun (m:=M.map f m) (x:=x)); auto. apply M.find_2. by rewrite F.map_o /option_map He. by apply M.find_2. move=> H0. have H1 : (M.In x (M.map f m)) by exists b; auto. have [a H2] := MIn_sig (M.map_2 H1). rewrite (M.find_1 H2) in H; discriminate. intros (a,(H,H0)). subst b. exact: M.map_1. Qed. (** As in the latest version of CoqEAL, all relations are in [Type], while most lemmas from FMaps are in [Prop], we will sometimes need to "lift" these lemmas in [Type] by using decidability arguments. *) Lemma or_dec P Q : decidable P -> decidable Q -> P \/ Q -> {P} + {Q}. Proof. case; first by move=> *; left. move=> nP [|nQ]; first by move=> *; right. move=> K; exfalso; by destruct K. Qed. Lemma MIn_dec {T} k (m : M.t T) : decidable (M.In k m). Proof. case E: (M.mem k m); [left|right]; apply/F.mem_in_iff =>//. by rewrite E. Qed. Lemma map2_2_dec {T T' T''} (m : M.t T) (m' : M.t T') (x : M.key) (f : option T -> option T' -> option T'') : M.In x (M.map2 f m m') -> {M.In x m} + {M.In x m'}. Proof. move=> HIn; apply: or_dec; try exact: MIn_dec. exact: M.map2_2 HIn. Qed. Lemma map2_ifft {T T' T''} (m : M.t T) (m' : M.t T') (x : M.key) (f : option T -> option T' -> option T'') : (forall t t', f (Some t) t' <> None) -> (forall t t', f t (Some t') <> None) -> M.In x (M.map2 f m m') <=> {M.In x m} + {M.In x m'}. Proof. move=> H1 H2. split; first exact: map2_2_dec. case=> HIn; apply F.in_find_iff; erewrite M.map2_1; try solve [by left|by right]; move/F.in_find_iff in HIn; by case: M.find HIn. Qed. Lemma HdRel_dec T (R : T -> T -> Prop) a l : (forall a b, decidable (R a b)) -> decidable (HdRel R a l). Proof. move=> Hdec. elim: l => [//|b l [IHl|IHl]]; first by left. - have [Rab|Rab] := Hdec a b. + by left; constructor. + by right=> K; inversion K. - have [Rab|Rab] := Hdec a b. + by left; constructor. + by right=> K; inversion K. Qed. Lemma Sorted_dec T (R : T -> T -> Prop) l : (forall a b, decidable (R a b)) -> decidable (Sorted R l). Proof. move=> Hdec. elim: l =>[//| a l [IHl|IHl]]; first by left. have [Ral|Ral] := @HdRel_dec T R a l Hdec. - left; constructor =>//. - by right => K; apply: Ral; inversion K. - by right => K; apply: IHl; inversion K. Qed. Inductive HdRelT (A : Type) (R : A -> A -> Prop) (a : A) : seq A -> Type := HdRelT_nil : HdRelT [::] | HdRelT_cons : forall (b : A) (l : seq A), R a b -> HdRelT (b :: l). Inductive SortedT (A : Type) (R : A -> A -> Prop) : seq A -> Type := SortedT_nil : SortedT [::] | SortedT_cons : forall (a : A) (l : seq A), SortedT l -> HdRelT R a l -> SortedT (a :: l). Lemma HdRelT_dec T (R : T -> T -> Prop) a l : (forall a b, decidable (R a b)) -> HdRel R a l -> HdRelT R a l. Proof. move=> Hdec H0. elim: l H0 => [//|b l] H0; first by left. have [Rab|Rab] := Hdec a b. + by move=> ?; constructor. + by move=> K0; exfalso; inversion K0. Qed. Lemma SortedT_dec T (R : T -> T -> Prop) l : (forall a b, decidable (R a b)) -> Sorted R l -> SortedT R l. Proof. move=> Hdec H0. elim: l H0 =>[//| a l] H0; first by left. have [Ral|Ral] := @HdRel_dec T R a l Hdec. - move=> SRal; constructor. + by apply H0; inversion SRal. + exact: HdRelT_dec. - move => K; constructor. + by apply: H0; inversion K. + by exfalso; apply: Ral; inversion K. Qed. End MoreProps. Definition list_of_mpoly {R : ringType} {n} (p : {mpoly R[n]}) : seq ('X_{1..n} * R) := [seq (m, p@_m) | m <- path.sort mnmc_le (msupp p)]. Section effmpoly_generic_2. Context {T : Type} `{!zero_of T, !one_of T}. Context `{!add_of T, !opp_of T, !sub_of T, !mul_of T, !eq_of T}. Context {n : nat}. Definition list_of_mpoly_eff (p : effmpoly T) : seq (seqmultinom * T) := [seq mc <- M.elements p | negb (mc.2 == 0)%C]. Definition mpoly_of_list_eff (l : seq (seqmultinom * T)) : effmpoly T := foldl (fun m mc => M.add mc.1 mc.2 m) M.empty l. Definition mp0_eff : effmpoly T := M.empty. Definition mp1_eff := singleton (@mnm0_seq n) (1%C : T). Definition mpvar_eff (c : T) (d : binnat.N) (i : nat) : effmpoly T := singleton (@mnmd_seq n i d) c. Definition mpolyC_eff (c : T) : effmpoly T := singleton (@mnm0_seq n) c. Definition mpolyX_eff (m : seqmultinom) : effmpoly T := singleton m 1%C. Definition mpoly_scale_eff (c : T) (p : effmpoly T) : effmpoly T := M.map (fun x => c * x)%C p. Definition mpoly_add_eff : effmpoly T -> effmpoly T -> effmpoly T := M.map2 (fun c1 c2 => match c1, c2 with | Some c1, Some c2 => Some (c1 + c2)%C | Some c, _ | _, Some c => Some c | None, None => None end). Definition mpoly_sub_eff : effmpoly T -> effmpoly T -> effmpoly T := M.map2 (fun c1 c2 => match c1, c2 with | Some c1, Some c2 => Some (c1 - c2)%C | Some c, _ => Some c | _, Some c => Some (- c)%C | None, None => None end). Definition mult_monomial_eff (m : seqmultinom) (c : T) (p : effmpoly T) : effmpoly T := M.fold (fun m' c' (*acc*) => M.add (mnm_add_seq m m') (c * c')%C (*acc*)) p M.empty. Definition mpoly_mul_eff (p q : effmpoly T) : effmpoly T := M.fold (fun m c => mpoly_add_eff (mult_monomial_eff m c q)) p mp0_eff. Definition mpoly_exp_eff (p : effmpoly T) (n : binnat.N) := N.iter n (mpoly_mul_eff p) mp1_eff. Definition comp_monomial_eff (m : seqmultinom) (c : T) (lq : seq (effmpoly T)) : effmpoly T := let mq := zipwith mpoly_exp_eff lq m in mpoly_scale_eff c (foldr mpoly_mul_eff mp1_eff mq). Definition comp_mpoly_eff (lq : seq (effmpoly T)) (p : effmpoly T) : effmpoly T := M.fold (fun m c => mpoly_add_eff (comp_monomial_eff m c lq)) p mp0_eff. End effmpoly_generic_2. Derive Inversion inv_InA with (forall (A : Type) (eqA : A -> A -> Prop) (x : A) (s : seq A), @InA A eqA x s) Sort Prop. (** ** Part 2: Proofs for proof-oriented types and programs *) Section effmpoly_theory. (** *** Data refinement for seqmultinom *) Definition multinom_of_seqmultinom n (m : seqmultinom) : option 'X_{1..n} := let m' := map spec_N m in if sumb (size m' == n) is left prf then Some (Multinom (@Tuple n nat m' prf)) else None. Definition multinom_of_seqmultinom_val n (m : seqmultinom) : 'X_{1..n} := odflt (@mnm0 n) (multinom_of_seqmultinom n m). Definition seqmultinom_of_multinom n (m : 'X_{1..n}) := let: Multinom m' := m in map implem_N (tval m'). Lemma implem_NK : cancel implem_N spec_N. Proof. move=> n; symmetry; apply refinesP. have{1}->: n = spec_id (implem_id n) by []. refines_apply. by rewrite refinesE. Qed. Lemma spec_NK : cancel spec_N implem_N. Proof. by move=> x; rewrite -[RHS](ssrnat.nat_of_binK x). Qed. Lemma seqmultinom_of_multinomK n : pcancel (@seqmultinom_of_multinom n) (@multinom_of_seqmultinom n). Proof. move=> x; rewrite /seqmultinom_of_multinom /multinom_of_seqmultinom. case: sumb => [prf|]. congr Some; apply: val_inj; simpl; apply: val_inj; simpl; case: (x). by move=> t; rewrite -map_comp (eq_map implem_NK) map_id. case: x => [t]. by rewrite size_tuple eqxx. Qed. (** Main refinement predicate for [multinom]s *) Definition Rseqmultinom {n} := ofun_hrel (@multinom_of_seqmultinom n). Lemma refine_size (n : nat) (m : 'X_{1..n}) (m' : seqmultinom) `{ref_mm' : !refines Rseqmultinom m m'} : size m' = n. Proof. move: ref_mm'. rewrite refinesE /Rseqmultinom /multinom_of_seqmultinom /ofun_hrel. case: sumb =>// prf _. rewrite size_map in prf. exact/eqP. Qed. Lemma refine_nth_def (n : nat) (m : 'X_{1..n}) (m' : seqmultinom) (i : 'I_n) x0 : refines Rseqmultinom m m' -> spec_N (nth x0 m' i) = m i. Proof. move=> rMN; move: (rMN). rewrite refinesE /Rseqmultinom /multinom_of_seqmultinom /ofun_hrel. case: sumb =>// prf [] <-. rewrite multinomE /= (tnth_nth (spec_N x0)) (nth_map x0) //. by move: prf; rewrite size_map; move/eqP ->. Qed. Lemma refine_nth (n : nat) (m : 'X_{1..n}) (m' : seqmultinom) (i : 'I_n) : refines Rseqmultinom m m' -> spec_N (nth 0%num m' i) = m i. Proof. exact: refine_nth_def. Qed. Lemma refine_seqmultinomP (n : nat) (m : 'X_{1..n}) (m' : seqmultinom) : size m' = n -> (forall i : 'I_n, spec_N (nth 0%num m' i) = m i) -> refines Rseqmultinom m m'. Proof. move=> eq_sz eq_nth. rewrite refinesE /Rseqmultinom /multinom_of_seqmultinom /ofun_hrel. case: sumb => [prf|]. congr Some; apply: val_inj; simpl. apply: eq_from_tnth => i. rewrite (tnth_nth 0%N) /= (nth_map 0%num) ?eq_nth //. by move: prf; rewrite size_map; move/eqP ->. by rewrite size_map eq_sz eqxx. Qed. Lemma refine_seqmultinom_of_multinom (n : nat) (m : 'X_{1..n}) : refines Rseqmultinom m (seqmultinom_of_multinom m). Proof. by rewrite refinesE /Rseqmultinom /ofun_hrel seqmultinom_of_multinomK. Qed. Lemma refine_multinom_of_seqmultinom_val (n : nat) (m : seqmultinom) : size m == n -> refines Rseqmultinom (multinom_of_seqmultinom_val n m) m. Proof. move=> Hsz. rewrite refinesE /Rseqmultinom /multinom_of_seqmultinom_val /ofun_hrel. case_eq (multinom_of_seqmultinom n m) => //. rewrite /multinom_of_seqmultinom; case sumb => //. by rewrite size_map Hsz. Qed. Lemma refine_mnm0 n : refines Rseqmultinom (@mnm0 n) (@mnm0_seq n). Proof. apply refine_seqmultinomP. by rewrite size_nseq. move=> i; rewrite nth_nseq if_same multinomE (tnth_nth 0%N) nth_map //=. by rewrite size_enum_ord. Qed. Lemma refine_mnmd {n1} : refines (Rord0 ==> Rnat ==> Rseqmultinom) (@mnmd n1) (@mnmd_seq n1). Proof. (* First, ensure that n1 > 0, else 'I_n1 would be empty *) case: n1 => [|n1]; first by rewrite refinesE => -[]. eapply refines_abstr => i i' ref_i. eapply refines_abstr => j j' ref_j. apply: refine_seqmultinomP. rewrite /mnmd_seq !(size_cat,size_nseq) /= -subnDA addnA addn1 subnKC //. by move: ref_i; rewrite refinesE /Rord0; move<-. move=> k. rewrite /mnmd_seq /mnmd multinomE (tnth_nth 0%N) /=. rewrite !(nth_cat,nth_nseq). rewrite (nth_map ord0); last by rewrite size_enum_ord. case: ifP. rewrite if_same size_nseq nth_enum_ord //. move=> Hic; rewrite ifF //. apply/negP; move/eqP => Keq. move/Rord0_eq in ref_i. by rewrite -ref_i -Keq ltnn in Hic. move/negbT; rewrite size_nseq -ltnNge ltnS => Hi. rewrite nth_enum_ord //. case: ifP. move/eqP <-; move/Rord0_eq: ref_i <-. rewrite subnn /=. have->: j = spec_id j by []. symmetry; eapply refinesP; refines_apply. move/negbT/eqP => Hneq. move/Rord0_eq in ref_i; rewrite -ref_i in Hi *. case: (ltnP i k) => Hci. by rewrite -(@prednK (k - i)) ?subn_gt0 //= nth_nseq if_same. by exfalso; apply/Hneq/anti_leq; rewrite Hi. Qed. #[export] Instance refine_mnm_add n : refines (Rseqmultinom ==> Rseqmultinom ==> Rseqmultinom) (@mnm_add n) mnm_add_seq. Proof. apply refines_abstr => mnm1 mnm1' ref_mnm1. apply refines_abstr => mnm2 mnm2' ref_mnm2. apply/refine_seqmultinomP. { rewrite /mnm_add_seq size_map size_zip. by rewrite (@refine_size _ mnm1) (@refine_size _ mnm2) minnn. } move=> i. rewrite /mnm_add_seq (nth_map (0%num, 0%num)); last first. { by rewrite size_zip (@refine_size _ mnm1) (@refine_size _ mnm2) minnn. } rewrite nth_zip /=; [|by rewrite (@refine_size _ mnm1) (@refine_size _ mnm2)]. rewrite mnmDE -!refine_nth. exact: nat_of_add_bin. Qed. #[export] Instance refine_mdeg n : refines (Rseqmultinom ==> eq) (@mdeg n) mdeg_eff. Proof. rewrite refinesE. elim n => [|n' Hn'] m m' rm; apply trivial_refines in rm. { by rewrite mdegE big_ord0 (size0nil (@refine_size _ _ _ rm)). } move: rm; case m'=> [|h t] rm; [by apply (@refine_size _ _ _) in rm|]. rewrite mdegE big_ord_recl /mdeg_eff /=. rewrite -(refine_nth _ rm) /spec_N /=. set s := bigop _ _ _; set p := add_op; set z := zero_op. suff ->: s = foldl p z t; rewrite {}/p {}/z. { set z := zero_op; generalize z. elim: t {rm z} h => [|h' t' IH] h z /=. { by rewrite /add_op /add_N N.add_comm nat_of_add_bin. } rewrite IH /add_op /add_N -!N.add_assoc; do 3 f_equal. by rewrite N.add_comm. } pose mt := [multinom m (fintype.lift ord0 i) | i < n']. suff ->: s = mdeg mt. { apply Hn', refinesP, refine_seqmultinomP. { suff: size (h :: t) = n'.+1; [by rewrite /= => H; injection H|]. by apply (@refine_size _ m _). } by move=> i; rewrite multinomE tnth_mktuple -(refine_nth _ rm). } rewrite /s mdegE /mt; apply eq_bigr=> i _. by rewrite multinomE tnth_mktuple. Qed. Lemma multinom_of_seqmultinom_inj n x y : size x = n -> size y = n -> multinom_of_seqmultinom n x = multinom_of_seqmultinom n y -> x = y. Proof. move=> Sx Sy; rewrite /multinom_of_seqmultinom. case (sumb _) => [prfx|] /=; [|by rewrite size_map Sx eqxx]. case (sumb _) => [prfy|] /=; [|by rewrite size_map Sy eqxx]. case; exact: map_spec_N_inj. Qed. Lemma multinom_of_seqmultinom_val_inj n x y : size x = n -> size y = n -> multinom_of_seqmultinom_val n x = multinom_of_seqmultinom_val n y -> x = y. Proof. move=> Sx Sy; rewrite /multinom_of_seqmultinom_val /multinom_of_seqmultinom. case (sumb _) => [prfx|] /=; [|by rewrite size_map Sx eqxx]. case (sumb _) => [prfy|] /=; [|by rewrite size_map Sy eqxx]. case; exact: map_spec_N_inj. Qed. Lemma Rseqmultinom_eq n (x : 'X_{1..n}) x' y y' : refines Rseqmultinom x x' -> refines Rseqmultinom y y' -> (x == y) = (x' == y'). Proof. move=> Hx Hy; apply/idP/idP => H. { have Sx' := @refine_size _ _ _ Hx. have Sy' := @refine_size _ _ _ Hy. apply/eqP. move: H Hy Hx; rewrite refinesE /Rseqmultinom /ofun_hrel; move/eqP=>-><-. by apply multinom_of_seqmultinom_inj. } apply/eqP; move: H Hx Hy. rewrite refinesE /Rseqmultinom /ofun_hrel; move/eqP=>->->. by move=> H; inversion H. Qed. #[export] Instance refine_mnmc_lt n : refines (Rseqmultinom ==> Rseqmultinom ==> eq) (@mnmc_lt n) (mnmc_lt_seq). Proof. rewrite refinesE=> m1 m1' rm1 m2 m2' rm2. apply trivial_refines in rm1; apply trivial_refines in rm2; rewrite /mnmc_lt. rewrite -ltEmnm. case: (boolP (m1 == m2)) => /= [E|]. { suff: mnmc_eq_seq m1' m2'. { move=> E'; symmetry. move: E => /eqP ->; rewrite Order.POrderTheory.ltxx. apply negbTE; apply /negP => K. by apply (E.lt_not_eq K). } by apply /mnmc_eq_seqP; rewrite -(Rseqmultinom_eq rm1 rm2). } move=> nE. rewrite /mnmc_lt_seq /Order.lt /=. rewrite mpoly.ltmc_def eq_sym nE /=. have rmdeg := refine_mdeg n; rewrite refinesE in rmdeg. rewrite /eq_op /eq_N /lt_op /lt_N. rewrite /mnmc_le. rewrite Order.SeqLexiOrder.Exports.lexi_cons. rewrite (rmdeg _ _ (refinesP rm1)) (rmdeg _ _ (refinesP rm2)) => {rmdeg}. rewrite /Order.le /=. rewrite (_ : Order.SeqLexiOrder.le _ _ = mnmc_lt_seq_aux m1' m2'). { rewrite leq_eqVlt. apply/idP/idP. { case eqP => /= He. { rewrite He leqnn /= => ->. apply /orP; right. rewrite andbC /=. move: He; rewrite -Nat2N.inj_iff !nat_of_binK => ->. by rewrite /is_true N.eqb_eq. } move=> /andP [Hlt _]. apply /orP; left. by rewrite /is_true N.ltb_lt; apply /Rnat_ltP. } move=> /orP [Hlt|/andP [Heaq ->]]. { apply /andP; split. { apply /orP; right. by move: Hlt; rewrite /is_true N.ltb_lt => /Rnat_ltP. } apply /implyP => Hle. exfalso; move: Hlt. rewrite /is_true N.ltb_lt => /Rnat_ltP. by rewrite /spec_N ltnNge Hle. } move: Heaq => /Neqb_ok => ->. by apply /andP; split; [rewrite eqxx|apply /implyP]. } elim: n m1 m1' rm1 m2 m2' rm2 nE => [|n IH] m1 m1' rm1 m2 m2' rm2 nE. { move: rm1=> /(@refine_size _) /size0nil ->. move: rm2=> /(@refine_size _) /size0nil -> /=. apply/negbTE/negP=> H; move: nE => /eqP; apply. by case m1, m2; rewrite tuple0; symmetry; rewrite tuple0. } case: m1' rm1 => [|h1 t1 rm1]; [by move/(@refine_size _)|]. case: m2' rm2 => [|h2 t2 rm2]; [by move/(@refine_size _)|]. move: nE; case: m1 rm1=> m1; case: m1 => m1; case: m1=> [//|h1' t1'] sm1 /= rm1. case: m2 rm2 => m2; case: m2 => m2; case: m2 => [//|h2' t2'] sm2 /= rm2 => nE. have st1 : size t1' == n; [by rewrite -eqSS|]. have st2 : size t2' == n; [by rewrite -eqSS|]. have Hh1 : nat_of_bin h1 = h1'. { by move: (refine_nth ord0 rm1); rewrite /spec_N => ->. } have rt1 : refines Rseqmultinom [multinom Tuple st1] t1. { apply refine_seqmultinomP. { by move: (@refine_size _ _ _ rm1)=> /= /eqP; rewrite eqSS=> /eqP. } move=> i; move: (refine_nth (fintype.lift ord0 i) rm1). by rewrite /= =>->; rewrite !multinomE !(tnth_nth 0%N) /=. } have Hh2 : nat_of_bin h2 = h2'. { by move: (refine_nth ord0 rm2); rewrite /spec_N => ->. } have rt2 : refines Rseqmultinom [multinom Tuple st2] t2. { apply refine_seqmultinomP. { by move: (@refine_size _ _ _ rm2)=> /= /eqP; rewrite eqSS=> /eqP. } move=> i; move: (refine_nth (fintype.lift ord0 i) rm2). by rewrite /= =>->; rewrite !multinomE !(tnth_nth 0%N) /=. } rewrite /Order.lt /= /eq_op /eq_N /lt_op /lt_N. move: (@refine_nth _ _ _ ord0 rm1) => /=. rewrite multinomE /spec_N (tnth_nth 0%N) /= => <-. move: (@refine_nth _ _ _ ord0 rm2) => /=. rewrite multinomE /spec_N (tnth_nth 0%N) /= => <-. rewrite /Order.le /=. apply/idP/idP. { rewrite leq_eqVlt. move=> /andP [/orP [Heq12|Hlt12] /implyP Himpl]. { move: Heq12 => /eqP; rewrite -Nat2N.inj_iff !nat_of_binK => Heq12. apply /orP; right. apply /andP; split. { rewrite Heq12; apply N.eqb_refl. } rewrite -(IH _ _ rt1 _ _ rt2). { by apply Himpl; rewrite Heq12. } apply /eqP => Hst12. move: nE => /eqP; apply. do 2 (apply val_inj => /=). apply f_equal2. { by rewrite -Hh1 Heq12. } by move: Hst12 => []. } apply /orP; left. by rewrite /is_true N.ltb_lt; apply /Rnat_ltP. } move=> /orP [Hlt12|/andP [Heq12 Hltseq]]; (apply /andP; split; [|apply /implyP => Hle21]). { apply ltnW. by move: Hlt12; rewrite /is_true N.ltb_lt => /Rnat_ltP. } { exfalso; move: Hle21. apply /negP; rewrite -ltnNge. by move: Hlt12; rewrite /is_true N.ltb_lt => /Rnat_ltP. } { by move: Heq12 => /Neqb_ok => ->. } rewrite (IH _ _ rt1 _ _ rt2) => [//|]. apply /negP => /eqP [Ht12']. move: nE => /negP; apply; apply /eqP. do 2 (apply val_inj => /=). apply f_equal2 => [|//]. by rewrite -Hh1 -Hh2; move: Heq12 => /Neqb_ok => ->. Qed. Definition mpoly_of_effmpoly (T : ringType) n (p' : effmpoly T) : option (mpoly n T) := if P.for_all (fun k _ => size k == n)%N p' then Some [mpoly [freeg [seq (a.2, multinom_of_seqmultinom_val n a.1) | a <- M.elements p']]] else None. Definition mpoly_of_effmpoly_val (T : ringType) n (p' : effmpoly T) : mpoly n T := odflt 0 (mpoly_of_effmpoly n p'). (** Main refinement predicate for multivariate polynomials *) Definition Reffmpoly `{T : ringType, n : nat} := ofun_hrel (@mpoly_of_effmpoly T n). Lemma eq_key_elt_eq T x y : (M.eq_key_elt (elt:=T)) x y <-> x = y. Proof. split. { move=> [H1 H2]. rewrite (surjective_pairing x) (surjective_pairing y); f_equal=> //. by apply/eqP/mnmc_eq_seqP. } move=> ->; split=> //; apply E.eq_refl. Qed. Lemma in_InA_eq_key_elt_iff (T : eqType) x s : x \in s <-> InA (M.eq_key_elt (elt:=T)) x s. Proof. split. { elim s => // h t Hind; rewrite inE; move/orP => [Hh|Ht]. { by move: Hh => /eqP ->; apply InA_cons_hd; split; [apply E.eq_refl|]. } by apply InA_cons_tl, Hind. } elim s => [|h t Hind]; [by rewrite InA_nil|]. rewrite InA_cons; elim. { by move/eq_key_elt_eq=>->; rewrite inE eqxx. } by move/Hind; rewrite inE orb_comm=>->. Qed. Lemma in_fst_InA_eq_key_iff (T : Type) x s : x.1 \in [seq x.1 | x <- s] <-> InA (M.eq_key (elt:=T)) x s. Proof. split. { elim s => // h t Hind; rewrite inE; move/orP => [Hh|Ht]. { apply InA_cons_hd; change (M.eq_key _ _) with (E.eq x.1 h.1). move: Hh => /eqP ->; apply E.eq_refl. } by apply InA_cons_tl, Hind. } elim s => [|h t Hind]; [by rewrite InA_nil|]. rewrite InA_cons; elim. { change (M.eq_key _ _) with (E.eq x.1 h.1). by move/mnmc_eq_seqP/eqP =>->; rewrite inE eqxx. } by rewrite inE orb_comm; move/Hind =>->. Qed. Lemma NoDupA_eq_key_uniq_fst elt s : NoDupA (M.eq_key (elt:=elt)) s -> uniq [seq i.1 | i <- s]. Proof. elim s => // h t Hind Hnd /=. inversion Hnd as [x|h' t' H1 H2]. apply/andP; split; [|by apply Hind]. by apply/negP => Hin; apply H1, in_fst_InA_eq_key_iff. Qed. Lemma refine_size_mpoly (n : nat) T (p : mpoly n T) (p' : effmpoly T) `{ref_pp' : !refines Reffmpoly p p'} : forall m, M.In m p' -> size m == n. Proof. move: ref_pp'. rewrite refinesE /Reffmpoly /mpoly_of_effmpoly /ofun_hrel. set t := P.for_all _ _; case_eq t => //. rewrite /t (P.for_all_iff _); [|by move=> m _ /mnmc_eq_seqP /eqP <-]. by move=> H _ m [e Hme]; apply (H m e). Qed. Lemma refine_find_mpoly (n : nat) T (p : mpoly n T) (p' : effmpoly T) : refines Reffmpoly p p' -> forall m m', refines Rseqmultinom m m' -> p@_m = odflt 0 (M.find m' p'). Proof. rewrite !refinesE /Reffmpoly /mpoly_of_effmpoly /ofun_hrel. set t := P.for_all _ _; case_eq t => //. rewrite /t (P.for_all_iff _); [|by move=> m _ /mnmc_eq_seqP /eqP <-]. move=> H_sz H; injection H; move=> {}H m m' Hm'. rewrite -H mcoeff_MPoly coeff_Freeg. case_eq (M.find m' p') => [c|] Hc. { change c with ((c, m).1); change m with ((c, m).2). apply precoeff_mem_uniqE. { rewrite /predom -map_comp. rewrite (@eq_map _ _ _ ((multinom_of_seqmultinom_val n) \o fst)) //. rewrite map_comp map_inj_in_uniq. { apply NoDupA_eq_key_uniq_fst, M.elements_3w. } move=> x y Hx Hy; apply multinom_of_seqmultinom_val_inj. { move: Hx; move/mapP => [xe Hxe ->]. apply/eqP /(H_sz _ xe.2) /M.elements_2. by apply in_InA_eq_key_elt_iff; rewrite -surjective_pairing. } move: Hy; move/mapP => [ye Hye ->]. apply/eqP /(H_sz _ ye.2) /M.elements_2. by apply in_InA_eq_key_elt_iff; rewrite -surjective_pairing. } apply M.find_2, M.elements_1, in_InA_eq_key_elt_iff in Hc. apply/mapP; exists (m', c) => //=; f_equal. move: Hm'; rewrite /Rseqmultinom /ofun_hrel /multinom_of_seqmultinom_val. by case (multinom_of_seqmultinom n m') => // m'' Hm''; injection Hm''. } apply precoeff_outdom. rewrite /predom -map_comp. rewrite (@eq_map _ _ _ ((multinom_of_seqmultinom_val n) \o fst)) //. apply/negP=> Hm; apply F.not_find_in_iff in Hc; apply Hc. move/mapP in Hm; destruct Hm as [xe Hxe Hm]. rewrite F.elements_in_iff; exists xe.2. rewrite -in_InA_eq_key_elt_iff. suff: m' = xe.1; [by move=> ->; rewrite -surjective_pairing|]. move: Hm' Hm; rewrite /Rseqmultinom /ofun_hrel /multinom_of_seqmultinom_val /=. rewrite /multinom_of_seqmultinom /seqmultinom_of_multinom. case (sumb _) => [prf|] //= Hm; injection Hm; move=> <- {Hm}. case (sumb _) => [prf'|] //=. by move=> H'; inversion H'; apply: map_spec_N_inj. rewrite size_map => Hf _. rewrite size_map in prf. rewrite (H_sz xe.1 xe.2) in Hf => //; apply M.elements_2. by rewrite -in_InA_eq_key_elt_iff -surjective_pairing. Qed. Lemma refine_effmpolyP (n : nat) T (p : mpoly n T) (p' : effmpoly T) : (forall m, M.In m p' -> size m == n)%N -> (forall m m', refines Rseqmultinom m m' -> p@_m = odflt 0 (M.find m' p')) -> refines Reffmpoly p p'. Proof. move=> eq_sz eq_monom. assert (Hsz : P.for_all (fun (k : M.key) (_ : T) => size k == n) p'). { rewrite /is_true (P.for_all_iff _) => k e Hke. { by apply eq_sz; exists e. } by move=> _ _ _; move: Hke; move/mnmc_eq_seqP/eqP ->. } rewrite refinesE /Reffmpoly /mpoly_of_effmpoly /ofun_hrel ifT //; f_equal. apply mpolyP => m. pose m' := seqmultinom_of_multinom m. have Hm' : refines Rseqmultinom m m'. by rewrite refinesE; apply seqmultinom_of_multinomK. rewrite (eq_monom _ _ Hm') mcoeff_MPoly coeff_Freeg. case_eq (M.find m' p') => [c|] Hc. { change c with ((c, m).1); change m with ((c, m).2). apply precoeff_mem_uniqE. { rewrite /predom -map_comp. rewrite (@eq_map _ _ _ ((multinom_of_seqmultinom_val n) \o fst)) //. rewrite map_comp map_inj_in_uniq. { apply NoDupA_eq_key_uniq_fst, M.elements_3w. } move=> x y Hx Hy; apply multinom_of_seqmultinom_val_inj. { move: Hx; move/mapP => [xe Hxe ->]. apply/eqP /eq_sz; exists xe.2; apply/(M.elements_2 (e:=xe.2)). by apply in_InA_eq_key_elt_iff; rewrite -surjective_pairing. } move: Hy; move/mapP => [ye Hye ->]. apply/eqP /eq_sz; exists ye.2; apply/(M.elements_2 (e:=ye.2)). by apply in_InA_eq_key_elt_iff; rewrite -surjective_pairing. } apply M.find_2, M.elements_1, in_InA_eq_key_elt_iff in Hc. apply/mapP; exists (m', c) => //=; f_equal. by rewrite /m' /multinom_of_seqmultinom_val seqmultinom_of_multinomK. } apply precoeff_outdom. rewrite /predom -map_comp. rewrite (@eq_map _ _ _ ((multinom_of_seqmultinom_val n) \o fst)) //. apply/negP=> Hm; apply F.not_find_in_iff in Hc; apply Hc. move/mapP in Hm; destruct Hm as [xe Hxe Hm]. rewrite F.elements_in_iff; exists xe.2. rewrite -in_InA_eq_key_elt_iff /m' Hm /= /multinom_of_seqmultinom_val. rewrite /multinom_of_seqmultinom /seqmultinom_of_multinom. case (sumb _) => [prf|] /=. rewrite -map_comp (eq_map spec_NK) map_id -surjective_pairing //. rewrite size_map (@eq_sz xe.1); [by []|exists xe.2]. by apply /M.elements_2 /in_InA_eq_key_elt_iff; rewrite -surjective_pairing. Qed. (** *** Data refinement for effmpoly *) Context {T : ringType}. Instance : zero_of T := 0. Instance : one_of T := 1. Instance : add_of T := +%R. Instance : opp_of T := -%R. #[export] Instance sub_instR : sub_of T := fun x y => (x - y). Instance mul_instR : mul_of T := *%R. Instance : eq_of T := fun x y => x == y. Lemma refine_seq_multinom_coeff n (s : seq ('X_{1..n} * T)) s' : all (fun mc => size mc.1 == n) s' -> s = [seq (multinom_of_seqmultinom_val n mc.1, mc.2) |mc <- s'] -> refines (list_R (prod_R Rseqmultinom eq)) s s'. Proof. rewrite refinesE. elim: s' s=> [|h' t' IH]; case=> [//|h t] //=. case/andP => Hsh Hst [Hh Ht]; constructor. { apply/prod_RI; rewrite Hh; split=>//. by apply refinesP; eapply refine_multinom_of_seqmultinom_val. } by apply IH. Qed. Lemma in_InA_iff mc l : mc \in l <-> InA (M.eq_key_elt (elt:=T)) mc l. Proof. elim l=> [|h t IH]; [by split=>// H; inversion H|]. rewrite in_cons; split. { move=>/orP []; [by move/eqP->; left; rewrite eq_key_elt_eq|]. by move=> Hmc; right; apply IH. } move=> H; inversion H as [mc' l' Hmc [Hmc' Hl']|mc' l' Hmc [Hmc' Hl']]. { by apply/orP; left; apply/eqP; apply eq_key_elt_eq. } by apply/orP; right; rewrite IH. Qed. Lemma uniq_map_filter (T' T'' : eqType) (s : seq T') C (E : T' -> T'') : uniq [seq E i | i <- s] -> uniq [seq E i | i <- s & C i]. Proof. elim s=> [//|h t IH] /= /andP [] Hh Ht. case (C h)=>/=; [|by apply IH]; apply/andP; split; [|by apply IH]. apply/negP=>H; move/negP in Hh; apply Hh; apply/mapP. move: H; move/mapP=> [] x Hx Hx'; exists x=>//; move: Hx. by rewrite mem_filter=>/andP []. Qed. #[export] Instance refine_list_of_mpoly_eff n : refines (Reffmpoly ==> list_R (prod_R Rseqmultinom eq)) (@list_of_mpoly T n) list_of_mpoly_eff. Proof. apply refines_abstr => p p' rp. rewrite /list_of_mpoly_eff. have Hs : all (fun mc : seq binnat.N * T => size mc.1 == n) [seq mc <- M.elements p' | ~~ (mc.2 == 0)%C]. { apply/allP=> mc; rewrite mem_filter; move/andP=> [] _ Hmc. apply (refine_size_mpoly (ref_pp' := rp)). rewrite F.elements_in_iff; exists mc.2. by rewrite -in_InA_iff -surjective_pairing. } apply refine_seq_multinom_coeff=> //; rewrite /list_of_mpoly. suff : path.sort mnmc_le (msupp p) = [seq multinom_of_seqmultinom_val n mc.1 | mc <- M.elements p' & ~~ (mc.2 == 0)]. { set l := path.sort _ _; set l' := filter _ _. move=> H; apply (eq_from_nth (x0:=(0%MM, 0))). { by rewrite size_map H !size_map. } move=> i; rewrite size_map=> Hi. have Hi' : i < size l'; [by move: Hi; rewrite H size_map|]. rewrite (nth_map 0%MM) // H !(nth_map (@mnm0_seq n, 0)) //; f_equal. set mc := nth _ _ _. erewrite (refine_find_mpoly (p' := p') (m':=mc.1) rp). (* erewrite?! *) { rewrite (M.find_1 (e:=mc.2)) // F.elements_mapsto_iff -in_InA_iff. rewrite -surjective_pairing. suff: mc \in l'; [by rewrite mem_filter=>/andP []|by apply mem_nth]. } apply refine_multinom_of_seqmultinom_val; move: Hs; move/allP; apply. rewrite -/l' /mc; apply (mem_nth (mnm0_seq, 0) Hi'). } apply: (path.sorted_eq mpoly.lemc_trans mpoly.lemc_anti). { apply path.sort_sorted, lemc_total. } { have Se := M.elements_3 p'. pose lef := fun x y : _ * T => mnmc_lt_seq x.1 y.1. pose l := [seq mc <- M.elements p' | mc.2 != 0]; rewrite -/l. have : path.sorted lef l. { apply path.sorted_filter; [by move=> x y z; apply E.lt_trans|]. clear l; move: Se; set l := _ p'; elim l=> [//|h t IH]. move=> H; inversion H as [|h' t' Ht Hht [Hh' Ht']]; move {H h' t' Hh' Ht'}. rewrite /path.sorted; case_eq t=>[//|h' t'] Ht' /=; apply /andP; split. { by rewrite Ht' in Hht; inversion Hht. } by rewrite -/(path.sorted _ (h' :: t')) -Ht'; apply IH. } case_eq l=> [//|h t Hl] /= /(path.pathP (@mnm0_seq n, 0)) H. apply/(path.pathP 0%MM)=> i; rewrite size_map=> Hi. rewrite /mnmc_le -leEmnm Order.POrderTheory.le_eqVlt; apply/orP; right. rewrite (nth_map (@mnm0_seq n, 0)) //; move/allP in Hs. move: (H _ Hi); rewrite /lef/is_true=><-; apply refinesP. eapply refines_apply; [eapply refines_apply; [by apply refine_mnmc_lt|]|]. { case: i Hi=> /= [|i'] Hi; [|apply ltnW in Hi]. { apply refine_multinom_of_seqmultinom_val, Hs. by rewrite -/l Hl in_cons eqxx. } rewrite (nth_map (@mnm0_seq n, 0)) //. apply refine_multinom_of_seqmultinom_val, Hs. by rewrite -/l Hl in_cons; apply/orP; right; rewrite mem_nth. } apply refine_multinom_of_seqmultinom_val, Hs. by rewrite -/l Hl in_cons; apply/orP; right; rewrite mem_nth. } apply uniq_perm. { rewrite path.sort_uniq; apply msupp_uniq. } { change (fun _ => multinom_of_seqmultinom_val _ _) with ((fun m => multinom_of_seqmultinom_val n m) \o (fst (B:=T))). rewrite map_comp map_inj_in_uniq. { apply (@uniq_map_filter _ _ (M.elements p')). apply NoDupA_eq_key_uniq_fst, M.elements_3w. } move=> m m' Hm Hm'; apply multinom_of_seqmultinom_val_inj. { by move/allP in Hs; move: Hm=>/mapP [x Hx] ->; apply/eqP /Hs. } by move/allP in Hs; move: Hm'=>/mapP [x Hx] ->; apply/eqP /Hs. } move=> m; rewrite path.mem_sort; apply/idP/idP. { pose m' := seqmultinom_of_multinom m. rewrite mcoeff_msupp=>Hin; apply/mapP; exists (m', p@_m). { rewrite mem_filter /= Hin /= in_InA_iff; apply M.elements_1, M.find_2. move: Hin; erewrite (@refine_find_mpoly _ _ _ _ rp _ m'). { by case (M.find _ _)=>//; rewrite eqxx. } apply refine_seqmultinom_of_multinom. } by rewrite /= /m' /multinom_of_seqmultinom_val seqmultinom_of_multinomK. } move/mapP=> [] mc; rewrite mem_filter=>/andP [] Hmc2; rewrite in_InA_iff. rewrite {1}(surjective_pairing mc) -F.elements_mapsto_iff. rewrite F.find_mapsto_iff mcoeff_msupp=> Hmc1 ->. erewrite (@refine_find_mpoly _ _ _ _ rp _ mc.1); [by rewrite Hmc1|]. apply refine_multinom_of_seqmultinom_val; move/allP in Hs; apply Hs. rewrite mem_filter Hmc2 /= in_InA_iff (surjective_pairing mc). by rewrite -F.elements_mapsto_iff; apply M.find_2. Qed. #[export] Instance refine_mp0_eff n : refines (@Reffmpoly T n) 0 mp0_eff. Proof. apply: refine_effmpolyP. - by move=> m /F.empty_in_iff Hm. - by move=> m m' ref_m; rewrite F.empty_o mcoeff0. Qed. #[export] Instance refine_mp1_eff n : refines (@Reffmpoly T n) 1 (mp1_eff (n := n)). Proof. apply refine_effmpolyP. - rewrite /mp1_eff => k /singleton_in_iff/mnmc_eq_seqP/eqP <-. by rewrite size_nseq. - move=> m m' Hm; rewrite mcoeff1 F.add_o. have H0 := refine_mnm0 n. rewrite (Rseqmultinom_eq Hm H0). case: E.eq_dec => [EQ|nEQ]. + by move/mnmc_eq_seqP/eqP: EQ <-; rewrite eqxx. + rewrite eq_sym; move/mnmc_eq_seqP/negbTE: nEQ ->. by rewrite F.empty_o. Qed. #[export] Instance refine_mpvar_eff {n1} : refines (eq ==> Rnat ==> Rord0 ==> Reffmpoly (T := T) (n := n1)) mpvar (mpvar_eff (n := n1)). Proof. case: n1 => [|n1]. by rewrite refinesE; move=> p p' Hp q q' Hq [] i' Hi. apply refines_abstr => c c' ref_c; apply refines_abstr => d d' ref_d. apply refines_abstr => i i' ref_i. assert (Hmnmd : refines Rseqmultinom (mnmd i d) (@mnmd_seq n1.+1 i' d')). { eapply refines_apply; first eapply refines_apply; first eapply refine_mnmd; by tc. } apply refine_effmpolyP. { move=> m [e Hme]; move: Hme; rewrite /mpvar_eff. move/(@singleton_mapsto T)=> [-> _]. by apply/eqP; apply (@refine_size _ (mnmd i d)). } move=> m m' Hm; rewrite mcoeffZ mcoeffX. rewrite (Rseqmultinom_eq Hmnmd Hm) eq_sym. case_eq (m' == (@mnmd_seq n1.+1 i' d')). { move/eqP => Hm'; rewrite Hm'. rewrite F.add_eq_o; last exact: E.eq_refl. by rewrite /= mulr1 (refines_eq ref_c). } move=> Hm'; rewrite F.add_neq_o /=. { by rewrite mulr0; rewrite F.empty_o. } by apply/mnmc_eq_seqP; rewrite eq_sym Hm'. Qed. Arguments mpolyC {n R} c. #[export] Instance refine_mpolyC_eff n : refines (eq ==> Reffmpoly (T := T) (n := n)) mpolyC (mpolyC_eff (n := n)). Proof. apply refines_abstr => c c' ref_c. rewrite !refinesE in ref_c; rewrite -{}ref_c {c'}. apply refine_effmpolyP. { move=> m [e Hme]; move: Hme; rewrite /mpvar_eff. by move/(@singleton_mapsto T)=> [-> _]; rewrite size_nseq eqxx. } move=> m m' Hm; rewrite mcoeffC. have Hm0 := @refine_mnm0 n. rewrite (Rseqmultinom_eq Hm Hm0). case_eq (m' == @mnm0_seq n). { move/eqP => Hm'; rewrite Hm'. by rewrite F.add_eq_o; [rewrite mulr1|apply E.eq_refl]. } move=> Hm'; rewrite F.add_neq_o /=. { by rewrite mulr0; rewrite F.empty_o. } by apply/mnmc_eq_seqP; move: Hm'; rewrite eq_sym =>->. Qed. Arguments mpolyX {n R} m. #[export] Instance refine_mpolyX_eff n : refines (Rseqmultinom ==> Reffmpoly (T := T) (n := n)) mpolyX mpolyX_eff. Proof. apply refines_abstr => m m' ref_m. apply refine_effmpolyP. { move=> m'' [e Hme]; move: Hme; rewrite /mpolyX_eff. move/(@singleton_mapsto T)=> [-> _]. by apply/eqP; apply (@refine_size _ m). } move=> m'' m''' Hm; rewrite mcoeffX. rewrite (Rseqmultinom_eq ref_m Hm) eq_sym. case_eq (m''' == m'). { move/eqP => Hm'; rewrite Hm'. by rewrite F.add_eq_o /=; [|by apply E.eq_refl]. } move=> Hm'; rewrite F.add_neq_o //=. { by rewrite F.empty_o. } by apply/mnmc_eq_seqP; rewrite eq_sym Hm'. Qed. Lemma MapsTo_mcoeff {n} m m' p p' a : refines (Reffmpoly (T := T) (n := n)) p p' -> refines Rseqmultinom m m' -> M.MapsTo m' a p' -> p@_m = a. (** the converse may be wrong if [a = 0] *) Proof. move=> Hp Hm HMT; move/F.find_mapsto_iff in HMT. by rewrite (refine_find_mpoly Hp Hm) /odflt /oapp HMT. Qed. Lemma not_In_mcoeff {n} m m' p p' : refines (Reffmpoly (T := T) (n := n)) p p' -> refines Rseqmultinom m m' -> ~ M.In m' p' -> p@_m = 0. Proof. move=> Hp Hm Hin; rewrite (refine_find_mpoly Hp Hm). by move/F.not_find_in_iff: Hin ->. Qed. Arguments mpoly_scale {n R} c p. #[export] Instance refine_mpoly_scale_eff n : refines (eq ==> Reffmpoly ==> Reffmpoly (T := T) (n := n)) mpoly_scale mpoly_scale_eff. Proof. apply refines_abstr => c c' ref_c. apply refines_abstr => p p' ref_p. rewrite /mpoly_scale_eff; apply: refine_effmpolyP. { move=> m /M.map_2 Hm; exact: refine_size_mpoly ref_p _ _. } move=> m m' ref_m; rewrite mcoeffZ. case Es: (M.find _ _) => [s|] /=. { have /F.find_mapsto_iff/F.map_mapsto_iff [a [-> Ha2 /=]] := Es. rewrite (refines_eq ref_c). congr *%R. apply: MapsTo_mcoeff ref_p ref_m Ha2. } move/F.not_find_in_iff in Es. suff->: p@_m = 0 by rewrite mulr0. apply: not_In_mcoeff ref_p ref_m _. move=> K; apply: Es. exact/F.map_in_iff. Qed. Arguments mpoly_add {n R} p q. #[export] Instance refine_mpoly_add_eff n : refines (Reffmpoly ==> Reffmpoly ==> Reffmpoly (T := T) (n := n)) mpoly_add mpoly_add_eff. Proof. apply refines_abstr => p p' ref_p. apply refines_abstr => q q' ref_q. rewrite /mpoly_add_eff. apply: refine_effmpolyP. { move=> m /F.in_find_iff Hm. have [Hip'|Hiq'] : M.In m p' \/ M.In m q'. rewrite !F.in_find_iff. rewrite F.map2_1bis // in Hm. case: M.find Hm; case: M.find; try by[left|left|right|]. apply (@refine_size_mpoly _ _ _ _ ref_p _ Hip'). apply (@refine_size_mpoly _ _ _ _ ref_q _ Hiq'). } move=> m m' Hm. rewrite mcoeffD F.map2_1bis //. case Ep: M.find => [cp|]; case Eq: M.find => [cq|] /=. - move/F.find_mapsto_iff in Ep; move/F.find_mapsto_iff in Eq; by rewrite (MapsTo_mcoeff ref_p Hm Ep) (MapsTo_mcoeff ref_q Hm Eq). - move/F.find_mapsto_iff in Ep; move/F.not_find_in_iff in Eq; by rewrite (MapsTo_mcoeff ref_p Hm Ep) (not_In_mcoeff ref_q Hm Eq) addr0. - move/F.not_find_in_iff in Ep; move/F.find_mapsto_iff in Eq; by rewrite (not_In_mcoeff ref_p Hm Ep) (MapsTo_mcoeff ref_q Hm Eq) add0r. - move/F.not_find_in_iff in Ep; move/F.not_find_in_iff in Eq; by rewrite (not_In_mcoeff ref_p Hm Ep) (not_In_mcoeff ref_q Hm Eq) addr0. Qed. Definition mpoly_sub {n} (p : {mpoly T[n]}) q := mpoly_add p (mpoly_opp q). #[export] Instance refine_mpoly_sub_eff n : refines (Reffmpoly ==> Reffmpoly ==> Reffmpoly (T := T) (n := n)) mpoly_sub mpoly_sub_eff. apply refines_abstr => p p' ref_p. apply refines_abstr => q q' ref_q. rewrite /mpoly_add_eff. apply: refine_effmpolyP. { move=> m /F.in_find_iff Hm. have [Hip'|Hiq'] : M.In m p' \/ M.In m q'. rewrite !F.in_find_iff. rewrite F.map2_1bis // in Hm. case: M.find Hm; case: M.find; try by[left|left|right|]. apply (@refine_size_mpoly _ _ _ _ ref_p _ Hip'). apply (@refine_size_mpoly _ _ _ _ ref_q _ Hiq'). } move=> m m' Hm. rewrite mcoeffB F.map2_1bis //. case Ep: M.find => [cp|]; case Eq: M.find => [cq|] /=. - move/F.find_mapsto_iff in Ep; move/F.find_mapsto_iff in Eq; by rewrite (MapsTo_mcoeff ref_p Hm Ep) (MapsTo_mcoeff ref_q Hm Eq). - move/F.find_mapsto_iff in Ep; move/F.not_find_in_iff in Eq; by rewrite (MapsTo_mcoeff ref_p Hm Ep) (not_In_mcoeff ref_q Hm Eq) subr0. - move/F.not_find_in_iff in Ep; move/F.find_mapsto_iff in Eq; by rewrite (not_In_mcoeff ref_p Hm Ep) (MapsTo_mcoeff ref_q Hm Eq) sub0r. - move/F.not_find_in_iff in Ep; move/F.not_find_in_iff in Eq; by rewrite (not_In_mcoeff ref_p Hm Ep) (not_In_mcoeff ref_q Hm Eq) subr0. Qed. Lemma rem_mpoly_eff n (q p' : effmpoly T) (k' : seqmultinom) (e : T) (p : mpoly n T) (k : 'X_{1..n}) : ~ M.In k' q -> P.Add k' e q p' -> refines Reffmpoly p p' -> refines Rseqmultinom k k' -> refines Reffmpoly (p - p@_k *: 'X_[k]) q. Proof. move=> Hin Hadd Hp Hk. apply refine_effmpolyP. { move=> m'' [c' Hc']; move: (Hadd m''); rewrite F.add_o. case E.eq_dec. { move/mnmc_eq_seqP/eqP <-; rewrite -F.find_mapsto_iff => Hm. by apply (@refine_size_mpoly _ _ _ _ (Hp)); exists e. } rewrite (proj1 (F.find_mapsto_iff q m'' c')) // => _ H. apply (@refine_size_mpoly _ _ _ _ (Hp)). by exists c'; move: H; rewrite -F.find_mapsto_iff. } move=> mm mm' ref_mm; move: (Hadd mm'); rewrite F.add_o. rewrite mcoeffB mcoeffZ mcoeffX. case E.eq_dec. { move/mnmc_eq_seqP/eqP => Hmm'; rewrite -Hmm'. have Hmm : k = mm. { by apply/eqP; rewrite (Rseqmultinom_eq Hk ref_mm); apply/eqP. } rewrite (proj1 (F.not_find_in_iff _ _) Hin) -Hmm eqxx mulr1. by rewrite (refine_find_mpoly Hp Hk) => ->; rewrite subrr. } move=> Hmm' <-. have Hmm : ~ k = mm. { move=> Hmmm; apply/Hmm'/mnmc_eq_seqP. by rewrite -(Rseqmultinom_eq Hk ref_mm); apply/eqP. } rewrite (refine_find_mpoly Hp ref_mm). by have ->: (k == mm = false); [apply/eqP|rewrite mulr0 subr0]. Qed. Lemma refine_mpoly_sum_eff n k f f' (p : mpoly k T) p' : (forall m, f m 0 = 0) -> refines (Rseqmultinom ==> eq ==> Reffmpoly (T:=T) (n:=n)) f f' -> refines Reffmpoly p p' -> refines Reffmpoly (\sum_(m <- msupp p) f m p@_m) (M.fold (fun m c => mpoly_add_eff (f' m c)) p' mp0_eff). Proof. move=> Hf ref_f; move: p. apply P.fold_rec. { move=> q' Eq' q Hq. suff -> : q = 0; [by rewrite msupp0 big_nil; apply refine_mp0_eff|]. apply /mpolyP => m. rewrite (refine_find_mpoly Hq (refine_seqmultinom_of_multinom m)). rewrite mcoeff0; case_eq (M.find (seqmultinom_of_multinom m) q') => [s|->]//. rewrite -F.find_mapsto_iff F.elements_mapsto_iff. by rewrite -in_InA_eq_key_elt_iff (proj1 (P.elements_Empty _ ) Eq'). } move=> m' c p'' q q' Hp'' Hq Hq' IH p Hp. pose m := multinom_of_seqmultinom_val k m'; pose cm := c *: 'X_[m]. have ref_m : refines Rseqmultinom m m'. { apply refine_multinom_of_seqmultinom_val. move: (Hq' m'); rewrite F.add_eq_o; [|by apply/mnmc_eq_seqP]; move=> Hm'. apply (@refine_size_mpoly _ _ _ _ Hp). by exists c; apply M.find_2. } have Hc : p@_m = c. { rewrite (refine_find_mpoly Hp ref_m) (Hq' m') F.add_eq_o //. apply E.eq_refl. } pose pmcm := p - cm. have Hpmcm : pmcm@_m = 0. { by rewrite mcoeffB mcoeffZ mcoeffX eqxx Hc mulr1 subrr. } have -> : \sum_(m <- msupp p) f m p@_m = f m c + \sum_(m <- msupp pmcm) f m pmcm@_m. { case_eq (m \in msupp p) => Hmsuppp. { rewrite (big_rem _ Hmsuppp) /= Hc; f_equal. rewrite /pmcm /cm -Hc -(perm_big _ (msupp_rem p m)) /=. apply eq_big_seq => i. rewrite mcoeffB mcoeffZ mcoeffX. rewrite mcoeff_msupp Hc -/cm -/pmcm -Hpmcm. case (@eqP _ m i) => [->|]; [by rewrite eqxx|]. by rewrite mulr0 subr0. } move: Hmsuppp; rewrite /pmcm /cm mcoeff_msupp Hc; move/eqP ->. by rewrite Hf add0r scale0r subr0. } eapply refines_apply. { eapply refines_apply; [by apply refine_mpoly_add_eff|]. apply: (@refines_apply _ _ eq). exact: trivial_refines. } apply IH. rewrite /pmcm /cm -Hc. apply (rem_mpoly_eff Hq Hq' Hp ref_m). Qed. Lemma RseqmultinomE {n} m m' : refines (Rseqmultinom (n := n)) m m' <=> m = map spec_N m' :> seq nat. Proof. split => Hmain. { apply eq_from_nth with (x0 := O). { by rewrite size_map size_tuple (@refine_size _ m). } move=> i Hi. rewrite size_tuple in Hi. case: n m Hmain Hi => // n m Hmain Hi. rewrite -(inordK Hi) (nth_map 0%num); last by rewrite (@refine_size _ m). by rewrite (@refine_nth _ m) -tnth_nth. } have Hsz : size m' = size m by rewrite Hmain size_map. apply: refine_seqmultinomP. { by rewrite Hsz size_tuple. } case: n m Hmain Hsz => [|n] m Hmain Hsz; first by case. by move=> i; rewrite (mnm_nth O) Hmain (nth_map 0%num 0%N) // Hsz size_tuple. Qed. Lemma refine_Madd_mnm_add {n} (m : 'X_{1.. n}) m' (c : T) p p' : refines Rseqmultinom m m' -> refines Reffmpoly p p' -> m \notin msupp p -> refines Reffmpoly (+%R (c *: 'X_[m]) p) (M.add m' c p'). Proof. move=> Hm Hp Hnotin. apply: refine_effmpolyP. { move=> k /F.add_in_iff [Hk|Hk]. - move/mnmc_eq_seqP/eqP: Hk <-. apply RseqmultinomE in Hm. by rewrite -(size_map spec_N m') -Hm size_tuple. - by apply (@refine_size_mpoly _ _ _ _ Hp). } move=> l l' Hl; rewrite mcoeffD mcoeffZ mcoeffX. case: (boolP (m == l)) => Heq /=. { rewrite mulr1. rewrite F.add_eq_o /=; last first. { apply/mnmc_eq_seqP. apply RseqmultinomE in Hm. apply RseqmultinomE in Hl. move/eqP/(congr1 (@tval n nat \o val)) in Heq. rewrite /= Hm Hl in Heq. exact/eqP/map_spec_N_inj. } move/eqP in Heq; rewrite Heq in Hnotin. by rewrite memN_msupp_eq0 // addr0. } rewrite mulr0 add0r. rewrite F.add_neq_o /=; last first. { apply/mnmc_eq_seqP. apply/negbT; rewrite -(@Rseqmultinom_eq _ _ _ _ _ Hm Hl). by move/negbTE: Heq ->. } rewrite refinesE in Hp. exact: refine_find_mpoly. Qed. Lemma refine_size_add n (k' : seqmultinom) (e : T) (p : mpoly n T) (p' : effmpoly T) (q : effmpoly T) : P.Add k' e q p' -> refines Reffmpoly p p' -> refines Rseqmultinom (multinom_of_seqmultinom_val n k') k'. Proof. move=> Hadd Hp. apply refine_multinom_of_seqmultinom_val. apply (@refine_size_mpoly _ _ _ _ Hp). exists e; move: (Hadd k'); rewrite F.add_eq_o; [|by apply E.eq_refl]. apply M.find_2. Qed. Lemma refine_Madd_mnm_add_sum n m m' c (p : mpoly n T) p' : refines Rseqmultinom m m' -> refines (Reffmpoly (T := T) (n := n)) p p' -> refines Reffmpoly (\sum_(i2 <- msupp p) (c * p@_i2) *: 'X_[m + i2]) (M.fold (fun (l' : M.key) (c' : T) => M.add (mnm_add_seq m' l') (c * c')%C) p' M.empty). Proof. move=> ref_m; move: p. apply P.fold_rec. { move=> q' Eq' q Hq. match goal with | [ |- refines Reffmpoly ?pol M.empty ] => suff ->: pol = 0 end. { by apply refine_mp0_eff. } apply /mpolyP => l. rewrite big1 ?mcoeff0 //. move=> i _. rewrite (refine_find_mpoly Hq (refine_seqmultinom_of_multinom i)) /=. case_eq (M.find (seqmultinom_of_multinom i) q') =>[s|/=]. - rewrite -F.find_mapsto_iff F.elements_mapsto_iff. by rewrite -in_InA_eq_key_elt_iff (proj1 (P.elements_Empty _ ) Eq'). - by move=> _; rewrite mulr0 scale0r. } move=> k' e q p'' p''' Hmap Hin Hadd Hind p ref_p. pose k := multinom_of_seqmultinom_val n k'. have Hk : refines Rseqmultinom k k'; [by apply (refine_size_add Hadd ref_p)|]. have Hp : p@_k = e. { rewrite (refine_find_mpoly ref_p Hk) Hadd F.add_eq_o //. exact: E.eq_refl. } pose p0 := (c * e) *: 'X_[m + k]. pose pmpk := p - p@_k *: 'X_[k]. have Hpmpk : pmpk@_k = 0. { by rewrite mcoeffB mcoeffZ mcoeffX eqxx Hp mulr1 subrr. } set sum := \sum_(_ <- _) _. have->: sum = p0 + \big[+%R/0]_(i2 <- msupp pmpk) ((c * pmpk@_i2) *: 'X_[(m + i2)]). { rewrite /sum /pmpk /p0. case_eq (k \in msupp p) => Hmsuppp. { rewrite (big_rem _ Hmsuppp) /= Hp; f_equal. rewrite -Hp -(perm_big _ (msupp_rem p k)) /=. apply eq_big_seq => i. rewrite mcoeffB mcoeffZ mcoeffX. rewrite mcoeff_msupp Hp -Hpmpk. case (boolP (k == i)). { move/eqP<-; rewrite Hpmpk. by rewrite mcoeffB Hp mcoeffZ mcoeffX eqxx mulr1 subrr eqxx. } by rewrite mulr0 subr0. } move: Hmsuppp; rewrite mcoeff_msupp Hp; move/eqP ->. by rewrite mulr0 !scale0r add0r subr0. } rewrite /p0. apply refine_Madd_mnm_add. { eapply refines_apply; first by eapply refines_apply; tc. rewrite /k. apply refine_multinom_of_seqmultinom_val. apply (@refine_size_mpoly _ _ _ _ ref_p). red in Hadd. apply/F.in_find_iff. rewrite Hadd F.add_eq_o //. exact/mnmc_eq_seqP. } { eapply Hind. apply (rem_mpoly_eff Hin Hadd ref_p Hk). } rewrite mcoeff_msupp negbK. set F' := fun i2 => (c *: 'X_[m]) * (pmpk@_i2 *: 'X_[i2]). rewrite (eq_bigr F'). { rewrite -big_distrr /= -mpolyE. rewrite (mcoeff_poly_mul _ _ (k:=(mdeg (m + k)).+1)) //. rewrite big1 // => k0. case (boolP (m == k0.1)). { by move/eqP<-; rewrite eqm_add2l; move/eqP <-; rewrite Hpmpk mulr0. } by rewrite mcoeffZ mcoeffX; move /negbTE ->; rewrite mulr0 mul0r. } move=> m'' _; rewrite /F'; rewrite mpolyXD. rewrite -scalerAl -scalerA; f_equal. by rewrite -[RHS]commr_mpolyX -scalerAl commr_mpolyX. Qed. Arguments mpoly_mul {n R} p q. #[export] Instance refine_mpoly_mul_eff n : refines (Reffmpoly ==> Reffmpoly ==> Reffmpoly (T := T) (n := n)) mpoly_mul mpoly_mul_eff. Proof. apply refines_abstr => q q' ref_q. apply refines_abstr => p p' ref_p. rewrite [mpoly_mul q p]mpolyME big_allpairs. rewrite /mpoly_mul_eff. pose f m c := \big[+%R/0]_(i2 <- msupp p) ((c * p@_i2) *: 'X_[(m + i2)]). pose f' m c := @mult_monomial_eff _ mul_instR m c p'. now_show (refines Reffmpoly (\sum_(m <- msupp q) f m q@_m) (M.fold (fun m c => mpoly_add_eff (f' m c)) q' M.empty)). apply(*:*) refine_mpoly_sum_eff =>//. - by move=> m; rewrite /f big1 // => m2 _; rewrite mul0r scale0r. - apply refines_abstr => m m' ref_m. apply refines_abstr => c c' ref_c. rewrite /f /f' /mult_monomial_eff. rewrite {ref_c}(refines_eq ref_c). by apply refine_Madd_mnm_add_sum. Qed. Definition mpoly_exp {n} (p : {mpoly T[n]}) (n : nat) := p ^+ n. #[export] Instance refine_mpoly_exp_eff n : refines (Reffmpoly ==> Rnat ==> Reffmpoly (T := T) (n := n)) mpoly_exp (mpoly_exp_eff (n:=n)). Proof. apply refines_abstr => p p' ref_p. apply refines_abstr => k k' ref_k. rewrite /mpoly_exp /mpoly_exp_eff. move/RnatE in ref_k. have{ref_k}->: k' = implem_N k by rewrite ref_k spec_NK. rewrite /implem_N bin_of_natE. elim: k => [|k IHk]; first by rewrite expr0; apply refine_mp1_eff. case Ek: k => [|k0]. by rewrite expr1 /= -[p]mulr1; refines_apply. rewrite exprS -Ek /= -Pos.succ_of_nat ?Ek //. rewrite Pos.iter_succ. refines_apply1. by rewrite Ek /= Pos.of_nat_succ in IHk. Qed. Definition seq_Reffmpoly n k (lq : k.-tuple {mpoly T[n]}) (lq' : seq (effmpoly T)) := ((size lq' = k) * forall i, refines Reffmpoly lq`_i (nth mp0_eff lq' i))%type. Lemma refine_comp_monomial_eff n k : refines (Rseqmultinom ==> eq ==> @seq_Reffmpoly n k ==> Reffmpoly) (fun m c lq => mpolyC c * mmap1 (tnth lq) m) (comp_monomial_eff (n:= n)). Proof. apply refines_abstr => m m' ref_m. apply refines_abstr => c c' ref_c. rewrite refinesE in ref_c; rewrite -{}ref_c {c'}. apply refines_abstr => lq lq' ref_lq. rewrite mul_mpolyC /comp_monomial_eff; eapply refines_apply. { eapply refines_apply; [apply refine_mpoly_scale_eff|by apply trivial_refines]. } move: ref_lq; rewrite refinesE /seq_Reffmpoly; move => [sz_lq ref_lq]. elim: k m m' ref_m lq lq' sz_lq ref_lq =>[|k IHk] m m' ref_m lq lq' sz_lq ref_lq. { rewrite /mmap1 bigop.big_ord0. move: (size0nil sz_lq) => ->; rewrite /zipwith /=; apply refine_mp1_eff. } move: sz_lq; case_eq lq' => //= q0 lqt' Hlq' sz_lq. move: (@refine_size _ _ _ ref_m); case_eq m' => //= m0 mt' Hm' sz_m'. rewrite /foldr /= -/(foldr _ _) /mmap1 bigop.big_ord_recl. eapply refines_apply; [eapply refines_apply; [by apply refine_mpoly_mul_eff|]|]. { move: (@refine_nth _ _ _ ord0 ref_m); rewrite Hm' /= => <-. refines_apply. replace (tnth _ _) with (lq`_O); [|by case lq, tval]. change q0 with (nth mp0_eff (q0 :: lqt') O); rewrite -Hlq'; apply ref_lq. } injection sz_lq => {}sz_lq; injection sz_m' => {}sz_m'. assert (ref_mt : refines Rseqmultinom (multinom_of_seqmultinom_val k mt') mt'). { by apply /refine_multinom_of_seqmultinom_val /eqP. } have Hlq_lq' : forall i : nat, refines Reffmpoly [tuple of behead lq]`_i (nth mp0_eff lqt' i). { by move=> i; move: (ref_lq i.+1); rewrite Hlq' /=; case tval; elim i. } move: (IHk _ _ ref_mt [tuple of behead lq] _ sz_lq Hlq_lq'). rewrite refinesE /Reffmpoly /ofun_hrel => ->; f_equal. apply bigop.eq_big => // i _; f_equal. { rewrite tnth_behead; f_equal. by apply ord_inj; rewrite inordK //; move: (ltn_ord i). } move /eqP in sz_m'; move: (refine_multinom_of_seqmultinom_val sz_m') => Hmt'. move: (@refine_nth _ _ _ i Hmt') => <-. move: (@refine_nth _ _ _ (inord i.+1) ref_m); rewrite Hm' /=. rewrite inordK /=; [|by rewrite ltnS]; move=> ->; apply f_equal. by apply ord_inj; rewrite inordK //; move: (ltn_ord i). Qed. Arguments comp_mpoly {n R k} lq p. #[export] Instance refine_comp_mpoly_eff n k : refines (@seq_Reffmpoly n k ==> Reffmpoly ==> Reffmpoly) comp_mpoly (comp_mpoly_eff (n:= n)). Proof. apply refines_abstr => lq lq' ref_lq. apply refines_abstr => p p' ref_p. rewrite /comp_mpoly /mmap /comp_mpoly_eff. pose f := fun m c => c%:MP_[n] * mmap1 (tnth lq) m. rewrite (eq_bigr (fun m => f m p@_m)) //. apply refine_mpoly_sum_eff. { by move=> m; rewrite /f mpolyC0 mul0r. } { apply refines_abstr => m m' ref_m. apply refines_abstr => c c'; rewrite refinesE /f => <-. change (_ * _) with ((fun lq => c%:MP_[n] * mmap1 (tnth lq) m) lq). eapply refines_apply; [|by apply ref_lq]. change (fun _ => _) with ((fun c lq => c%:MP_[n] * mmap1 (tnth lq) m) c). apply: (@refines_apply _ _ eq); last first. { exact: trivial_refines. } change (fun _ => _) with ((fun m (c : T) lq => c%:MP_[n] * mmap1 (tnth lq) m) m). eapply refines_apply; [apply refine_comp_monomial_eff|apply ref_m]. } apply ref_p. Qed. End effmpoly_theory. (** ** Part 3: Parametricity *) Derive Inversion inv_HdRel with (forall (A : Type) (eqA : A -> A -> Prop) (x : A) (s : seq A), @HdRel A eqA x s) Sort Prop. Section effmpoly_parametricity. Context (A : ringType) (C : Type) (rAC : A -> C -> Type). Definition M_hrel (m : M.t A) (m' : M.t C) : Type := ((forall k, M.In k m <-> M.In k m') * forall k e e', M.MapsTo k e m -> M.MapsTo k e' m' -> rAC e e')%type. Definition ReffmpolyC {n} := (@Reffmpoly A n \o M_hrel)%rel. Context `{!zero_of C, !one_of C, !opp_of C, !add_of C, !sub_of C, !mul_of C, !eq_of C}. Context `{!refines rAC 0 0%C}. Context `{!refines rAC 1 1%C}. Context `{!refines (rAC ==> rAC) -%R -%C}. Context `{!refines (rAC ==> rAC ==> rAC) +%R +%C}. Context `{ref_sub : !refines (rAC ==> rAC ==> rAC) sub_instR sub_op}. Context `{ref_mul : !refines (rAC ==> rAC ==> rAC) *%R *%C}. Context `{!refines (rAC ==> rAC ==> eq) eqtype.eq_op eq_op}. Lemma refine_M_hrel_empty : refines M_hrel M.empty M.empty. Proof. rewrite refinesE; split. { by move=> k; rewrite !F.empty_in_iff. } by move=> k e e' K; exfalso; apply F.empty_mapsto_iff in K. Qed. Lemma refine_M_hrel_add : refines (eq ==> rAC ==> M_hrel ==> M_hrel) (@M.add A) (@M.add C). Proof. rewrite refinesE => m _ <- a c Hac x x' Hx; split. { move=> k; rewrite !F.add_in_iff; split; by rewrite (fst Hx k). } move=> k e e' H1 H2. apply add_mapsto_iff_dec in H1. apply add_mapsto_iff_dec in H2. move: H1 H2. case=> [[Hy <-]|[Hy He]]. { move: Hy; move/mnmc_eq_seqP/eqP->. elim=>[[_ <-]|] // []; rewrite -/(E.eq k k) => K; exfalso; apply: K. exact: E.eq_refl. } by case; [elim=> H'; elim (Hy H')|elim=>_; apply (snd Hx)]. Qed. Lemma refine_M_hrel_singleton : refines (eq ==> rAC ==> M_hrel) (@singleton A) (@singleton C). Proof. apply refines_abstr => k k'; rewrite refinesE => <-. apply refines_abstr => e e' ref_e. rewrite /singleton. eapply refines_apply; [|by apply refine_M_hrel_empty]. eapply refines_apply; [|exact ref_e]. eapply refines_apply; [apply refine_M_hrel_add|by rewrite refinesE]. Qed. Lemma refine_M_hrel_map : refines ((rAC ==> rAC) ==> M_hrel ==> M_hrel) (@M.map A A) (@M.map C C). Proof. apply refines_abstr => f f' ref_f. apply refines_abstr => m m' ref_m. rewrite refinesE; split. { move=> k; rewrite !F.map_in_iff. move: ref_m; rewrite refinesE => H'; apply H'. } move=> k e e' H1 H2. apply map_mapsto_iff_dec in H1. apply map_mapsto_iff_dec in H2. move: H1 H2 => [a Ha] [a' Ha']. rewrite (proj1 Ha) (proj1 Ha'). apply refinesP; eapply refines_apply; [by apply ref_f|]. move: ref_m (proj2 Ha) (proj2 Ha'); rewrite !refinesE => ref_m. apply (snd ref_m). Qed. Lemma refine_M_hrel_find : refines (eq ==> M_hrel ==> option_R rAC) (@M.find A) (@M.find C). Proof. apply refines_abstr => k k'; rewrite refinesE => <-. apply refines_abstr => m m'; rewrite refinesE => ref_m. rewrite refinesE; case_eq (M.find k m') => [e'|]; case_eq (M.find k m) => [e|] /=. { move/F.find_mapsto_iff => H1 /F.find_mapsto_iff => H2. by constructor; apply (snd ref_m) with k. } { move/F.not_find_in_iff => H' H''; exfalso; apply H'. by apply (fst ref_m); rewrite F.in_find_iff H''. } { move=> H' /F.not_find_in_iff => H''; exfalso; apply H''. apply/(fst ref_m k)/F.in_find_iff. by rewrite H'. } by move=> *; constructor. Qed. (* Note: Maybe could be simplified using [map2_ifft] *) Lemma refine_M_hrel_map2 : refines ((option_R rAC ==> option_R rAC ==> option_R rAC) ==> M_hrel ==> M_hrel ==> M_hrel) (@M.map2 A A A) (@M.map2 C C C). Proof. apply refines_abstr => f f' ref_f. apply refines_abstr => m1 m1' ref_m1. apply refines_abstr => m2 m2' ref_m2. have Hf : forall k, option_R rAC (f (M.find k m1) (M.find k m2)) (f' (M.find k m1') (M.find k m2')). { move=> k; apply refinesP; eapply refines_apply; [eapply refines_apply|]. { apply ref_f. } { eapply refines_apply; [|by apply ref_m1]. eapply refines_apply; [apply refine_M_hrel_find|by apply trivial_refines]. } eapply refines_apply; [|by apply ref_m2]. eapply refines_apply; [apply refine_M_hrel_find|by apply trivial_refines]. } rewrite refinesE; rewrite refinesE in ref_m1, ref_m2; split. { move=> k; split. { move=> Hk; have Hor := M.map2_2 Hk; move: Hk => [e He]. apply M.find_1 in He; rewrite (M.map2_1 _ Hor) in He. move: (Hf k); rewrite He; case_eq (f' (M.find k m1') (M.find k m2')) => //. move=> e' He' _; exists e'; apply M.find_2; rewrite -He'; apply M.map2_1. by destruct Hor as [Hk|Hk]; [left; apply ref_m1|right; apply ref_m2]. by move=> _ K; inversion_clear K. } move=> Hk; have Hor := M.map2_2 Hk; move: Hk => [e He]. apply M.find_1 in He; rewrite (M.map2_1 _ Hor) in He. move: (Hf k); rewrite He; case_eq (f (M.find k m1) (M.find k m2)) => //. move=> e' He' _; exists e'; apply M.find_2; rewrite -He'; apply M.map2_1. by destruct Hor as [Hk|Hk]; [left; apply ref_m1|right; apply ref_m2]. by move=> _ K; inversion_clear K. } move=> k e e' He He'; move: (M.find_1 He) (M.find_1 He') (Hf k). case_eq (M.find k m1) => [e1|] He1. { rewrite M.map2_1; [|by left; exists e1; apply M.find_2]. rewrite M.map2_1; [|by left; apply ref_m1; exists e1; apply M.find_2]. by rewrite He1 => -> -> H; inversion_clear H. } case_eq (M.find k m2) => [e2|] He2. { rewrite M.map2_1; [|by right; exists e2; apply M.find_2]. rewrite M.map2_1; [|by right; apply ref_m2; exists e2; apply M.find_2]. by rewrite He1 He2 => -> -> H; inversion_clear H. } elim (@map2_2_dec _ _ _ m1 m2 k f); [| |by exists e]. { by move/MIn_sig=> [e'1 He'1]; apply M.find_1 in He'1; rewrite He'1 in He1. } by move/MIn_sig=> [e'2 He'2]; apply M.find_1 in He'2; rewrite He'2 in He2. Qed. Lemma Sorted_InA_not_lt_hd B (ke h : M.key * B) t : Sorted (M.lt_key (elt:=B)) (h :: t) -> InA (M.eq_key_elt (elt:=B)) ke (h :: t) -> ~ M.lt_key ke h. Proof. move: h; elim t => [|h' t' IH] h. { move=> _ Hin. eapply inv_InA; [move=> _ y l Hy Hlt| |exact: Hin]. by case: Hlt =><- _ => K; move: (proj1 Hy); apply E.lt_not_eq. by move=> _ y l K [_ Hl]; rewrite Hl in K; inversion K. } move=> HS Hin Hlt. have Hh := proj2 (Sorted_inv HS); eapply inv_HdRel; last exact: Hh; first done. move=> _. eapply inv_InA; last exact: Hin. intros H y l H0 H1 b l0 H2 H3. move: Hlt (proj1 H0). by case: H1 =>-> _; apply E.lt_not_eq. have HS' := proj1 (Sorted_inv HS). intros H y l H0 H1 b l0 H2 H3. case: H3 => H31 H32; rewrite H31 in H2. apply (IH _ HS'); last by apply E.lt_trans with (1 := Hlt). by case: H1 => _ <-. Qed. Lemma Sorted_InA_tl_lt B (ke h : M.key * B) t : Sorted (M.lt_key (elt:=B)) (h :: t) -> InA (M.eq_key_elt (elt:=B)) ke t -> M.lt_key h ke. Proof. move: h; elim t => [|h' t' IH] h; [by move=> _ Hin; inversion Hin|]. move=> HS Hin. have Hh := proj2 (Sorted_inv HS). eapply inv_HdRel; last exact: Hh; [done|move=> _ b l Hbl [Hb _]]. rewrite Hb in Hbl. eapply inv_InA; last exact: Hin; move=> _ y l' Hy [Hy' Hl']. { change (M.lt_key _ _) with (E.lt h.1 ke.1). by rewrite Hy' in Hy; move: (proj1 Hy); move/mnmc_eq_seqP/eqP => ->. } apply (E.lt_trans Hbl), IH; first by apply (Sorted_inv HS). by rewrite -Hl'. Qed. Lemma refine_M_hrel_elements : refines (M_hrel ==> list_R (prod_R eq rAC)) (@M.elements A) (@M.elements C). Proof. apply refines_abstr => m m'; rewrite !refinesE => ref_m. set em := M.elements m; set em' := M.elements m'. have: ((forall k, {e | InA (M.eq_key_elt (elt:=A)) (k, e) em} <=> {e' | InA (M.eq_key_elt (elt:=C)) (k, e') em'}) * (forall k e e', InA (M.eq_key_elt (elt:=A)) (k, e) em -> InA (M.eq_key_elt (elt:=C)) (k, e') em' -> rAC e e'))%type. { split. { move=> k; split. { move=> [e He]. have Hkm : M.In k m; [by exists e; apply M.elements_2|]. have /MIn_sig [e' He'] := proj1 (fst ref_m k) Hkm. exists e'; by apply M.elements_1. } move=> [e' He']. have Hkm' : M.In k m'; [by exists e'; apply M.elements_2|]. have /MIn_sig [e He] := proj2 (fst ref_m _) Hkm'. exists e; by apply M.elements_1. } move=> k e e' He He'. move: (M.elements_2 He) (M.elements_2 He'); apply (snd ref_m). } move: (M.elements_3 m) (M.elements_3 m'); rewrite -/em -/em'. clearbody em em'; move: {m m' ref_m} em em'. elim=> [|h t IH]; case=> [|h' t'] //=. { move/SortedT_dec=> _ _ [Heq _]. move: (ifft2 (Heq h'.1)); elim. { by move=> h'2 /InA_nil. } by exists h'.2; apply InA_cons_hd; split; [apply E.eq_refl|]. } { move=> _ _ [Heq _]; move: (ifft1 (Heq h.1)); elim. { by move=> h2 /InA_nil. } by exists h.2; apply InA_cons_hd; split; [apply E.eq_refl|]. } move=> Sht Sht' [Hht1 Hht2]. have St := proj1 (Sorted_inv Sht); have St' := proj1 (Sorted_inv Sht'). have Hhh' : E.eq h.1 h'.1. { apply MultinomOrd.intro_eq; apply/negbTE/negP. { move=> Hhh'1. have Hh1 : {e | InA (M.eq_key_elt (elt:=A)) (h.1, e) (h :: t)}. { by exists h.2; apply InA_cons_hd; split; [apply E.eq_refl|]. } have [e' He'] := (ifft1 (Hht1 _) Hh1). have Hhh'1' : M.lt_key (h.1, e') h'; [by simpl|]. by apply (Sorted_InA_not_lt_hd Sht' He'). } move=> Hh'h1. have Hh1 : {e | InA (M.eq_key_elt (elt:=C)) (h'.1, e) (h' :: t')}. { by exists h'.2; apply InA_cons_hd; split; [apply E.eq_refl|]. } move: (ifft2 (Hht1 _) Hh1) => [e He]. have Hh'h1' : M.lt_key (h'.1, e) h; [by simpl|]. by apply (Sorted_InA_not_lt_hd Sht He). } constructor 2. apply: prod_RI. split; [by move: Hhh' => /mnmc_eq_seqP /eqP|]. { apply (Hht2 h.1); apply InA_cons_hd. { by split; [apply E.eq_refl|]. } by move: Hhh' => /mnmc_eq_seqP/eqP->; split; [apply E.eq_refl|]. } apply (IH _ St St'). constructor=> k; specialize (Hht1 k); specialize (Hht2 k). { split. { move=> [e He]. have Ht1 : {e | InA (M.eq_key_elt (elt:=A)) (k, e) (h :: t)}. { by exists e; apply InA_cons_tl. } case (ifft1 Hht1 Ht1) => e' He'. exists e'. have /InA_cons[Heq0|//] := He'. move: (Sorted_InA_tl_lt Sht He); move /E.lt_not_eq. move: Hhh'; move/mnmc_eq_seqP/eqP-> => Heq; exfalso; apply Heq. move: (proj1 Heq0); move/mnmc_eq_seqP/eqP => /= ->. by apply E.eq_refl. } move=> [e' He']. have Ht1 : { e' | InA (M.eq_key_elt (elt:=C)) (k, e') (h' :: t')}. { by exists e'; apply InA_cons_tl. } elim (ifft2 Hht1 Ht1) => e He. exists e. have /InA_cons[Heq0|//] := He. move: (Sorted_InA_tl_lt Sht' He'); move /E.lt_not_eq. move: Hhh'; move/mnmc_eq_seqP/eqP<- => Heq; exfalso; apply Heq. move: (proj1 Heq0); move/mnmc_eq_seqP/eqP => /= ->. by apply E.eq_refl. } by move=> e e' He He'; apply Hht2; apply InA_cons_tl. Qed. Derive Inversion inv_list_R with (forall (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (s1 : seq A₁) (s2 : seq A₂), @list_R A₁ A₂ A_R s1 s2) Sort Type. Lemma refine_M_hrel_fold : refines ((eq ==> rAC ==> M_hrel ==> M_hrel) ==> M_hrel ==> M_hrel ==> M_hrel) (@M.fold A _) (@M.fold C _). Proof. apply refines_abstr => f f' ref_f. apply refines_abstr => m m' ref_m. apply refines_abstr => i i' ref_i. move: (refines_apply refine_M_hrel_elements ref_m); rewrite !M.fold_1 !refinesE. move: i i' ref_i; generalize (M.elements m), (M.elements m'). elim=> [|h t IHt]; case=> //=. - by move=> i i'; rewrite refinesE. - by move=> a l i i' _ K; inversion K. - by move=> i i' _ K; inversion K. move=> h' t' i i' ref_i Hyp. eapply inv_list_R; last exact: Hyp; try done. move=> H a c sa sc Heq Heqs [H1 H2] [H3 H4]. apply: IHt; last first. rewrite -H2 -H4; exact: Heqs. rewrite -H1 -H3; case: Heq => [h1 _ <- h2 h2' rh2] /=. apply: refines_apply ref_i. apply: refines_apply. apply: refines_apply. by rewrite refinesE. Qed. #[export] Instance refine_filter A' B (rAB : A' -> B -> Type) : refines ((rAB ==> eq) ==> list_R rAB ==> list_R rAB) filter filter. Proof. eapply refines_abstr=> f f' rf. eapply refines_abstr=> l l' rl. elim: l l' rl => [|h t IH] l'; rewrite refinesE => rl. { inversion rl; apply nil_R. } move: rl; case l' => [|h' t'] rl; [by inversion rl|]. inversion rl as [|h_ h'_ Hh t_ t'_ Ht]. rewrite /=. have ->: f h = f' h'; [by apply refinesP; eapply refines_apply; tc|]. specialize (IH t' (trivial_refines Ht)); rewrite refinesE in IH. by case (f' h') => //; apply cons_R. Qed. #[export] Instance ReffmpolyC_list_of_mpoly_eff n : refines (@ReffmpolyC n ==> list_R (prod_R Rseqmultinom rAC)) (@list_of_mpoly A n) list_of_mpoly_eff. Proof. have: refines (M_hrel ==> list_R (prod_R eq rAC)) (@list_of_mpoly_eff _ _ (@eq_of_instance_0 A)) list_of_mpoly_eff. { rewrite /list_of_mpoly_eff. apply refines_abstr => p p' rp. eapply refines_apply; [|eapply refines_apply; [apply refine_M_hrel_elements|exact rp]]. eapply refines_apply; [by apply refine_filter|]. eapply refines_abstr => mc mc' rmc. rewrite refinesE; f_equal. rewrite refinesE in rmc; inversion rmc as [a a' ref_a b b' ref_b]. apply refinesP; tc. } apply: refines_trans (refine_list_of_mpoly_eff _). apply: (composable_imply _ _ (R2 := list_R (prod_R eq rAC))). rewrite composableE => l. elim: l => [|h t IH]. { case=> [|h' t']; [by move=>_; apply nil_R|]. move=> H; inversion H as [x X]; inversion X as [X0 X1]. by inversion X0 as [H' Hx|H' Hx]; rewrite -Hx in X1; inversion X1. } case=> [|h' t']. { move=> H; inversion H as [x X]; inversion X as [X0 X1]. by inversion X1 as [Hx H'|Hx H']; rewrite -Hx in X0; inversion X0. } specialize (IH t'); move=> H. case: H => l'' X. case: X => X0 X1. move: X0 X1; case: l'' => [|h'' t''] X0 X1; [by inversion X0|]. inversion X0 as [|X X' ref_X Y Y' ref_Y]. inversion X1 as [|Z Z' ref_Z T T' ref_T]. inversion ref_X as [x x' ref_x x0 x0' ref_x0']. inversion ref_Z as [u u' ref_u v v' ref_v]. apply: cons_R; last first. by apply IH; exists t''; split. apply/prod_RI; split; simpl. suff->: u' = x' by []. rewrite -[u']/(u',v').1 H10 -[x']/(x', x0').1 H8. symmetry. by rewrite -H9 -H10 /=. suff->: x0 = v by []. rewrite -[x0]/(x, x0).2 H7. rewrite -[v]/(u, v).2 H9. by rewrite -H7 -H8 /=. Qed. #[export] Instance ReffmpolyC_mp0_eff (n : nat) : refines (@ReffmpolyC n) 0 (@mp0_eff C). Proof. eapply refines_trans; [by apply composable_comp|by apply refine_mp0_eff|]. apply refine_M_hrel_empty. Qed. #[export] Instance ReffmpolyC_mp1_eff (n : nat) : refines (@ReffmpolyC n) 1 (mp1_eff (n:=n)). Proof. eapply refines_trans; [by apply composable_comp|by apply refine_mp1_eff|]. rewrite /mp1_eff; eapply refines_apply; [|by tc]. by eapply refines_apply; [apply refine_M_hrel_singleton|apply trivial_refines]. Qed. Instance composable_imply_id2 : forall (A B A' B' C' : Type) (rAB : A -> B -> Type) (R1 : A' -> B' -> Type) (R2 : B' -> C' -> Type) (R3 : A' -> C' -> Type), composable R1 R2 R3 -> composable (rAB ==> R1)%rel (eq ==> R2)%rel (rAB ==> R3)%rel. Proof. intros A0 B A' B' C' rAB R1 R2 R3. rewrite !composableE => R123 fA fC [fB [RfAB RfBC]] a c rABac. apply: R123; exists (fB c); split; [ exact: RfAB | exact: RfBC ]. Qed. #[export] Instance ReffmpolyC_mpvar_eff {n1 : nat} : refines (rAC ==> Rnat ==> Rord0 ==> @ReffmpolyC n1) mpvar (mpvar_eff (n:=n1)). Proof. eapply refines_trans. eapply composable_imply_id1. eapply composable_imply_id2. eapply composable_imply_id2. by tc. by eapply refine_mpvar_eff. rewrite /mpvar_eff. apply refines_abstr => c c' ref_c. apply refines_abstr => d d' ref_d. apply refines_abstr => i i' ref_i. eapply refines_apply; [|by apply ref_c]. eapply refines_apply; [apply refine_M_hrel_singleton|apply trivial_refines]. by rewrite (refines_eq ref_d) (refines_eq ref_i). Qed. #[export] Instance ReffmpolyC_mpolyC_eff (n : nat) : refines (rAC ==> ReffmpolyC) (@mpolyC n A) (mpolyC_eff (n:=n)). Proof. eapply refines_trans. eapply composable_imply_id1; by tc. by apply refine_mpolyC_eff. apply refines_abstr => c c' ref_c. eapply refines_apply; [|by apply ref_c]. rewrite /mpolyC_eff; eapply refines_apply; by [apply refine_M_hrel_singleton|apply trivial_refines]. Qed. #[export] Instance ReffmpolyC_mpolyX_eff (n : nat) : refines (Rseqmultinom ==> ReffmpolyC) (@mpolyX n A) mpolyX_eff. Proof. eapply refines_trans; [|by apply refine_mpolyX_eff|]. eapply composable_imply_id2; by tc. rewrite /mpolyX_eff. apply refines_abstr => m m' ref_m. eapply refines_apply; [|by tc]. eapply refines_apply; [apply refine_M_hrel_singleton|apply ref_m]. Qed. Local Instance refine_M_hrel_mpoly_scale_eff : refines (rAC ==> M_hrel ==> M_hrel) (@mpoly_scale_eff A *%R) (@mpoly_scale_eff C *%C). Proof. rewrite /mpoly_scale_eff. rewrite refinesE => x x' ref_x p p' [Hp1 Hp2]; split. { by move=> k; rewrite !F.map_in_iff. } move=> k e e'; move=>/map_mapsto_iff_dec [a [Ha1 Ha2]]. move=>/map_mapsto_iff_dec [c [Hc1 Hc2]]. rewrite Ha1 Hc1. rewrite {1}/mul_op. eapply refinesP; refines_apply; rewrite refinesE. by eapply (Hp2 _ _ _ Ha2 Hc2). Qed. #[export] Instance ReffmpolyC_mpoly_scale_eff (n : nat) : refines (rAC ==> ReffmpolyC ==> ReffmpolyC) (@mpoly_scale n A) mpoly_scale_eff. Proof. by eapply refines_trans; first eapply composable_imply_id1; tc. Qed. Local Instance refine_M_hrel_mpoly_add_eff : refines (M_hrel ==> M_hrel ==> M_hrel) (@mpoly_add_eff A +%R) mpoly_add_eff. Proof. rewrite /mpoly_add_eff. eapply refines_apply; first eapply refine_M_hrel_map2. rewrite refinesE => a a' ref_a b b' ref_b. case: ref_a; case: ref_b => *; constructor =>//. by eapply refinesP; refines_apply. Qed. #[export] Instance ReffmpolyC_mpoly_add_eff (n : nat) : refines (ReffmpolyC ==> ReffmpolyC ==> ReffmpolyC) (@mpoly_add n A) mpoly_add_eff. Proof. by eapply refines_trans; first eapply composable_imply; tc. Qed. Local Instance refine_M_hrel_mpoly_sub_eff : refines (M_hrel ==> M_hrel ==> M_hrel) (@mpoly_sub_eff A -%R sub_instR) mpoly_sub_eff. Proof. rewrite /mpoly_sub_eff. eapply refines_apply; first eapply refine_M_hrel_map2. rewrite refinesE => a a' ref_a b b' ref_b. case: ref_a; case: ref_b => *; constructor =>//. by eapply refinesP; refines_apply. by eapply refinesP; refines_apply. Qed. #[export] Instance ReffmpolyC_mpoly_sub_eff (n : nat) : refines (ReffmpolyC ==> ReffmpolyC ==> ReffmpolyC) (@mpoly_sub A n) mpoly_sub_eff. Proof. by eapply refines_trans; first eapply composable_imply; tc. Qed. Local Instance refine_M_hrel_mult_monomial_eff : refines (eq ==> rAC ==> M_hrel ==> M_hrel) (@mult_monomial_eff A *%R) mult_monomial_eff. Proof. rewrite /mult_monomial_eff. eapply refines_abstr => k k' ref_k. eapply refines_abstr => d d' ref_d. eapply refines_abstr => e e' ref_e. eapply refines_apply. eapply refines_apply. eapply refines_apply. eapply refine_M_hrel_fold. clear e e' ref_e. eapply refines_abstr => e e' ref_e. eapply refines_abstr => f f' ref_f. eapply refines_abstr => g g' ref_g. eapply refines_apply. (* FIXME: Use refines_apply *) eapply refines_apply. eapply refines_apply. eapply refine_M_hrel_add. by rewrite (refines_eq ref_k) (refines_eq ref_e) refinesE. refines_apply. done. done. exact: refine_M_hrel_empty. Qed. (* Really needed to restate this? *) Local Instance refine_M_hrel_mp0_eff : refines M_hrel mp0_eff mp0_eff. Proof. rewrite /mp0_eff; exact: refine_M_hrel_empty. Qed. Local Instance refine_M_hrel_mpoly_mul_eff : refines (M_hrel ==> M_hrel ==> M_hrel) (@mpoly_mul_eff A +%R *%R) mpoly_mul_eff. Proof. rewrite /mpoly_mul_eff. apply refines_abstr => a a' ref_a. apply refines_abstr => b b' ref_b. repeat eapply refines_apply. eapply refine_M_hrel_fold. eapply refines_abstr => k k' ref_k. eapply refines_abstr => d d' ref_d. eapply refines_abstr => e e' ref_e. refines_apply. done. by tc. Qed. #[export] Instance ReffmpolyC_mpoly_mul_eff (n : nat) : refines (ReffmpolyC ==> ReffmpolyC ==> ReffmpolyC) (@mpoly_mul n A) mpoly_mul_eff. Proof. by eapply refines_trans; first eapply composable_imply; tc. Qed. Local Instance refine_M_hrel_mpoly_exp_eff n : refines (M_hrel ==> Logic.eq ==> M_hrel) (@mpoly_exp_eff _ 1 +%R *%R n) (mpoly_exp_eff (n:=n)). Proof. rewrite /mpoly_exp_eff. apply refines_abstr => m m' ref_m. apply refines_abstr => k k'; rewrite refinesE => <- {k'}. rewrite !N2Nat.inj_iter. move Ek: (N.to_nat k) => nk. elim: nk {Ek} => [|nk IHnk] /=. { rewrite /mp1_eff; eapply refines_apply; [|by tc]. eapply refines_apply; [apply refine_M_hrel_singleton|by apply trivial_refines]. } eapply refines_apply; first eapply refines_apply; try by tc. Qed. #[export] Instance ReffmpolyC_mpoly_exp_eff (n : nat) : refines (ReffmpolyC ==> Rnat ==> ReffmpolyC) (@mpoly_exp A n) (mpoly_exp_eff (n:=n)). Proof. by eapply refines_trans; first eapply composable_imply; tc. Qed. Definition seq_ReffmpolyC n k := (@seq_Reffmpoly A n k \o list_R M_hrel)%rel. Local Instance refine_M_hrel_comp_monomial_eff n : refines (Logic.eq ==> rAC ==> list_R M_hrel ==> M_hrel) (@comp_monomial_eff A 1 +%R *%R n) (comp_monomial_eff (n:=n)). Proof. apply refines_abstr => m m'; rewrite refinesE => <-. apply refines_abstr => c c' ref_c. apply refines_abstr => lq lq' ref_lq. rewrite /comp_monomial_eff. eapply refines_apply. { eapply refines_apply; [apply refine_M_hrel_mpoly_scale_eff|apply ref_c]. } move: lq lq' ref_lq m. elim=> [|hlq tlq IH]; case=> [|hlq' tlq']; rewrite refinesE //=. { move=> _ m /=; rewrite /mp1_eff; eapply refines_apply; [|by tc]. eapply refines_apply; [apply refine_M_hrel_singleton|by apply trivial_refines]. } by move=> K; inversion K. by move=> K; inversion K. move=> K; inversion K. case=> [|hm tm] /=. { rewrite /mp1_eff; eapply refines_apply; [|by tc]. eapply refines_apply; [apply refine_M_hrel_singleton|by apply trivial_refines]. } eapply refines_apply; [eapply refines_apply|]. { by apply refine_M_hrel_mpoly_mul_eff. } { apply: (@refines_apply _ _ eq). exact: trivial_refines. } by apply IH; rewrite refinesE. Qed. Local Instance refine_M_hrel_comp_mpoly_eff (n : nat) : refines (list_R M_hrel ==> M_hrel ==> M_hrel) (@comp_mpoly_eff A 1 +%R *%R n) (comp_mpoly_eff (n:=n)). Proof. rewrite /comp_mpoly_eff. apply refines_abstr => lq lq' ref_lq. apply refines_abstr => p p' ref_p. eapply refines_apply. eapply refines_apply. eapply refines_apply. eapply refine_M_hrel_fold. eapply refines_abstr => k k' ref_k. eapply refines_abstr => d d' ref_d. eapply refines_abstr => e e' ref_e. refines_apply. done. by tc. Qed. #[export] Instance ReffmpolyC_comp_mpoly_eff (n k : nat) : refines (seq_ReffmpolyC (k:=k) ==> ReffmpolyC ==> ReffmpolyC) (comp_mpoly (k:=n)) (comp_mpoly_eff (n:=n)). Proof. by eapply refines_trans; first eapply composable_imply; tc. Qed. End effmpoly_parametricity. End FMapMultipoly. (* Module M := FMapList.Make MultinomOrd. Module PolyList := FMapMultipoly M. *) Module M := FMapAVL.Make MultinomOrd. Module PolyAVL := FMapMultipoly M. coqeal-2.1.0/refinements/param.v000066400000000000000000000264031475512565300166060ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype. From elpi Require Import derive param2. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. #[global] Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. (** Automation: for turning [sth_R a b] goals into mere [a = b] goals, do [suff_eq sth_Rxx]. *) Ltac suff_eq Rxx := match goal with | [ |- ?R ?a ?b ] => let H := fresh in suff H : a = b; first (rewrite H; eapply Rxx =>//) end. Require Import ProofIrrelevance. (* for opaque terms *) (* data types *) Elpi derive.param2 option. Elpi derive.param2 unit. Elpi derive.param2 bool. #[export] Hint Resolve true_R false_R : core. Elpi derive.param2 nat. Elpi derive.param2 list. Elpi derive.param2 prod. Lemma bool_Rxx b : bool_R b b. Proof. by case: b. Qed. Lemma nat_Rxx n : nat_R n n. Proof. elim: n=> [|n]; [ exact: O_R | exact: S_R ]. Qed. Lemma list_Rxx T (rT : T -> T -> Type) l : (forall x, rT x x) -> list_R rT l l. Proof. move=> Hr; elim: l=> [|h t IH]; [exact: nil_R|]. exact: cons_R. Qed. Lemma option_Rxx T (rT : T -> T -> Type) l : (forall x, rT x x) -> option_R rT l l. Proof. by move=> Hr; case: l => *; constructor. Qed. (** ssrfun *) Elpi derive.param2 simpl_fun. (** ssrbool *) Elpi derive.param2 pred. Elpi derive.param2 rel. Elpi derive.param2 simpl_pred. Elpi derive.param2 simpl_rel. Elpi derive.param2 SimplPred. Elpi derive.param2 SimplRel. Elpi derive.param2 orb. Elpi derive.param2 andb. Elpi derive.param2 implb. Elpi derive.param2 negb. Elpi derive.param2 addb. Elpi derive.param2 eqb. (** ssrnat *) Elpi derive.param2 Nat.sub. Elpi derive.param2 subn. Elpi derive.param2 subn_rec. Elpi derive.param2 Nat.add. Elpi derive.param2 addn. Elpi derive.param2 addn_rec. Elpi derive.param2 addn. Elpi derive.param2 eqn. (* This trick avoids having to apply Parametricity to eqtype structure *) Opaque eqn subn. Definition leqn := Eval cbv in leq. Elpi derive.param2 leqn. Definition leq_R := leqn_R. Elpi derive.param2.register leq leq_R. Elpi derive.param2 Logic.eq. (* geq, ltn and gtn use SimplRel, not sure how well they will work in proofs... *) Elpi derive.param2 geq. Elpi derive.param2 ltn. Elpi derive.param2 gtn. Elpi derive.param2 maxn. Elpi derive.param2 minn. Elpi derive.param2 iter. Elpi derive.param2 iteri. Elpi derive.param2 iterop. Elpi derive.param2 Nat.mul. Elpi derive.param2 muln. Elpi derive.param2 muln_rec. Elpi derive.param2 expn. Elpi derive.param2 expn_rec. Elpi derive.param2 factorial. Elpi derive.param2 fact_rec. Elpi derive.param2 odd. Elpi derive.param2 double. Elpi derive.param2 double_rec. (* Obtained from paramcoq *) Definition half_R := let fix_half_1 : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let fix_half_2 : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let fix_uphalf_1 : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for uphalf in let fix_uphalf_2 : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for uphalf in 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₂) := let gen_path : let half : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let uphalf : forall _ : nat, nat := fix half0 (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half0 n') end for uphalf in forall n : nat, @eq nat match n return nat with | @O => n | @S n' => uphalf n' end (half n) := let half : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let uphalf : forall _ : nat, nat := fix half0 (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half0 n') end for uphalf in fun n : nat => match n as n0 return (@eq nat match n0 return nat with | @O => n0 | @S n' => uphalf n' end (half n0)) with | @O => @Logic.eq_refl nat (half O) | @S n0 => (fun n1 : nat => @Logic.eq_refl nat (half (S n1))) n0 end in @eq_rect nat match n₁ return nat with | @O => n₁ | @S n' => fix_uphalf_1 n' end (fun x : nat => nat_R x (fix_half_2 n₂)) (@eq_rect nat match n₂ return nat with | @O => n₂ | @S n' => fix_uphalf_2 n' end (fun x : nat => nat_R match n₁ return nat with | @O => n₁ | @S n' => fix_uphalf_1 n' end x) match n_R in (nat_R n₁0 n₂0) return (nat_R match n₁0 return nat with | @O => n₁ | @S n' => fix_uphalf_1 n' end match n₂0 return nat with | @O => n₂ | @S n' => fix_uphalf_2 n' end) with | @O_R => n_R | @S_R n'₁ n'₂ n'_R => uphalf_R n'₁ n'₂ n'_R end (fix_half_2 n₂) (gen_path n₂)) (fix_half_1 n₁) (gen_path n₁) 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₂) := let gen_path : let half : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let uphalf : forall _ : nat, nat := fix half0 (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half0 n') end for uphalf in forall n : nat, @eq nat match n return nat with | @O => n | @S n' => S (half n') end (uphalf n) := let half : forall _ : nat, nat := fix half (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half n') end for half in let uphalf : forall _ : nat, nat := fix half0 (n : nat) : nat := match n return nat with | @O => n | @S n' => uphalf n' end with uphalf (n : nat) : nat := match n return nat with | @O => n | @S n' => S (half0 n') end for uphalf in fun n : nat => match n as n0 return (@eq nat match n0 return nat with | @O => n0 | @S n' => S (half n') end (uphalf n0)) with | @O => @Logic.eq_refl nat (uphalf O) | @S n0 => (fun n1 : nat => @Logic.eq_refl nat (uphalf (S n1))) n0 end in @eq_rect nat match n₁ return nat with | @O => n₁ | @S n' => S (fix_half_1 n') end (fun x : nat => nat_R x (fix_uphalf_2 n₂)) (@eq_rect nat match n₂ return nat with | @O => n₂ | @S n' => S (fix_half_2 n') end (fun x : nat => nat_R match n₁ return nat with | @O => n₁ | @S n' => S (fix_half_1 n') end x) match n_R in (nat_R n₁0 n₂0) return (nat_R match n₁0 return nat with | @O => n₁ | @S n' => S (fix_half_1 n') end match n₂0 return nat with | @O => n₂ | @S n' => S (fix_half_2 n') end) with | @O_R => n_R | @S_R n'₁ n'₂ n'_R => @S_R (fix_half_1 n'₁) (fix_half_2 n'₂) (half_R n'₁ n'₂ n'_R) end (fix_uphalf_2 n₂) (gen_path n₂)) (fix_uphalf_1 n₁) (gen_path n₁) for half_R. Elpi derive.param2.register half half_R. (* Elpi derive.param2 half. (* requires mutual inductives *) *) (** seq *) (* Here we must make the implicit argument in size explicit *) Elpi derive.param2 size. Definition nilp' T (s : seq T) := eqn (size s) 0. Elpi derive.param2 nilp'. Definition nilp_R := nilp'_R. Elpi derive.param2.register nilp nilp_R. Elpi derive.param2 ohead. Elpi derive.param2 head. Elpi derive.param2 behead. Elpi derive.param2 ncons. Elpi derive.param2 nseq. Elpi derive.param2 cat. Elpi derive.param2 rcons. Elpi derive.param2 last. Elpi derive.param2 belast. Elpi derive.param2 nth. Elpi derive.param2 set_nth. Elpi derive.param2 find. Elpi derive.param2 filter. Elpi derive.param2 nat_of_bool. Elpi derive.param2 count. Elpi derive.param2 has. Elpi derive.param2 all. Elpi derive.param2 drop. Elpi derive.param2 take. Elpi derive.param2 rot. Elpi derive.param2 rotr. Elpi derive.param2 catrev. Elpi derive.param2 rev. Elpi derive.param2 map. Elpi derive.param2 oapp. Elpi derive.param2 pmap. Elpi derive.param2 iota. Elpi derive.param2 mkseq. Elpi derive.param2 foldr. Elpi derive.param2 sumn. Elpi derive.param2 foldl. Elpi derive.param2 pairmap. Elpi derive.param2 scanl. Elpi derive.param2 zip. Elpi derive.param2 fst. Elpi derive.param2 snd. Elpi derive.param2 unzip1. Elpi derive.param2 unzip2. Elpi derive.param2 flatten. Elpi derive.param2 shape. Elpi derive.param2 reshape. Elpi derive.param2 allpairs. (* fintype *) Elpi derive.param2 predArgType. Elpi derive.param2 is_true. Elpi derive.param2 ordinal. coqeal-2.1.0/refinements/poly_div.v000066400000000000000000000153031475512565300173300ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From elpi Require Import derive. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv. From CoqEAL Require Import param refinements hrel poly_op. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op Poly.Op. Section generic_division. Variable N R polyR : Type. Context `{lt_of N, sub_of N, add_of N, one_of N, zero_of N, spec_of N nat}. Context `{size_of polyR N, lead_coef_of R polyR, cast_of R polyR}. Context `{shift_of polyR N, add_of polyR, mul_of polyR, sub_of polyR}. Context `{eq_of polyR, zero_of polyR}. Definition div_rec_poly (q : polyR) := let sq := (size_op q : N) in let cq := (cast (lead_coef_op q : R) : polyR) in fix loop (k : N) (qq r : polyR) (n : nat) {struct n} := if (size_op r < sq)%C then (k, qq, r) else let m := shift_op (size_op r - sq)%C (cast (lead_coef_op r : R) : polyR) in let qq1 := (qq * cq + m)%C in let r1 := (r * cq - m * q)%C in if n is n1.+1 then loop (k + 1)%C qq1 r1 n1 else ((k + 1)%C, qq1, r1). #[export] Instance div_poly : div_of polyR := fun p q => (if (q == 0)%C then (0%C, 0%C, p) else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).1.2. #[export] Instance mod_poly : mod_of polyR := fun p q => (if (q == 0)%C then (0%C, 0%C, p) else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).2. #[export] Instance scal_poly : scal_of polyR N := fun p q => (if (q == 0)%C then (0%C, 0%C, p) else div_rec_poly q 0%C 0%C p (spec (size_op p : N))).1.1. End generic_division. Elpi derive.param2 div_rec_poly. Elpi derive.param2 div_poly. Elpi derive.param2 mod_poly. Elpi derive.param2 scal_poly. Section division_correctness. Variable R : ringType. Local Instance lt_nat : lt_of nat := ltn. Local Instance sub_nat : sub_of nat := subn. Local Instance add_nat : add_of nat := addn. Local Instance one_nat : one_of nat := 1%N. Local Instance zero_nat : zero_of nat := 0%N. Local Instance spec_nat : spec_of nat nat := spec_id. Local Instance size_of_poly : size_of {poly R} nat := sizep (R:=R). Local Instance lead_coef_poly : lead_coef_of R {poly R} := lead_coef. Local Instance cast_poly : cast_of R {poly R} := polyC. Local Instance shift_poly : shift_of {poly R} nat := shiftp (R:=R). Local Instance add_poly : add_of {poly R} := +%R. Local Instance mul_poly : mul_of {poly R} := *%R. Local Instance sub_poly : sub_of {poly R} := fun p q => p - q. Local Instance eq_poly : eq_of {poly R} := eqtype.eq_op. Local Instance zero_poly : zero_of {poly R} := 0%R. Lemma div_rec_polyE (p q : {poly R}) n r m: div_rec_poly (N:=nat) (R:=R) q n r p m = redivp_rec q n r p m. Proof. rewrite /div_rec_poly /redivp_rec. move: n r p. elim: m=> [|m ihm] n r p; by rewrite -[(_ < _)%C]/(_ < _) /shift_op /shift_poly /shiftp ?ihm mul_polyC [(_ + _)%C]addn1. Qed. Lemma div_polyE (p q : {poly R}) : div_poly (N:=nat) (R:=R) p q = rdivp p q. Proof. rewrite /div_poly -[rdivp p q]/((rscalp p q, rdivp p q, rmodp p q).1.2). rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. by rewrite unlock /= /spec_nat /spec_id. Qed. Lemma mod_polyE (p q : {poly R}) : mod_poly (N:=nat) (R:=R) p q = rmodp p q. Proof. rewrite /mod_poly -[rmodp p q]/((rscalp p q, rdivp p q, rmodp p q).2). rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. by rewrite unlock /= /spec_nat /spec_id. Qed. Lemma scal_polyE (p q : {poly R}) : scal_poly (N:=nat) (R:=R) p q = rscalp p q. Proof. rewrite /scal_poly -[rscalp p q]/((rscalp p q, rdivp p q, rmodp p q).1.1). rewrite -redivp_def div_rec_polyE /redivp /redivp_expanded_def. by rewrite unlock /= /spec_nat /spec_id. Qed. Section division_param. Local Open Scope rel_scope. Context (N : Type) (rN : nat -> N -> Type). Context (C : Type) (rC : R -> C -> Type). Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). Context `{lt_of N, sub_of N, add_of N, one_of N, zero_of N, spec_of N nat}. Context `{size_of polyC N, lead_coef_of C polyC, cast_of C polyC}. Context `{shift_of polyC N, add_of polyC, mul_of polyC, sub_of polyC}. Context `{eq_of polyC, zero_of polyC}. Context `{!refines (rN ==> rN ==> bool_R) ltn lt_op}. Context `{!refines (rN ==> rN ==> rN) subn sub_op}. Context `{!refines (rN ==> rN ==> rN) addn add_op}. Context `{!refines rN 1%N 1%C, !refines rN 0%N 0%C}. Context `{!refines (rN ==> nat_R) spec_id spec}. Context `{!refines (RpolyC ==> rN) size_op size_op}. Context `{!refines (RpolyC ==> rC) lead_coef_poly lead_coef_op}. Context `{!refines (rC ==> RpolyC) cast_poly cast}. Context `{!refines (rN ==> RpolyC ==> RpolyC) shift_poly shift_op}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) sub_poly sub_op}. Context `{!refines (RpolyC ==> RpolyC ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines RpolyC 0%R 0%C}. #[export] Instance RpolyC_div_poly : refines (RpolyC ==> RpolyC ==> RpolyC) (div_poly (N:=nat) (R:=R) (polyR:={poly R})) (div_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. param div_poly_R. Qed. #[export] Instance refine_div_poly : refines (RpolyC ==> RpolyC ==> RpolyC) (@rdivp R) (div_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. rewrite refinesE=> p p' hp q q' hq. rewrite -div_polyE. exact: refinesP. Qed. #[export] Instance RpolyC_mod_poly : refines (RpolyC ==> RpolyC ==> RpolyC) (mod_poly (N:=nat) (R:=R) (polyR:={poly R})) (mod_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. param mod_poly_R. Qed. #[export] Instance refine_mod_poly : refines (RpolyC ==> RpolyC ==> RpolyC) (@rmodp R) (mod_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. rewrite refinesE=> p p' hp q q' hq. rewrite -mod_polyE. exact: refinesP. Qed. #[export] Instance RpolyC_scal_poly : refines (RpolyC ==> RpolyC ==> rN) (scal_poly (N:=nat) (R:=R) (polyR:={poly R})) (scal_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. apply: refines_abstr2 => p p' hp q q' hq; rewrite refinesE. by apply: (@scal_poly_R _ _ _ _ _ rC _ _ RpolyC) => *; apply: refinesP. Qed. #[export] Instance refine_scal_poly : refines (RpolyC ==> RpolyC ==> rN) (@rscalp R) (scal_poly (N:=N) (R:=C) (polyR:=polyC)). Proof. rewrite refinesE=> p p' hp q q' hq. rewrite -scal_polyE. exact: refinesP. Qed. End division_param. End division_correctness. coqeal-2.1.0/refinements/poly_op.v000066400000000000000000000030771475512565300171710ustar00rootroot00000000000000From elpi Require Import derive. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv. From CoqEAL Require Import param. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. (* Specific classes for polynomials *) Module Poly. Module Op. Class shift_of polyA N := shift_op : N -> polyA -> polyA. #[export] Hint Mode shift_of + + : typeclass_instances. Class split_of polyA N := split_op : N -> polyA -> polyA * polyA. #[export] Hint Mode split_of + + : typeclass_instances. Class lead_coef_of A polyA := lead_coef_op : polyA -> A. #[export] Hint Mode lead_coef_of + + : typeclass_instances. Class scal_of polyA N := scal_op : polyA -> polyA -> N. #[export] Hint Mode scal_of + + : typeclass_instances. Elpi derive.param2 shift_of. Elpi derive.param2 shift_op. Elpi derive.param2 split_of. Elpi derive.param2 split_op. Elpi derive.param2 lead_coef_of. Elpi derive.param2 lead_coef_op. Elpi derive.param2 scal_of. Elpi derive.param2 scal_op. End Op. End Poly. Import Poly.Op. #[export] Typeclasses Transparent shift_of split_of lead_coef_of scal_of. Section poly_op. Local Open Scope ring_scope. Variable R : ringType. Definition splitp : nat -> {poly R} -> {poly R} * {poly R} := fun n p => (rdivp p 'X^n, rmodp p 'X^n). Definition shiftp n (p : {poly R}) := p * 'X^n. Definition sizep : {poly R} -> nat := size. Lemma sizepE s : sizep s = size s. Proof. by []. Qed. End poly_op. coqeal-2.1.0/refinements/pos.v000066400000000000000000000041571475512565300163110ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. Require Import ZArith. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. From CoqEAL Require Import hrel param refinements. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import Refinements.Op GRing.Theory. Record pos := pos_of { val_of_pos : nat; _ : (val_of_pos > 0)%N }. HB.instance Definition _ := [isSub of pos for val_of_pos]. HB.instance Definition _ := [Equality of pos by <:]. (* Parametricity pos. *) (* Lemma eq_bool_R x y (a b : bool_R x y) : a = b. *) (* Proof. Admitted. *) (* Lemma pos_Rxx p : pos_R p p. *) (* Proof. *) (* case: p=> n ngt0. *) (* apply: (@pos_R_pos_of_R _ _ (nat_Rxx _)). *) (* case: _ / ngt0 (leq_R _ _) bool_R_true_R=> a b. *) (* rewrite [a](eq_bool_R _ b). *) (* by constructor. *) (* Qed. *) Section pos. Import Refinements.Op. Definition posS (n : nat) : pos := @pos_of n.+1 isT. #[export] Instance pos1 : one_of pos := posS 0. #[export] Instance add_pos : add_of pos := fun m n => insubd pos1 (val m + val n). #[export] Instance sub_pos : sub_of pos := fun m n => insubd pos1 (val m - val n). #[export] Instance mul_pos : mul_of pos := fun m n => insubd pos1 (val m * val n). #[export] Instance exp_pos : exp_of pos pos := fun m n => insubd pos1 (val m ^ val n). #[export] Instance leq_pos : leq_of pos := fun m n => val m <= val n. #[export] Instance lt_pos : lt_of pos := fun m n => val m < val n. #[export] Instance eq_pos : eq_of pos := eqtype.eq_op. #[export] Instance cast_pos_nat : cast_of pos nat := val. #[export] Instance cast_nat_pos : cast_of nat pos := insubd 1%C. Local Open Scope ring_scope. Definition pos_to_int (p : pos) : int := (val p)%:R. Definition int_to_nat (z : int) : nat := if z > 0 then `|z|%N else 0%N. Definition int_to_pos (z : int) : pos := insubd pos1 (int_to_nat z). End pos. coqeal-2.1.0/refinements/rational.v000066400000000000000000000344551475512565300173250ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset bigop order. From mathcomp Require Import ssralg ssrint ssrnum rat. From CoqEAL Require Import hrel param refinements pos. (******************************************************************************) (* Non-normalized rational numbers refines SSReflects rational numbers (rat) *) (* *) (* rational == Type of non normalized rational numbers *) (* *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Import GRing.Theory Order.Theory Num.Theory Refinements.Op. (*************************************************************) (* PART I: Defining datastructures and programming with them *) (*************************************************************) Section Q. Variable Z P N : Type. (* Generic definition of rationals *) Definition Q := (Z * P)%type. (* Definition of operators on Q Z *) Section Q_ops. Local Open Scope computable_scope. Context `{zero_of Z, one_of Z, add_of Z, opp_of Z, mul_of Z, eq_of Z, leq_of Z, lt_of Z}. Context `{one_of P, sub_of P, add_of P, mul_of P, eq_of P, leq_of P, lt_of P}. Context `{cast_of P Z, cast_of Z P}. Context `{spec_of Z int, spec_of P pos, spec_of N nat}. #[export] Instance zeroQ : zero_of Q := (0, 1). #[export] Instance oneQ : one_of Q := (1, 1). #[export] Instance addQ : add_of Q := fun x y => (x.1 * cast y.2 + y.1 * cast x.2, x.2 * y.2). #[export] Instance mulQ : mul_of Q := fun x y => (x.1 * y.1, x.2 * y.2). #[export] Instance oppQ : opp_of Q := fun x => (- x.1, x.2). #[export] Instance eqQ : eq_of Q := fun x y => (x.1 * cast y.2 == y.1 * cast x.2). #[export] Instance leqQ : leq_of Q := fun x y => (x.1 * cast y.2 <= y.1 * cast x.2). #[export] Instance ltQ : lt_of Q := fun x y => (x.1 * cast y.2 < y.1 * cast x.2). #[export] Instance invQ : inv_of Q := fun x => if (x.1 == 0)%C then 0 else if (0 < x.1) then (cast x.2, cast x.1) else (- (cast x.2), cast (- x.1)). #[export] Instance subQ : sub_of Q := fun x y => (x + - y). #[export] Instance divQ : div_of Q := fun x y => (x * y^-1). #[export] Instance expQnat : exp_of Q N := fun x n => iter (spec n) (mulQ x) 1. #[export] Instance specQ : spec_of Q rat := fun q => (spec q.1)%:~R / (cast (spec q.2 : pos))%:R. (* Embedding from Z to Q *) #[export] Instance cast_ZQ : cast_of Z Q := fun x => (x, 1). #[export] Instance cast_PQ : cast_of P Q := fun x => cast (cast x : Z). End Q_ops. End Q. Elpi derive.param2 Q. Elpi derive.param2 zeroQ. Elpi derive.param2 oneQ. Elpi derive.param2 addQ. Elpi derive.param2 mulQ. Elpi derive.param2 oppQ. Elpi derive.param2 eqQ. Elpi derive.param2 leqQ. Elpi derive.param2 ltQ. Elpi derive.param2 invQ. Elpi derive.param2 subQ. Elpi derive.param2 divQ. Definition expQnat' := Eval compute in expQnat. Elpi derive.param2 expQnat'. Definition expQnat_R := expQnat'_R. Elpi derive.param2 cast_ZQ. Elpi derive.param2 cast_PQ. Arguments specQ / _ _ _ _ _ : assert. (***********************************************************) (* PART II: Proving the properties of the previous objects *) (***********************************************************) Section Qint. Instance zero_int : zero_of int := 0%R. Instance one_int : one_of int := 1%R. Instance add_int : add_of int := +%R. Instance opp_int : opp_of int := -%R. Instance mul_int : mul_of int := *%R. Instance eq_int : eq_of int := eqtype.eq_op. Instance leq_int : leq_of int := Num.le. Instance lt_int : lt_of int := Num.lt. Instance spec_int : spec_of int int := spec_id. Instance cast_pos_int : cast_of pos int := pos_to_int. Instance cast_int_pos : cast_of int pos := int_to_pos. Instance spec_pos : spec_of pos pos := spec_id. Instance spec_nat : spec_of nat nat := spec_id. Local Notation Qint := (Q int pos). (* rat_to_Qint = repr *) (* Qint_to_rat = \pi_rat *) Lemma absz_denq_gt0 r : (0 < `|denq r|)%N. Proof. by rewrite absz_gt0 denq_eq0. Qed. Definition rat_to_Qint (r : rat) : Qint := (numq r, pos_of (absz_denq_gt0 r)). Definition Qint_to_rat (r : Qint) : rat := (r.1%:Q / (val r.2)%:Q). Lemma Qrat_to_intK : cancel rat_to_Qint Qint_to_rat. Proof. by move=> x; rewrite /Qint_to_rat /= absz_denq divq_num_den. Qed. Local Open Scope rel_scope. Definition Rrat : rat -> Q int pos -> Type := fun_hrel Qint_to_rat. Instance Rrat_spec : refines (Rrat ==> Logic.eq) spec_id spec. Proof. by rewrite refinesE=> _ x <-. Qed. Lemma RratE (x : rat) (a : Qint) : refines Rrat x a -> x = a.1%:~R / (val a.2)%:~R. Proof. by move=> rxa; rewrite -[x]/(spec_id _) [spec_id _]refines_eq. Qed. (* We establish the correction of Q int with regard to rat *) Instance Rrat_0 : refines Rrat 0 0%C. Proof. by rewrite refinesE. Qed. Instance Rrat_1 : refines Rrat 1 1%C. Proof. by rewrite refinesE. Qed. Instance Rrat_embed : refines (Logic.eq ==> Rrat) intr cast. Proof. rewrite refinesE => n _ <-. by rewrite /Rrat /Qint_to_rat /fun_hrel /= mulr1. Qed. Definition pos_to_rat (x : pos) : rat := (val x)%:R. Instance Rrat_embed_pos : refines (Logic.eq ==> Rrat) pos_to_rat cast. Proof. rewrite refinesE => n _ <-. rewrite /Rrat /Qint_to_rat /fun_hrel /pos_to_rat /= mulr1. by rewrite /cast /cast_pos_int /pos_to_int natz. Qed. Instance Rrat_add : refines (Rrat ==> Rrat ==> Rrat) +%R +%C. Proof. apply refines_abstr2 => x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite refinesE /Rrat /fun_hrel /Qint_to_rat /= /cast /cast_pos_int /=. rewrite /pos_to_int /mul_op /mul_pos /mul_int /add_op /add_int /=. rewrite val_insubd muln_gt0 da_gt0 db_gt0 /=. rewrite [x]RratE [y]RratE /= addf_div ?intr_eq0 -?lt0n //. by rewrite ?(rmorphD, rmorphM)/= ?PoszM ?intrM !natz. Qed. Instance Rrat_opp : refines (Rrat ==> Rrat) -%R -%C. Proof. apply refines_abstr => x a rx; rewrite refinesE /Rrat /fun_hrel /Qint_to_rat /=. by rewrite /opp_op /opp_int [x]RratE -mulNr rmorphN. Qed. Instance Rrat_mul : refines (Rrat ==> Rrat ==> Rrat) *%R *%C. Proof. apply refines_abstr2 => x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite refinesE /Rrat /fun_hrel /Qint_to_rat /= /mul_op /mul_int /mul_pos /=. rewrite val_insubd muln_gt0 da_gt0 db_gt0 /=. rewrite [x]RratE [y]RratE mulrACA -invfM ?(rmorphD, rmorphM) /=. by rewrite ?PoszM ?rmorphM /=. Qed. Instance Rrat_expnat : refines (Rrat ==> Logic.eq ==> Rrat) (@GRing.exp _) exp_op. Proof. apply refines_abstr2 => x a rx y n; rewrite !refinesE => -> {y}. by elim: n => //= n ihn; rewrite exprS [x * x ^+ n]RratE. Qed. Instance Rrat_inv : refines (Rrat ==> Rrat) GRing.inv inv_op. Proof. apply refines_abstr => x [na [da da_gt0]] /= rx. rewrite refinesE /Rrat /fun_hrel /Qint_to_rat /= /inv_op /invQ /=. rewrite [x]RratE /= -[(_ == _)%C]/(_ == _) -[(_ < _)%C]/(_ < _) /cast. rewrite /cast_pos_int /cast_int_pos /pos_to_int /int_to_pos /int_to_nat /=. have [-> /=|na_neq0 /=] := altP (na =P 0). by rewrite !mul0r ?invr0. have [na_gt0|na_le0] /= := ltrP 0 na. rewrite val_insubd absz_gt0 na_neq0 abszE ger0_norm ?ltW//. by rewrite invfM invrK natz mulrC. rewrite val_insubd /= /opp_op /opp_int /=. rewrite oppr_gt0 lt_neqAle na_neq0 na_le0 /= absz_gt0 oppr_eq0 na_neq0. rewrite abszN mulrNz mulNr -mulrN -invrN -rmorphN /=. by rewrite lez0_abs // opprK invfM invrK mulrC natz. Qed. Instance Rrat_eq : refines (Rrat ==> Rrat ==> bool_R) eqtype.eq_op eq_op. Proof. apply: refines_abstr2 => x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite /eq_op /eqQ /cast /cast_pos_int /pos_to_int /=; simpC. rewrite [x]RratE [y]RratE /= GRing.eqr_div; last 2 first. - by rewrite gt_eqF // ltr0z. - by rewrite gt_eqF // ltr0z. rewrite -!rmorphM /= eqr_int !natz. rewrite refinesE; exact: bool_Rxx. Qed. Instance Rrat_leq : refines (Rrat ==> Rrat ==> bool_R) Num.le leq_op. Proof. apply refines_abstr2 => x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite /leq_op /leqQ /cast /cast_pos_int /pos_to_int /=; simpC. rewrite [x]RratE [y]RratE /= !natz. rewrite ler_pdivrMr ?ltr0z // mulrAC ler_pdivlMr ?ltr0z //. rewrite -!rmorphM /= ler_int. rewrite refinesE; exact: bool_Rxx. Qed. Instance Rrat_lt : refines (Rrat ==> Rrat ==> bool_R) Num.lt lt_op. Proof. apply refines_abstr2 => x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite /leq_op /leqQ /cast /cast_pos_int /pos_to_int /=. rewrite [x]RratE [y]RratE /= /lt_op /ltQ /cast /= !natz. rewrite ltr_pdivrMr ?ltr0z // mulrAC ltr_pdivlMr ?ltr0z //. rewrite -!rmorphM /= ltr_int. rewrite refinesE; exact: bool_Rxx. Qed. Instance Rrat_sub : refines (Rrat ==> Rrat ==> Rrat) (fun x y => x - y) sub_op. Proof. apply refines_abstr2=> x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. rewrite refinesE /Rrat /fun_hrel /Qint_to_rat /= /cast /cast_pos_int. rewrite /pos_to_int /mul_op /mul_pos /mul_int /add_op /add_int /=. rewrite /opp_op /opp_int val_insubd muln_gt0 da_gt0 db_gt0 /=. rewrite [x]RratE [y]RratE /= [(_ * _)%N%:~R]natrM !natz. rewrite intrD !intrM -addf_div ?intr_eq0 -?lt0n //. by rewrite -[in LHS]mulN1r intrM -[db%:~R in LHS]mul1r -mulf_div divr1 mulN1r. Qed. Instance Rrat_div : refines (Rrat ==> Rrat ==> Rrat) divq div_op. Proof. apply refines_abstr2=> x [na [da da_gt0]] rx y [nb [db db_gt0]] ry. by rewrite /divq /div_op /divQ; tc. Qed. (*************************************************************************) (* PART III: We take advantage of parametricity to extend correcion of *) (* operation on Q int to correction of operations on Q Z, for any Z that *) (* refines int *) (*************************************************************************) Section Qparametric. (* (* Z is a type that should implement int *) *) Context (Z P N : Type). Context (Rint : int -> Z -> Type) (Rpos : pos -> P -> Type) (Rnat : nat -> N -> Type). Local Notation Q := (Q Z P). Definition RratC : rat -> Q -> Type := (Rrat \o prod_R Rint Rpos)%rel. Context `{zero_of Z, one_of Z, add_of Z, opp_of Z, sub_of Z, mul_of Z, eq_of Z, leq_of Z, lt_of Z}. Context `{one_of P, sub_of P, add_of P, mul_of P, eq_of P, leq_of P, lt_of P}. Context `{cast_of P Z, cast_of Z P}. Context `{spec_of Z int, spec_of P pos, spec_of N nat}. Context `{!refines Rint 0%R 0%C, !refines Rint 1%R 1%C}. Context `{!refines (Rint ==> Rint) -%R -%C}. Context `{!refines (Rint ==> Rint ==> Rint) +%R +%C}. Context `{!refines (Rint ==> Rint ==> Rint) (fun x y => x - y) sub_op}. Context `{!refines (Rint ==> Rint ==> Rint) *%R *%C}. Context `{!refines (Rint ==> Rint ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (Rint ==> Rint ==> bool_R) Num.le leq_op}. Context `{!refines (Rint ==> Rint ==> bool_R) Num.lt lt_op}. Context `{!refines (Rpos ==> Rint) cast cast}. Context `{!refines (Rint ==> Rpos) cast cast}. Context `{!refines (Rint ==> Logic.eq) spec_id spec}. Context `{!refines Rpos pos1 1%C}. Context `{!refines (Rpos ==> Rpos ==> Rpos) add_pos +%C}. Context `{!refines (Rpos ==> Rpos ==> Rpos) mul_pos *%C}. Context `{!refines (Rpos ==> Rpos ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (Rpos ==> Rpos ==> bool_R) leq_pos leq_op}. Context `{!refines (Rpos ==> Rpos ==> bool_R) lt_pos lt_op}. Context `{!refines (Rpos ==> Logic.eq) spec_id spec}. Context `{!refines (Rnat ==> nat_R) spec_id spec}. #[export] Instance RratC_zeroQ : refines RratC 0 0%C. Proof. param_comp zeroQ_R. Qed. #[export] Instance RratC_oneQ : refines RratC 1 1%C. Proof. param_comp oneQ_R. Qed. #[export] Instance RratC_cast_ZQ : refines (Rint ==> RratC) intr cast. Proof. param_comp cast_ZQ_R. Qed. #[export] Instance RratC_cast_PQ : refines (Rpos ==> RratC) pos_to_rat cast. Proof. param_comp cast_PQ_R. Qed. #[export] Instance RratC_addQ : refines (RratC ==> RratC ==> RratC) +%R +%C. Proof. param_comp addQ_R. Qed. #[export] Instance RratC_mulQ : refines (RratC ==> RratC ==> RratC) *%R *%C. Proof. param_comp mulQ_R. Qed. #[export] Instance RratC_expQnat : refines (RratC ==> Rnat ==> RratC) (@GRing.exp _) exp_op. Proof. eapply refines_trans; tc. rewrite refinesE; do ?move=> ?*. eapply (@expQnat_R _ _ _ _ _ _ _ _ Rnat)=> // *; exact: refinesP. Qed. #[export] Instance RratC_oppQ : refines (RratC ==> RratC) -%R -%C. Proof. param_comp oppQ_R. Qed. #[export] Instance RratC_invQ : refines (RratC ==> RratC) GRing.inv inv_op. Proof. param_comp invQ_R. Qed. #[export] Instance RratC_subQ : refines (RratC ==> RratC ==> RratC) (fun x y => x - y) sub_op. Proof. param_comp subQ_R. Qed. #[export] Instance RratC_divq : refines (RratC ==> RratC ==> RratC) divq div_op. Proof. param_comp divQ_R. Qed. #[export] Instance RratC_eqQ : refines (RratC ==> RratC ==> bool_R) eqtype.eq_op eq_op. Proof. param_comp eqQ_R. Qed. #[export] Instance RratC_leqQ : refines (RratC ==> RratC ==> bool_R) Num.le leq_op. Proof. param_comp leqQ_R. Qed. #[export] Instance RratC_ltQ : refines (RratC ==> RratC ==> bool_R) Num.lt lt_op. Proof. param_comp ltQ_R. Qed. #[export] Instance RratC_spec : refines (RratC ==> Logic.eq) spec_id spec. Proof. eapply refines_trans; tc. rewrite refinesE -[Rint]refinesE -[Rpos]refinesE; move=> x y rxy. case: rxy=> i j rij p q rpq. by rewrite /spec /specQ /spec_int /spec_pos /= ![spec_id _]refines_eq. Qed. End Qparametric. End Qint. Require Import binnat binint. Section tests. Goal (0 == 0 :> rat). by coqeal. Abort. Goal (1 == 1 :> rat). by coqeal. Abort. Goal (3%:~R / 4%:~R == - (- (3 * 10)%:Z)%:~R / (2 * 20)%N%:~R :> rat). by coqeal. Abort. Goal ((3%:~R / 4%:~R) * (20%:~R / 15%:~R) == 1 :> rat). by coqeal. Abort. Goal ((1 / 2%:~R)^+3 == (1 / 2%:~R) - (3%:~R / 8%:~R) :> rat). by coqeal. Abort. Goal ((1 / 10%:~R)^-1 == 10%:~R :> rat). by coqeal. Abort. Goal ((1 / 15%:~R) / (2%:~R / 21%:~R) == 7%:~R / 10%:~R :> rat). by coqeal. Abort. (* Lemma foo (P : bool -> Type) : *) (* P true -> *) (* P ((11*100+1)%N%:~R / (44*100)%N%:~R + (22*100-1)%N%:~R/(44*100)%N%:~R *) (* == 3%:~R / 4%:~R :> rat). *) (* Proof. *) (* Time by vm_compute. (* 20s *) *) (* Restart. *) (* Time by rewrite [X in _ -> P X]refines_boolE. (* 1s *) *) (* (* TODO : deal with tons of successors => *) *) (* (* only possible through a plugin imo -- Cyril*) *) (* Qed. *) End tests. coqeal-2.1.0/refinements/refinements.v000066400000000000000000000441651475512565300200320ustar00rootroot00000000000000From elpi Require Import derive. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. (* Require Import path choice fintype tuple finset ssralg bigop poly polydiv. *) (* Require Import ssrint ZArith. *) From CoqEAL Require Import hrel param. Require Import ssrmatching. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. *) Declare Scope computable_scope. Delimit Scope computable_scope with C. Local Open Scope rel. (* Shortcut for triggering typeclass resolution *) Ltac tc := do 1?typeclasses eauto. Section refinements. Fact refines_key : unit. Proof. done. Qed. Class refines A B (R : A -> B -> Type) (m : A) (n : B) := refines_rel : (locked_with refines_key R) m n. Arguments refines A B R%rel m n. Lemma refinesE A B (R : A -> B -> Type) : refines R = R. Proof. by rewrite /refines unlock. Qed. Lemma refines_eq T (x y : T) : refines eq x y -> x = y. Proof. by rewrite refinesE. Qed. #[export] Instance refines_bool_eq x y : refines bool_R x y -> refines eq x y. Proof. by rewrite !refinesE=> [[]]. Qed. Lemma nat_R_eq x y : nat_R x y -> x = y. Proof. by elim=> // m n _ ->. Qed. #[export] Instance refines_nat_eq x y : refines nat_R x y -> refines eq x y. Proof. rewrite !refinesE; exact: nat_R_eq. Qed. Lemma refinesP T T' (R : T -> T' -> Type) (x : T) (y : T') : refines R x y -> R x y. Proof. by rewrite refinesE. Qed. Fact composable_lock : unit. Proof. done. Qed. Class composable A B C (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type) := Composable : locked_with composable_lock (rAB \o rBC <= rAC). Arguments composable A B C rAB%rel rBC%rel rAC%rel. Lemma composableE A B C (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type) : composable rAB rBC rAC = (rAB \o rBC <= rAC). Proof. by rewrite /composable unlock. Qed. Lemma refines_trans A B C (rAB : A -> B -> Type) (rBC : B -> C -> Type) (rAC : A -> C -> Type) (a : A) (b : B) (c : C) : composable rAB rBC rAC -> refines rAB a b -> refines rBC b c -> refines rAC a c. Proof. by rewrite !refinesE composableE => rABC rab rbc; apply: rABC; exists b. Qed. Lemma trivial_refines T T' (R : T -> T' -> Type) (x : T) (y : T') : R x y -> refines R x y. Proof. by rewrite refinesE. Qed. #[export] Instance refines_apply A B (R : A -> B -> Type) C D (R' : C -> D -> Type) : forall (c : A -> C) (d : B -> D), refines (R ==> R') c d -> forall (a : A) (b : B), refines R a b -> refines R' (c a) (d b) | 99. Proof. by rewrite !refinesE => c d rcd a b rab; apply: rcd. Qed. #[export] Instance composable_rid1 A B (R : A -> B -> Type) : composable eq R R | 1. Proof. rewrite composableE; apply: eq_hrelRL. by split; [ apply: comp_eql | move=> x y hxy; exists x ]. Qed. #[export] Instance composable_bool_id1 B (R : bool -> B -> Type) : composable bool_R R R | 1. Proof. by rewrite composableE => x y [y' [[]]]. Qed. (* #[export] Instance composable_nat_id1 B (R : nat -> B -> Type) : composable nat_R R R | 1. *) (* Proof. by rewrite composableE => x y [y' [/nat_R_eq ->]]. Qed. *) #[export] Instance composable_comp A B C (rAB : A -> B -> Type) (rBC : B -> C -> Type) : composable rAB rBC (rAB \o rBC). Proof. by rewrite composableE. Qed. #[export] Instance composable_imply A B C A' B' C' (rAB : A -> B -> Type) (rBC : B -> C -> Type) (R1 : A' -> B' -> Type) (R2 : B' -> C' -> Type) (R3 : A' -> C' -> Type) : composable R1 R2 R3 -> composable (rAB ==> R1) (rBC ==> R2) (rAB \o rBC ==> R3) | 0. Proof. rewrite !composableE => R123 fA fC [fB [RfAB RfBC]] a c [b [rABab rBCbc]]. apply: R123; exists (fB b); split; [ exact: RfAB | exact: RfBC ]. Qed. #[export] Instance composable_imply_id1 A B A' B' C' (rAB : A -> B -> Type) (R1 : A' -> B' -> Type) (R2 : B' -> C' -> Type) (R3 : A' -> C' -> Type) : composable R1 R2 R3 -> composable (eq ==> R1) (rAB ==> R2) (rAB ==> R3) | 1. Proof. rewrite !composableE => R123 fA fC [fB [RfAB RfBC]] a c rABac. apply: R123; exists (fB a); split; [ exact: RfAB | exact: RfBC ]. Qed. (* Composable and pairs *) Lemma prod_RE A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y : prod_R rA rB x y -> prod_hrel rA rB x y. Proof. by case; split. Qed. Lemma prod_RI A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y : prod_hrel rA rB x y -> prod_R rA rB x y. Proof. by move: x y => [x1 x2] [y1 y2] [] /=; constructor. Qed. Lemma refines_prod_R A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) x y : refines rA x.1 y.1 -> refines rB x.2 y.2 -> refines (prod_R rA rB) x y. Proof. by rewrite !refinesE => *; apply: prod_RI; split. Qed. #[export] Instance composable_prod A A' B B' C C' (rAB : A -> B -> Type) (rAB' : A' -> B' -> Type) (rBC : B -> C -> Type) (rBC' : B' -> C' -> Type) (rAC : A -> C -> Type) (rAC' : A' -> C' -> Type) : composable rAB rBC rAC -> composable rAB' rBC' rAC' -> composable (prod_R rAB rAB') (prod_R rBC rBC') (prod_R rAC rAC') | 1. Proof. rewrite !composableE=> h1 h2 [a a'] [c c'] [[b b']]. move=> [/prod_RE [/= ??] /prod_RE [/= ??]]. by split; [ apply: h1; exists b | apply: h2; exists b']. Qed. Section refines_split. Context {T} {Y} {Z} {R1 : T -> Y -> Type} {R2 : Y -> Z -> Type} {x : T} {z : Z}. Lemma refines_split : refines (R1 \o R2) x z -> {y : Y & (refines R1 x y * refines R2 y z)%type}. Proof. by rewrite !refinesE. Qed. Lemma refines_split1 : refines (R1 \o R2) x z -> {y : Y & (refines R1 x y * R2 y z)%type}. Proof. by rewrite !refinesE. Qed. Lemma refines_split2 : refines (R1 \o R2) x z -> {y : Y & (R1 x y * refines R2 y z)%type}. Proof. by rewrite !refinesE. Qed. Lemma refines_split12 : refines (R1 \o R2) x z -> {y : Y & (R1 x y * R2 y z)%type}. Proof. by rewrite !refinesE. Qed. End refines_split. Lemma refines_abstr A B C D (R : A -> B -> Type) (R' : C -> D -> Type) (c : A -> C) (d : B -> D): (forall (a : A) (b : B), refines R a b -> refines R' (c a) (d b)) -> refines (R ==> R') c d. Proof. by rewrite !refinesE; apply. Qed. Lemma refines_abstr2 A B A' B' A'' B'' (R : A -> B -> Type) (R' : A' -> B' -> Type) (R'' : A'' -> B'' -> Type) (f : A -> A' -> A'' ) (g : B -> B' -> B''): (forall (a : A) (b : B), refines R a b -> forall (a' : A') (b' : B'), refines R' a' b' -> refines R'' (f a a') (g b b')) -> refines (R ==> R' ==> R'') f g. Proof. by move=> H; do 2![eapply refines_abstr => *]; apply: H. Qed. #[export] Instance refines_pair_R A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) : refines (rA ==> rB ==> prod_R rA rB)%rel (@pair _ _) (@pair _ _). Proof. by rewrite refinesE. Qed. #[export] Instance refines_fst_R A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) : refines (prod_R rA rB ==> rA)%rel (@fst _ _) (@fst _ _). Proof. by rewrite !refinesE=> [??] [??]. Qed. #[export] Instance refines_snd_R A A' B B' (rA : A -> A' -> Type) (rB : B -> B' -> Type) : refines (prod_R rA rB ==> rB)%rel (@snd _ _) (@snd _ _). Proof. by rewrite !refinesE=> [??] [??]. Qed. Class unify A (x y : A) := unify_rel : x = y. #[export] Instance unifyxx A (x : A) : unify x x := erefl. #[export] Instance refines_of_unify A x y : unify x y -> refines (@unify A) x y | 100. Proof. by rewrite refinesE. Qed. Lemma refines_comp_unify A B (R : A -> B -> Type) x y : refines (R \o (@unify B))%rel x y -> refines R x y. Proof. move=> /refines_split12. rewrite !refinesE=> H. case: H=> ? h. case: h=> ? h2. by rewrite -h2. Qed. End refinements. Arguments refines [A B]%type R%rel m n. Arguments refinesP {T T' R x y} _. #[export] Hint Mode refines - - - + - : typeclass_instances. #[export] Hint Extern 0 (refines _ _ _) => apply trivial_refines; eassumption : typeclass_instances. #[export] Hint Extern 0 (refines (_ \o (@unify _))%rel _ _) => eapply refines_trans : typeclass_instances. (* Tactic for doing parametricity proofs, it takes a parametricity theorem generated by the Parametricity plugin as argument *) Ltac param x := rewrite ?refinesE; do?move=> ?*; eapply x=> *; eapply refinesP; do ?eapply refines_apply; tc. (* Special tactic when relation is defined using \o *) Ltac param_comp x := eapply refines_trans; tc; param x. #[export] Instance refines_true : refines _ _ _ := trivial_refines true_R. #[export] Instance refines_false : refines _ _ _ := trivial_refines false_R. #[export] Instance refines_negb : refines (bool_R ==> bool_R) negb negb. Proof. exact/trivial_refines/negb_R. Qed. #[export] Instance refines_implb : refines (bool_R ==> bool_R ==> bool_R) implb implb. Proof. exact/trivial_refines/implb_R. Qed. #[export] Instance refines_andb : refines (bool_R ==> bool_R ==> bool_R) andb andb. Proof. exact/trivial_refines/andb_R. Qed. #[export] Instance refines_orb : refines (bool_R ==> bool_R ==> bool_R) orb orb. Proof. exact/trivial_refines/orb_R. Qed. #[export] Instance refines_addb : refines (bool_R ==> bool_R ==> bool_R) addb addb. Proof. exact/trivial_refines/addb_R. Qed. #[export] Instance refines_eqb : refines (bool_R ==> bool_R ==> bool_R) eqtype.eq_op eqtype.eq_op. Proof. exact/trivial_refines/eqb_R. Qed. Lemma refines_goal (G G' : Type) : refines (fun T T' => T' -> T) G G' -> G' -> G. Proof. by rewrite refinesE. Qed. #[export] Instance refines_leibniz_eq (T : eqType) (x y : T) b : refines bool_R (x == y) b -> refines (fun T' T => T -> T') (x = y) b. Proof. by move=> /refines_bool_eq; rewrite !refinesE => <- /eqP. Qed. Module Refinements. (* Generic operations *) Module Op. Class zero_of A := zero_op : A. #[export] Hint Mode zero_of + : typeclass_instances. Class one_of A := one_op : A. #[export] Hint Mode one_of + : typeclass_instances. Class opp_of A := opp_op : A -> A. #[export] Hint Mode opp_of + : typeclass_instances. Class add_of A := add_op : A -> A -> A. #[export] Hint Mode add_of + : typeclass_instances. Class sub_of A := sub_op : A -> A -> A. #[export] Hint Mode sub_of + : typeclass_instances. Class mul_of A := mul_op : A -> A -> A. #[export] Hint Mode mul_of + : typeclass_instances. Class exp_of A B := exp_op : A -> B -> A. #[export] Hint Mode exp_of + + : typeclass_instances. Class div_of A := div_op : A -> A -> A. #[export] Hint Mode div_of + : typeclass_instances. Class inv_of A := inv_op : A -> A. #[export] Hint Mode inv_of + : typeclass_instances. Class mod_of A := mod_op : A -> A -> A. #[export] Hint Mode mod_of + : typeclass_instances. Class scale_of A B := scale_op : A -> B -> B. #[export] Hint Mode scale_of + + : typeclass_instances. Elpi derive.param2 zero_of. Elpi derive.param2 zero_op. Elpi derive.param2 one_of. Elpi derive.param2 one_op. Elpi derive.param2 opp_of. Elpi derive.param2 opp_op. Elpi derive.param2 add_of. Elpi derive.param2 add_op. Elpi derive.param2 sub_of. Elpi derive.param2 sub_op. Elpi derive.param2 mul_of. Elpi derive.param2 mul_op. Elpi derive.param2 exp_of. Elpi derive.param2 exp_op. Elpi derive.param2 div_of. Elpi derive.param2 div_op. Elpi derive.param2 inv_of. Elpi derive.param2 inv_op. Elpi derive.param2 mod_of. Elpi derive.param2 mod_op. Elpi derive.param2 scale_of. Elpi derive.param2 scale_op. Class eq_of A := eq_op : A -> A -> bool. #[export] Hint Mode eq_of + : typeclass_instances. Class leq_of A := leq_op : A -> A -> bool. #[export] Hint Mode leq_of + : typeclass_instances. Class lt_of A := lt_op : A -> A -> bool. #[export] Hint Mode lt_of + : typeclass_instances. Class size_of A N := size_op : A -> N. #[export] Hint Mode size_of + + : typeclass_instances. Elpi derive.param2 eq_of. Elpi derive.param2 eq_op. Elpi derive.param2 leq_of. Elpi derive.param2 leq_op. Elpi derive.param2 lt_of. Elpi derive.param2 lt_op. Elpi derive.param2 size_of. Elpi derive.param2 size_op. Class spec_of A B := spec : A -> B. #[export] Hint Mode spec_of + + : typeclass_instances. Definition spec_id {A : Type} : spec_of A A := id. Class implem_of A B := implem : A -> B. #[export] Hint Mode implem_of + + : typeclass_instances. Definition implem_id {A : Type} : implem_of A A := id. Class cast_of A B := cast_op : A -> B. #[export] Hint Mode cast_of + + : typeclass_instances. Elpi derive.param2 spec_of. Elpi derive.param2 spec. Elpi derive.param2 implem_of. Elpi derive.param2 implem. Elpi derive.param2 cast_of. Elpi derive.param2 cast_op. End Op. End Refinements. Import Refinements.Op. #[export] Typeclasses Transparent zero_of one_of opp_of add_of sub_of mul_of exp_of div_of inv_of mod_of scale_of size_of eq_of leq_of lt_of spec_of implem_of cast_of. Arguments spec / A B spec_of _: assert. Notation "0" := zero_op : computable_scope. Notation "1" := one_op : computable_scope. Notation "-%C" := opp_op. Notation "- x" := (opp_op x) : computable_scope. Notation "+%C" := add_op. Notation "x + y" := (add_op x y) : computable_scope. Notation "x - y" := (sub_op x y) : computable_scope. Notation "*%C" := mul_op. Notation "x * y" := (mul_op x y) : computable_scope. Notation "x ^ y" := (exp_op x y) : computable_scope. Notation "x %/ y" := (div_op x y) : computable_scope. Notation "x ^-1" := (inv_op x) : computable_scope. Notation "x %% y" := (mod_op x y) : computable_scope. Notation "*:%C" := scale_op. Notation "x *: y" := (scale_op x y) : computable_scope. Notation "x == y" := (eq_op x y) : computable_scope. Notation "x <= y" := (leq_op x y) : computable_scope. Notation "x < y" := (lt_op x y) : computable_scope. Notation cast := (@cast_op _). Ltac simpC := do ?[ rewrite -[0%C]/0%R | rewrite -[1%C]/1%R | rewrite -[(_ + _)%C]/(_ + _)%R | rewrite -[(_ + _)%C]/(_ + _)%N | rewrite -[(- _)%C]/(- _)%R | rewrite -[(_ - _)%C]/(_ - _)%R | rewrite -[(_ - _)%C]/(_ - _)%N | rewrite -[(_ * _)%C]/(_ * _)%R | rewrite -[(_ * _)%C]/(_ * _)%N | rewrite -[(_ %/ _)%C]/(_ %/ _)%R | rewrite -[(_ %% _)%C]/(_ %% _)%R | rewrite -[(_ == _)%C]/(_ == _)%bool ]. (* Section testmx. *) (* Variable mxA : nat -> nat -> Type. *) (* Definition idmx (m n : nat) (mx : mxA m n) : mxA m n := mx. *) (* End testmx. *) (* Parametricity idmx. *) (* Print idmx_R. (* Here we get something too general! *) *) (* Workaround because casts are not retained for hypothesis, so we design this elimination lemma to abstract the context and vm_compute in the goal *) Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. Tactic Notation "context" "[" ssrpatternarg(pat) "]" tactic3(tac) := let H := fresh "H" in let Q := fresh "Q" in let eqQ := fresh "eqQ" in ssrpattern pat => H; elim/abstract_context : (H) => Q eqQ; rewrite /H {H}; tac; rewrite eqQ {Q eqQ}. Class strategy_class (C : forall T, T -> T -> Prop) := StrategyClass : C = (fun T => @eq T). #[export] Hint Mode strategy_class + : typeclass_instances. Class native_compute T (x y : T) := NativeCompute : x = y. #[export] Hint Mode native_compute - + - : typeclass_instances. #[export] Hint Extern 0 (native_compute _ _) => context [(X in native_compute X)] native_compute; reflexivity : typeclass_instances. #[export] Instance strategy_class_native_compute : strategy_class native_compute := erefl. Class vm_compute T (x y : T) := VmCompute : x = y. #[export] Hint Mode vm_compute - + - : typeclass_instances. #[export] Hint Extern 0 (vm_compute _ _) => context [(X in vm_compute X)] vm_compute; reflexivity : typeclass_instances. #[export] Instance strategy_class_vm_compute : strategy_class vm_compute := erefl. Class compute T (x y : T) := Compute : x = y. #[export] Hint Mode compute - + - : typeclass_instances. #[export] Hint Extern 0 (compute _ _) => context [(X in compute X)] compute; reflexivity : typeclass_instances. #[export] Instance strategy_class_compute : strategy_class compute := erefl. Class simpl T (x y : T) := Simpl : x = y. #[export] Hint Mode simpl - + - : typeclass_instances. #[export] Hint Extern 0 (simpl _ _) => context [(X in simpl X)] simpl; reflexivity : typeclass_instances. #[export] Instance strategy_class_simpl : strategy_class simpl := erefl. Lemma coqeal_eq C {eqC : strategy_class C} {T T'} spec (x x' : T) {y y' : T'} {rxy : refines eq (spec_id x) (spec y)} {ry : C _ y y'} {rx : simpl (spec y') x'} : x = x'. Proof. by rewrite eqC in ry; rewrite -rx -ry; apply: refines_eq. Qed. Notation "'[' 'coqeal' strategy 'of' x ']'" := (@coqeal_eq strategy _ _ _ _ x _ _ _ _ _ _). Notation coqeal strategy := [coqeal strategy of _]. Notation "'[' 'coqeal' strategy 'of' x 'for' y ']'" := ([coqeal strategy of x] : y = _). Ltac coqeal := apply: refines_goal; vm_compute. Tactic Notation "coqeal_" tactic3(tac) := apply: refines_goal; tac. Tactic Notation "coqeal" "[" ssrpatternarg(pat) "]" open_constr(strategy) := let H := fresh "H" in let Q := fresh "Q" in let eqQ := fresh "eqQ" in ssrpattern pat => H; elim/abstract_context : (H) => Q eqQ; rewrite /H {H} [(X in Q X)](coqeal strategy) eqQ {Q eqQ}. Ltac refines_apply1 := eapply refines_apply; tc. Ltac refines_abstr1 := eapply refines_abstr=> ???; tc. Ltac refines_apply := do ![refines_apply1]. Ltac refines_abstr := do ![refines_abstr1]. Ltac refines_trans := eapply refines_trans; tc. (** Automation: for proving refinement lemmas involving if-then-else's do [rewrite !ifE; apply refines_if_expr]. *) Lemma refines_if_expr (A C : Type) (b1 b2 : bool) (vt1 vf1 : A) (vt2 vf2 : C) (R : A -> C -> Type) : refines bool_R b1 b2 -> (b1 -> b2 -> R vt1 vt2) -> (~~ b1 -> ~~ b2 -> R vf1 vf2) -> refines R (if_expr b1 vt1 vf1) (if_expr b2 vt2 vf2). Proof. move/refines_bool_eq/refinesP=> Hb; rewrite -!{}Hb => Ht Hf. rewrite /if_expr !refinesE; case: b1 Ht Hf => Ht Hf. exact: Ht. exact: Hf. Qed. Lemma optionE (A B : Type) (o : option A) (b : B) (f : A -> B) : match o with | Some a => f a | None => b end = oapp f b o. Proof. by []. Qed. (** Automation: for proving refinement lemmas involving options, do [rewrite !optionE; refines_apply]. *) #[export] Instance refines_option (A B : Type) (rA : A -> A -> Type) (rB : B -> B -> Type) : refines ((rA ==> rB) ==> rB ==> option_R rA ==> rB) (@oapp _ _) (@oapp _ _). Proof. rewrite refinesE => f1 f2 Hf b1 b2 Hb o1 o2 Ho. case: o1 Ho => [a1|]; case: o2 => [a2|] Ho //=. { eapply refinesP; refines_apply; rewrite refinesE in Ho *. by inversion_clear Ho. } { by eapply refinesP; inversion_clear Ho. } { by eapply refinesP; inversion_clear Ho. } Qed. coqeal-2.1.0/refinements/ring.v000066400000000000000000000207061475512565300164450ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg ssrint. From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv. From mathcomp Require Import zmodp. From CoqEAL Require Import hrel param refinements binint poly_op hpoly karatsuba. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op Poly.Op. Local Open Scope ring_scope. Ltac in_seq s t := let rec aux s := match s with | [::] => constr:(false) | (?hd :: ?tl) => match hd with | t => constr:(true) | _ => aux tl end end in aux s. Ltac freeVars t A := let rec aux t fv := match t with | 0 => fv | 1 => fv | (?t1 + ?t2) => aux t2 ltac:(aux t1 fv) | (?t1 - ?t2) => aux t2 ltac:(aux t1 fv) | (?t1 * ?t2) => aux t2 ltac:(aux t1 fv) | (- ?t) => aux t fv | ?n%:~R => fv | _ => let b := in_seq fv t in match b with | true => fv | false => constr:(t :: fv) end end in let s := aux t ([::] : seq A) in let n := (eval compute in (size s)) in constr:((s, n)). Inductive PExpr := | PEc : int -> PExpr | PEX : nat -> PExpr | PEadd : PExpr -> PExpr -> PExpr | PEmul : PExpr -> PExpr -> PExpr | PEopp : PExpr -> PExpr | PEpow : PExpr -> nat -> PExpr. Definition poly_comRingType (R : comRingType) : comRingType := [the comRingType of {poly R}]. Definition Npoly (R : comRingType) : nat -> comRingType := fix aux n := if n is n.+1 then poly_comRingType (aux n) else R. Fixpoint NpolyC (R : comRingType) N : R -> Npoly R N := if N isn't N'.+1 return R -> Npoly R N then fun x => x else fun x => (NpolyC N' x)%:P. Fixpoint NpolyX (R : comRingType) N : nat -> Npoly R N := if N isn't N'.+1 return nat -> Npoly R N then fun=> 0 else fun n => if n is n.+1 then (NpolyX R N' n)%:P else 'X. Fixpoint Nmap_poly (R R' : comRingType) (f : R -> R') N : Npoly R N -> Npoly R' N := if N isn't N'.+1 return Npoly R N -> Npoly R' N then f else map_poly (@Nmap_poly _ _ f N'). Section Nmap_poly_morphism. Variable R R' : comRingType. Variable g : {additive R -> R'}. Variable f : {rmorphism R -> R'}. Variable N : nat. Fact Nmap_poly_is_additive : additive (Nmap_poly g (N:=N)). Proof. elim: N=> [|N' IHN] /=. exact: raddfB. exact: map_poly_is_additive (Additive IHN). Qed. Canonical Nmap_poly_additive := Additive Nmap_poly_is_additive. Fact Nmap_poly_is_rmorphism : rmorphism (Nmap_poly f (N:=N)). Proof. elim: N=> [|N' IHN] /=. exact: rmorphismP. exact: map_poly_is_rmorphism (RMorphism IHN). Qed. Canonical Nmap_poly_rmorphism := RMorphism Nmap_poly_is_rmorphism. End Nmap_poly_morphism. Fact horner_key : unit. Proof. exact: tt. Qed. Fixpoint NhornerR (R : comRingType) N : seq R -> Npoly R N -> R := if N isn't N'.+1 return seq R -> Npoly R N -> R then fun _ p => p else fun env p => if env is a :: env then NhornerR env p.[NpolyC N' a] else NhornerR [::] p.[0]. Lemma NhornerRS (R : comRingType) N (a : R) (env : seq R) (p : Npoly R N.+1) : NhornerR (a :: env) p = NhornerR env p.[NpolyC N a]. Proof. by elim: N p. Qed. Definition Nhorner (R : comRingType) N (env : seq R) (p : Npoly [comRingType of int] N) : R := locked_with horner_key (@NhornerR _ _) env (Nmap_poly intr p). Lemma NhornerE (R : comRingType) N (env : seq R) (p : Npoly [comRingType of int] N) : Nhorner env p = (@NhornerR _ _) env (Nmap_poly intr p). Proof. by rewrite /Nhorner; case: horner_key. Qed. Definition PExpr_to_poly N : PExpr -> Npoly [comRingType of int] N := fix aux p := match p with | PEc n => n%:~R | PEX n => NpolyX _ N n | PEadd p q => aux p + aux q | PEmul p q => aux p * aux q | PEopp p => - aux p | PEpow p n => aux p ^+ n end. Definition PExpr_to_Expr (R : comRingType) (env : seq R) : PExpr -> R := fix aux p := match p with | PEc n => n%:~R | PEX n => env`_n | PEadd p q => aux p + aux q | PEmul p q => aux p * aux q | PEopp p => - aux p | PEpow p n => aux p ^+ n end. Lemma NhornerRC (R : comRingType) N (env : seq R) (a : R) : NhornerR env (NpolyC N a) = a. Proof. by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC. Qed. Lemma Nhorner_is_rmorphism (R : comRingType) (N : nat) (env : seq R) : rmorphism (@NhornerR R N env). Proof. do !split. - by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerD hornerN IHN. - by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerM IHN. by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC. Qed. Canonical Nhorner_rmorphism (R : comRingType) (N : nat) (env : seq R) := RMorphism (Nhorner_is_rmorphism N env). Lemma polyficationP (R : comRingType) (env : seq R) N p : size env == N -> PExpr_to_Expr env p = Nhorner env (PExpr_to_poly N p). Proof. elim: p=> [n|n|p IHp q IHq|p IHp q IHq|p IHp|p IHp n] /=. - by rewrite NhornerE !rmorph_int. - rewrite NhornerE; elim: N env n=> [|N IHN] [|a env] [|n] //= senv. by rewrite map_polyX hornerX [RHS]NhornerRC. by rewrite map_polyC hornerC !IHN. - by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphD. - by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphM. - by move=> senv; rewrite (IHp senv) !NhornerE !rmorphN. - by move=> senv; rewrite (IHp senv) !NhornerE !rmorphX. Qed. Ltac getIndex t fv := let rec aux s n := match s with | (?hd :: ?tl) => match hd with | t => eval compute in n | _ => aux tl uconstr:(n.+1) end | _ => fail "Not found" end in aux fv O. Ltac toPExpr t fv N := let rec aux t := match t with | 0 => uconstr:(PEc 0) | 1 => uconstr:(PEc 1) | (?t1 + ?t2) => let e1 := aux t1 in let e2 := aux t2 in uconstr:(PEadd e1 e2) | (?t1 * ?t2) => let e1 := aux t1 in let e2 := aux t2 in uconstr:(PEmul e1 e2) | (- ?t) => let e := aux t in uconstr:(PEopp e) | ?n%:~R => uconstr:(PEc n) | _ => let n := getIndex t fv in uconstr:(PEX n) end in let e := aux t in constr:(e : PExpr). Tactic Notation (at level 0) "translate" constr(t) := let A := type of t in let c := freeVars t A in let fv := (eval simpl in (c.1)) in let n := (eval simpl in (c.2)) in let p := toPExpr t fv n in have /= := @polyficationP _ fv n p isT. Tactic Notation "polyfication" := match goal with | |- (eq ?lhs ?rhs) => let A := type of lhs in let c := freeVars (lhs + rhs) A in let fv := (eval simpl in (c.1)) in let n := (eval simpl in (c.2)) in let pl := toPExpr lhs fv n in let pr := toPExpr rhs fv n in let rwl := fresh "rwl" in let rwr := fresh "rwr" in have /= rwl := @polyficationP _ fv n pl isT; rewrite [LHS]rwl {rwl}; have /= rwr := @polyficationP _ fv n pr isT; rewrite [RHS]rwr {rwr} | _ => fail "goal not an equation" end. Tactic Notation "depolyfication" := rewrite NhornerE /NhornerR /=; do ?[rewrite ?(rmorph0, rmorphN, rmorphD, rmorphB, rmorph1, rmorphM, rmorphX, map_polyC, map_polyX, map_polyZ) /=]; rewrite ?hornerE. Tactic Notation "coqeal_vm_compute_eq2" := do 1?coqeal [(X in Nhorner _ X = _)%pattern] vm_compute; do 1?coqeal [(X in _ = Nhorner _ X)%pattern] vm_compute. Tactic Notation "coqeal_ring" := by polyfication; coqeal_vm_compute_eq2; depolyfication. Goal true. assert (h1 := [coqeal vm_compute of - (1 + 'X%:P * 'X) : {poly {poly int}}]). assert (h2 := [coqeal vm_compute of (1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int})))]). assert (h3 := [coqeal vm_compute of 1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (3%:Z *: 'X^2 + 1 + 2%:Z%:P * 'X)]). assert (h4 := [coqeal vm_compute of 'X + 'X^2 * 'X%:P : {poly {poly int}}]). have (a b c : int) : a * (b + c) = a * b + a * c. Time by coqeal_ring. move=> _. have (a b c : {poly int}) : (b + c) * a = b * a + c * a. Time by coqeal_ring. move=> _. have (a : {poly int}) : a * 0 = 0. Time by coqeal_ring. move=> _. have (a : Zp_ringType 7) : 0 = a * 0. Time by coqeal_ring. move=> _. have (a : {poly {poly {poly int}}}) : a * 0 = 0. Time by coqeal_ring. move=> _. have (R : comRingType) (a b c : R) : a + b - (1 * b + c * 0) = a. Time by coqeal_ring. move=> _. by[]. Qed. coqeal-2.1.0/refinements/seqmx.v000066400000000000000000001606461475512565300166530ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. From mathcomp Require Import path choice fintype tuple finset bigop poly matrix mxpoly. From CoqEAL Require Import hrel param refinements trivial_seq. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Import Refinements.Op. Local Open Scope ring_scope. Declare Scope hetero_computable_scope. Delimit Scope hetero_computable_scope with HC. Section classes. Class hzero_of I B := hzero_op : forall m n : I, B m n. Local Notation "0" := hzero_op : hetero_computable_scope. Class hmul_of I B := hmul_op : forall m n p : I, B m n -> B n p -> B m p. Local Notation "*m%HC" := hmul_op. Local Notation "x *m y" := (hmul_op x y) : hetero_computable_scope. (* Class hopp I B := hopp_op : forall m n : I, B m n -> B m n. *) (* Local Notation "- x" := (hopp_op x) : hetero_computable_scope. *) Class heq_of I B := heq_op : forall m n : I, B m n -> B m n -> bool. Local Notation "x == y" := (heq_op x y) : hetero_computable_scope. Local Open Scope nat_scope. (* TODO: Remove this and get a better way for extracting elements *) Class top_left_of A B := top_left_op : A -> B. Class usubmx_of B := usubmx_op : forall (m1 m2 n : nat), B (m1 + m2) n -> B m1 n. Class dsubmx_of B := dsubmx_op : forall (m1 m2 n : nat), B (m1 + m2) n -> B m2 n. Class lsubmx_of B := lsubmx_op : forall (m n1 n2 : nat), B m (n1 + n2) -> B m n1. Class rsubmx_of B := rsubmx_op : forall (m n1 n2 : nat), B m (n1 + n2) -> B m n2. Class ulsubmx_of B := ulsubmx_op : forall (m1 m2 n1 n2 : nat), B (m1 + m2) (n1 + n2) -> B m1 n1. Class ursubmx_of B := ursubmx_op : forall (m1 m2 n1 n2 : nat), B (m1 + m2) (n1 + n2) -> B m1 n2. Class dlsubmx_of B := dlsubmx_op : forall (m1 m2 n1 n2 : nat), B (m1 + m2) (n1 + n2) -> B m2 n1. Class drsubmx_of B := drsubmx_op : forall (m1 m2 n1 n2 : nat), B (m1 + m2) (n1 + n2) -> B m2 n2. Class row_mx_of B := row_mx_op : forall (m n1 n2 : nat), B m n1 -> B m n2 -> B m (n1 + n2). Class col_mx_of B := col_mx_op : forall (m1 m2 n : nat), B m1 n -> B m2 n -> B (m1 + m2) n. Class block_mx_of B := block_mx_op : forall (m1 m2 n1 n2 : nat), B m1 n1 -> B m1 n2 -> B m2 n1 -> B m2 n2 -> B (m1 + m2) (n1 + n2). Class const_mx_of A B := const_mx_op : forall (m n : nat), A -> B m n. Class map_mx_of A B C D := map_mx_op : (A -> B) -> C -> D. End classes. #[export] Typeclasses Transparent hzero_of hmul_of heq_of top_left_of usubmx_of dsubmx_of lsubmx_of rsubmx_of ulsubmx_of ursubmx_of dlsubmx_of drsubmx_of row_mx_of col_mx_of block_mx_of const_mx_of map_mx_of. Notation "0" := hzero_op : hetero_computable_scope. (* Notation "- x" := (hopp_op x) : hetero_computable_scope. *) Notation "x == y" := (heq_op x y) : hetero_computable_scope. Notation "*m%HC" := hmul_op. Notation "x *m y" := (hmul_op x y) : hetero_computable_scope. Section extra_seq. Variables (T1 T2 T3 : Type) (f : T1 -> T2 -> T3). Fixpoint zipwith (s1 : seq T1) (s2 : seq T2) := if s1 is x1 :: s1' then if s2 is x2 :: s2' then f x1 x2 :: zipwith s1' s2' else [::] else [::]. Lemma zipwithE s1 s2 : zipwith s1 s2 = [seq f x.1 x.2 | x <- zip s1 s2]. Proof. by elim: s1 s2 => [|x1 s1 ihs1] [|x2 s2] //=; rewrite ihs1. Qed. Fixpoint foldl2 (f : T3 -> T1 -> T2 -> T3) z (s : seq T1) (t : seq T2) := if s is x :: s' then if t is y :: t' then foldl2 f (f z x y) s' t' else z else z. End extra_seq. Elpi derive.param2 zipwith. Elpi derive.param2 foldl2. Section seqmx_op. Variable A B : Type. Variable I : nat -> Type. Definition seqmx {A} := seq (seq A). Definition hseqmx {A} := fun (_ _ : nat) => @seqmx A. Context `{zero_of A, one_of A, add_of A, opp_of A, mul_of A, eq_of A}. Context `{forall n, implem_of 'I_n (I n)}. Definition ord_enum_eq n : seq 'I_n := pmap (insub_eq _) (iota 0 n). Definition seqmx_of_fun m n (f : I m -> I n -> A) : hseqmx m n := let enum_n := map implem (ord_enum_eq n) in let enum_m := map implem (ord_enum_eq m) in map (fun i => map (f i) enum_n) enum_m. Definition mkseqmx_ord m n (f : 'I_m -> 'I_n -> A) : seqmx := let enum_n := ord_enum_eq n in map (fun i => map (f i) enum_n) (ord_enum_eq m). #[export] Instance const_seqmx : const_mx_of A hseqmx := fun m n (x : A) => nseq m (nseq n x). #[export] Instance map_seqmx : map_mx_of A B seqmx seqmx := fun (f : A -> B) (M : seqmx) => map (map f) M. Definition zipwith_seqmx (f : A -> A -> A) (M N : seqmx) := zipwith (zipwith f) M N. #[export] Instance seqmx0 : hzero_of hseqmx := fun m n => const_seqmx m n 0%C. Definition diag_seqmx (s : seqmx) := mkseqmx_ord (fun (i j : 'I_(size (nth [::] s 0))) => (if i == j then nth 0%C (nth [::] s 0) i else 0%C)). Definition scalar_seqmx m (x : A) := diag_seqmx (const_seqmx 1%N m x). #[export] Instance seqmx1 m : one_of seqmx := scalar_seqmx m 1%C. #[export] Instance opp_seqmx : opp_of (@seqmx A) := map (map -%C). #[export] Instance add_seqmx : add_of seqmx := zipwith_seqmx +%C. (* TODO: Implement better *) #[export] Instance sub_seqmx : sub_of (@seqmx A) := fun a b => (a + - b)%C. Definition trseqmx m n (M : @hseqmx A m n) := if eqn m 0 then nseq n [::] else foldr (zipwith cons) (nseq n [::]) M. #[export] Instance mul_seqmx : @hmul_of nat hseqmx := fun _ n p M N => let N := trseqmx N in if n is O then seqmx0 (size M) p else map (fun r => map (foldl2 (fun z x y => (x * y) + z) 0 r)%C N) M. #[export] Instance scale_seqmx : scale_of A seqmx := fun x M => map (map (mul_op x)) M. (* Inlining of && should provide lazyness here. *) Fixpoint eq_seq T f (s1 s2 : seq T) := match s1, s2 with | [::], [::] => true | x1 :: s1', x2 :: s2' => f x1 x2 && eq_seq f s1' s2' | _, _ => false end. #[export] Instance eq_seqmx : eq_of (@seqmx A) := eq_seq (eq_seq eq_op). #[export] Instance top_left_seqmx : top_left_of seqmx A := fun (M : seqmx) => nth 0%C (nth [::] M 0) 0. #[export] Instance usubseqmx : usubmx_of hseqmx := fun m1 m2 n (M : @seqmx A) => take m1 M. #[export] Instance dsubseqmx : dsubmx_of hseqmx := fun m1 m2 n (M : @seqmx A) => drop m1 M. #[export] Instance lsubseqmx : lsubmx_of hseqmx := fun m n1 n2 (M : @seqmx A) => map (take n1) M. #[export] Instance rsubseqmx : rsubmx_of hseqmx := fun m n1 n2 (M : @seqmx A) => map (drop n1) M. #[export] Instance ulsubseqmx : ulsubmx_of hseqmx := fun m1 m2 n1 n2 (M : hseqmx (m1 + m2)%N (n1 + n2)%N) => lsubseqmx (usubseqmx M). #[export] Instance ursubseqmx : ursubmx_of hseqmx := fun m1 m2 n1 n2 (M : hseqmx (m1 + m2)%N (n1 + n2)%N) => rsubseqmx (usubseqmx M). #[export] Instance dlsubseqmx : dlsubmx_of hseqmx := fun m1 m2 n1 n2 (M : hseqmx (m1 + m2)%N (n1 + n2)%N) => lsubseqmx (dsubseqmx M). #[export] Instance drsubseqmx : drsubmx_of hseqmx := fun m1 m2 n1 n2 (M : hseqmx (m1 + m2)%N (n1 + n2)%N) => rsubseqmx (dsubseqmx M). #[export] Instance row_seqmx : row_mx_of hseqmx := fun m n1 n2 (M N : @seqmx A) => zipwith cat M N. #[export] Instance col_seqmx : col_mx_of hseqmx := fun m1 m2 n (M N : @seqmx A) => M ++ N. #[export] Instance block_seqmx : block_mx_of hseqmx := fun m1 m2 n1 n2 Aul Aur Adl Adr => col_seqmx (row_seqmx Aul Aur) (row_seqmx Adl Adr). Definition delta_seqmx m n i j : hseqmx m n := mkseqmx_ord (fun (i0 : 'I_m) (j0 : 'I_n) => if (eqn i0 i) && (eqn j0 j) then 1%C else 0%C). Fixpoint trace_seqmx m (s : hseqmx m m) := match m with | O => 0%C | (S n) => (top_left_seqmx s + @trace_seqmx n (@drsubseqmx 1%N n 1%N n s))%C end. Definition pid_seqmx m n r := mkseqmx_ord (fun (i : 'I_m) (j : 'I_n) => if (eqn i j) && (i < r) then 1%C else 0%C). Definition copid_seqmx m r := (seqmx1 m - pid_seqmx m m r)%C. End seqmx_op. Elpi derive.param2 seqmx. Elpi derive.param2 hseqmx. Definition ord_enum_eqn := Eval cbv in ord_enum_eq. Elpi derive.param2 ord_enum_eqn. Elpi derive.param2.register ord_enum_eq ord_enum_eqn_R. Elpi derive.param2 seqmx_of_fun. Elpi derive.param2 mkseqmx_ord. Elpi derive.param2 const_mx_of. Elpi derive.param2 const_seqmx. Elpi derive.param2 map_mx_of. Elpi derive.param2 map_seqmx. Elpi derive.param2 zipwith_seqmx. Elpi derive.param2 hzero_of. Elpi derive.param2 seqmx0. Definition diag_seqmx_simpl := Eval cbv in diag_seqmx. Elpi derive.param2 diag_seqmx_simpl. Definition diag_seqmx_R := diag_seqmx_simpl_R. Elpi derive.param2.register diag_seqmx diag_seqmx_R. Elpi derive.param2 scalar_seqmx. Elpi derive.param2 seqmx1. Elpi derive.param2 opp_seqmx. Elpi derive.param2 add_seqmx. Elpi derive.param2 sub_seqmx. Elpi derive.param2 trseqmx. Elpi derive.param2 hmul_of. Elpi derive.param2 mul_seqmx. Elpi derive.param2 scale_seqmx. Elpi derive.param2 eq_seq. Elpi derive.param2 eq_seqmx. Elpi derive.param2 top_left_of. Elpi derive.param2 top_left_seqmx. Elpi derive.param2 usubmx_of. Elpi derive.param2 usubseqmx. Elpi derive.param2 dsubmx_of. Elpi derive.param2 dsubseqmx. Elpi derive.param2 lsubmx_of. Elpi derive.param2 lsubseqmx. Elpi derive.param2 rsubmx_of. Elpi derive.param2 rsubseqmx. Elpi derive.param2 ulsubmx_of. Elpi derive.param2 ulsubseqmx. Elpi derive.param2 ursubmx_of. Elpi derive.param2 ursubseqmx. Elpi derive.param2 dlsubmx_of. Elpi derive.param2 dlsubseqmx. Elpi derive.param2 drsubmx_of. Elpi derive.param2 drsubseqmx. Elpi derive.param2 row_mx_of. Elpi derive.param2 row_seqmx. Elpi derive.param2 col_mx_of. Elpi derive.param2 col_seqmx. Elpi derive.param2 block_mx_of. Elpi derive.param2 block_seqmx. Elpi derive.param2 mkseqmx_ord. Elpi derive.param2 nat_of_ord. Elpi derive.param2 delta_seqmx. Elpi derive.param2 trace_seqmx. Elpi derive.param2 pid_seqmx. Elpi derive.param2 pid_seqmx. Elpi derive.param2 copid_seqmx. Section seqmx_more_op. Variable R : Type. Context `{zero_of R}. Context (C : Type). Context `{spec_of C R}. #[export] Instance spec_seqmx m n : spec_of (@seqmx C) 'M[R]_(m, n) := fun s => \matrix_(i, j) nth 0%C (nth [::] (map_seqmx spec s) i) j. End seqmx_more_op. Arguments spec_seqmx / _ _ _ _ _ _ _ : assert. Section seqmx_theory. Section seqmx. Variable R : Type. Context `{zero_of R, one_of R, opp_of R, add_of R, mul_of R, eq_of R}. Local Instance specR : spec_of R R := spec_id. Local Instance implem_ord : forall n, (implem_of 'I_n 'I_n) := fun _ => implem_id. Local Open Scope rel_scope. Variant Rseqmx {m1 m2} (rm : nat_R m1 m2) {n1 n2} (rn : nat_R n1 n2) : 'M[R]_(m1,n1) -> hseqmx m2 n2 -> Type := Rseqmx_spec (A : 'M[R]_(m1, n1)) M of size M = m2 & forall i, i < m2 -> size (nth [::] M i) = n2 & (forall i j, (A i j = nth 0%C (nth [::] M i) j)) : Rseqmx A M. (* Definition Rord n (i : 'I_n) j := i = j :> nat. *) Lemma ord_enum_eqE p : ord_enum_eq p = enum 'I_p. Proof. by rewrite enumT unlock; apply:eq_pmap ; exact:insub_eqE. Qed. Instance Rseqmx_seqmx_of_fun m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) f g : refines (eq ==> eq ==> eq) f g -> refines (Rseqmx rm rn) (\matrix_(i, j) f i j) (seqmx_of_fun (I:=(fun n => 'I_n)) g). Proof. move=> h. rewrite refinesE; constructor; rewrite -?(nat_R_eq rm) -?(nat_R_eq rn). by rewrite !size_map ord_enum_eqE size_enum_ord. move=> i ltim. by rewrite (nth_map (Ordinal ltim)) !size_map ord_enum_eqE size_enum_ord. move=> i j. rewrite mxE /seqmx_of_fun !ord_enum_eqE /implem /implem_ord /implem_id. rewrite !map_id (nth_map i) ?size_enum_ord // nth_ord_enum. rewrite (nth_map j) ?size_enum_ord // nth_ord_enum. apply refinesP; eapply refines_apply. eapply refines_apply; tc. by rewrite refinesE. by rewrite refinesE. Qed. Instance Rseqmx_mkseqmx_ord m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (eq ==> Rseqmx rm rn) (matrix_of_fun matrix_key) (@mkseqmx_ord R m1 n1). Proof. rewrite refinesE=> _ M ->; constructor; rewrite -?(nat_R_eq rm) -?(nat_R_eq rn). by rewrite size_map ord_enum_eqE size_enum_ord. move=> i ltim. rewrite (nth_map (Ordinal ltim)) ?ord_enum_eqE ?size_enum_ord // size_map. by rewrite size_enum_ord. move=> i j. by rewrite mxE (nth_map i) ?ord_enum_eqE ?size_enum_ord // (nth_map j) ?size_enum_ord // !nth_ord_enum. Qed. Instance Rseqmx_const_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (eq ==> Rseqmx rm rn) matrix.const_mx (const_seqmx m2 n2). Proof. rewrite refinesE=> _ x ->; constructor=> [|i ltim|i j]. by rewrite size_nseq. by rewrite nth_nseq ltim size_nseq. by rewrite -(nat_R_eq rm) -(nat_R_eq rn); do 2 (rewrite nth_nseq ltn_ord); rewrite mxE. Qed. Instance Rseqmx_0 m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm rn) (const_mx 0%C) (seqmx0 m2 n2). Proof. rewrite refinesE; constructor=>[|i|i j]; first by rewrite size_nseq. by rewrite nth_nseq => ->; rewrite size_nseq. by rewrite mxE nth_nseq -(nat_R_eq rm) ltn_ord nth_nseq -(nat_R_eq rn) ltn_ord. Qed. Instance Rseqmx_top_left_seqmx m1 m2 (rm : nat_R m1 m2) : refines (Rseqmx (S_R rm) (S_R rm) ==> eq) (fun M => M ord0 ord0) top_left_op. Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. by rewrite /top_left_op /top_left_seqmx h3. Qed. Lemma if_add_eq m n : (if m < m + n then m else (m + n)%N) = m. Proof. case: n=> [|?]; first by rewrite addn0 ltnn. by rewrite ifT // -addn1 leq_add. Qed. Instance Rseqmx_usubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (addn_R rm1 rm2) rn ==> Rseqmx rm1 rn) (@matrix.usubmx R m11 m21 n1) (@usubseqmx R m12 m22 n2). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /usubseqmx. by rewrite size_take h1 if_add_eq. by rewrite nth_take ?h2 ?ltn_addr. by rewrite mxE nth_take ?h3 -?(nat_R_eq rm1). Qed. Instance Rseqmx_dsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (addn_R rm1 rm2) rn ==> Rseqmx rm2 rn) (@matrix.dsubmx R m11 m21 n1) (@dsubseqmx R m12 m22 n2). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /dsubseqmx. by rewrite size_drop h1 addnC -addnBA ?subnn ?addn0. by rewrite nth_drop h2 ?ltn_add2l. by rewrite mxE nth_drop h3 (nat_R_eq rm1). Qed. Instance Rseqmx_lsubseqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx rm (addn_R rn1 rn2) ==> Rseqmx rm rn1) (@matrix.lsubmx R m1 n11 n21) (@lsubseqmx R m2 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim|i j]; rewrite /lsubseqmx. by rewrite size_map. by rewrite (nth_map [::]) ?size_take ?h1 ?h2 // if_add_eq. by rewrite mxE h3 (nth_map [::]) ?nth_take ?h1 -?(nat_R_eq rn1) -?(nat_R_eq rm). Qed. Instance Rseqmx_rsubseqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx rm (addn_R rn1 rn2) ==> Rseqmx rm rn2) (@matrix.rsubmx R m1 n11 n21) (@rsubseqmx R m2 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim|i j]; rewrite /rsubseqmx. by rewrite size_map. by rewrite (nth_map [::]) ?size_drop ?h1 ?h2 // addnC -addnBA ?subnn ?addn0. by rewrite mxE h3 (nth_map [::]) ?nth_drop ?h1 -?(nat_R_eq rm) ?(nat_R_eq rn1). Qed. Instance Rseqmx_ulsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx (addn_R rm1 rm2) (addn_R rn1 rn2) ==> Rseqmx rm1 rn1) (@matrix.ulsubmx R m11 m21 n11 n21) (@ulsubseqmx R m12 m22 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /ulsubseqmx /lsubseqmx /usubseqmx. by rewrite size_map size_take h1 if_add_eq. by rewrite (nth_map [::]) size_take ?nth_take ?h1 ?h2 ?if_add_eq ?ltn_addr. by rewrite !mxE h3 (nth_map [::]) ?size_take ?h1 ?if_add_eq ?nth_take -?(nat_R_eq rm1) -?(nat_R_eq rn1). Qed. Instance Rseqmx_ursubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx (addn_R rm1 rm2) (addn_R rn1 rn2) ==> Rseqmx rm1 rn2) (@matrix.ursubmx R m11 m21 n11 n21) (@ursubseqmx R m12 m22 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /ursubseqmx /rsubseqmx /usubseqmx. by rewrite size_map size_take h1 if_add_eq. by rewrite (nth_map [::]) ?size_take ?size_drop ?nth_take ?h1 ?h2 ?if_add_eq ?ltn_addr // addnC -addnBA ?subnn ?addn0. by rewrite !mxE h3 (nth_map [::]) ?nth_drop ?size_take ?nth_take ?h1 ?if_add_eq -?(nat_R_eq rm1) ?(nat_R_eq rn1). Qed. Instance Rseqmx_dlsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx (addn_R rm1 rm2) (addn_R rn1 rn2) ==> Rseqmx rm2 rn1) (@matrix.dlsubmx R m11 m21 n11 n21) (@dlsubseqmx R m12 m22 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /dlsubseqmx /lsubseqmx /dsubseqmx. by rewrite size_map size_drop h1 addnC -addnBA ?subnn ?addn0. by rewrite (nth_map [::]) ?size_take ?nth_drop ?size_drop ?h1 ?h2 ?if_add_eq ?ltn_add2l // addnC -addnBA ?subnn ?addn0. by rewrite !mxE h3 (nth_map [::]) ?nth_take ?nth_drop ?size_drop ?h1 -?(nat_R_eq rn1) -?(nat_R_eq rm1) // -(nat_R_eq rm2) addnC -addnBA ?subnn ?addn0. Qed. Instance Rseqmx_drsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx (addn_R rm1 rm2) (addn_R rn1 rn2) ==> Rseqmx rm2 rn2) (@matrix.drsubmx R m11 m21 n11 n21) (@drsubseqmx R m12 m22 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim12|i j]; rewrite /drsubseqmx /rsubseqmx /dsubseqmx. by rewrite size_map size_drop h1 addnC -addnBA ?subnn ?addn0. by rewrite (nth_map [::]) size_drop ?nth_drop ?h1 ?h2 ?ltn_add2l // addnC -addnBA ?subnn ?addn0. by rewrite !mxE h3 (nth_map [::]) ?nth_drop ?size_drop ?h1 -?(nat_R_eq rm1) -?(nat_R_eq rn1) // addnC -addnBA ?subnn ?addn0 -?(nat_R_eq rm2). Qed. Instance Rseqmx_row_seqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx rm rn1 ==> Rseqmx rm rn2 ==> Rseqmx rm (addn_R rn1 rn2)) (@matrix.row_mx R m1 n11 n21) (@row_seqmx R m2 n12 n22). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. constructor=> [|i ltim|i j]; rewrite /row_seqmx zipwithE. by rewrite size_map size1_zip h1 ?h'1. by rewrite (nth_map ([::], [::])) ?nth_zip /= ?size_cat ?size1_zip ?h1 ?h'1 ?h2 ?h'2. rewrite mxE (nth_map ([::], [::])) ?nth_zip /= ?nth_cat ?size1_zip ?h1 ?h'1 ?h2 ?h'2 //. case: (splitP j)=> k hk; rewrite ?(h3, h'3) hk -?(nat_R_eq rn1). by rewrite ltn_ord. rewrite ifN; first by rewrite addnC -addnBA ?subnn ?addn0. by rewrite ltnNge leq_addr. by rewrite -(nat_R_eq rm). by rewrite -(nat_R_eq rm). Qed. Instance Rseqmx_col_seqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm1 rn ==> Rseqmx rm2 rn ==> Rseqmx (addn_R rm1 rm2) rn) (@matrix.col_mx R m11 m21 n1) (@col_seqmx R m12 m22 n2). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. constructor=> [|i ltim12|i j]; rewrite /col_seqmx. by rewrite size_cat h1 h'1. rewrite nth_cat h1 -(nat_R_eq rm1); case: (ltnP i m11)=> [ltim1|leqm1i]; rewrite ?(h2, h'2) -?(nat_R_eq rm1) //. by rewrite -subn_gt0 subnBA // addnC subn_gt0 (nat_R_eq rm1). rewrite mxE nth_cat h1. case: (splitP i)=> k hk; rewrite ?(h3, h'3) hk -(nat_R_eq rm1). by rewrite ltn_ord. rewrite ifN; last by rewrite ltnNge leq_addr. by rewrite addnC -addnBA ?subnn ?addn0. Qed. Instance Rseqmx_block_seqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (Rseqmx rm1 rn1 ==> Rseqmx rm1 rn2 ==> Rseqmx rm2 rn1 ==> Rseqmx rm2 rn2 ==> Rseqmx (addn_R rm1 rm2) (addn_R rn1 rn2)) (@matrix.block_mx R m11 m21 n11 n21) (@block_seqmx R m12 m22 n12 n22). Proof. rewrite refinesE=> _ _ [M1 sM1 h11 h21 h31] _ _ [M2 sM2 h12 h22 h32] _ _ [M3 sM3 h13 h23 h33] _ _ [M4 sM4 h14 h24 h34]. constructor=> [|i ltim12|i j]; rewrite /block_seqmx /col_seqmx /row_seqmx. by rewrite !zipwithE size_cat !size_map !size1_zip ?h11 ?h12 ?h13 ?h14. rewrite !zipwithE nth_cat size_map size1_zip ?h11 ?h12 // -(nat_R_eq rm1). case: (ltnP i m11)=> [ltim1|leqm1i]; by rewrite (nth_map ([::], [::])) ?nth_zip /= ?size1_zip ?size_cat ?(h11, h13) ?(h12, h14) ?(h21, h23) ?(h22, h24) -?(nat_R_eq rm1) // -subn_gt0 subnBA // addnC subn_gt0 (nat_R_eq rm1). rewrite mxE !zipwithE nth_cat size_map size1_zip h11 ?h12 // -(nat_R_eq rm1). case: (splitP i)=> k hk; rewrite (nth_map ([::], [::])) ?nth_zip ?size1_zip ?(h11, h13) ?(h12, h14) ?hk -?(nat_R_eq rm1) //= ?nth_cat ?(h21, h23) -?(nat_R_eq rm1) // ?mxE; case: (splitP j)=> l hl; rewrite ?(h31, h33) ?(h32, h34) ?hl -?(nat_R_eq rn1) ?ltn_ord // addnC -?[in _ < _]addnBA ?subnn ?addn0 -?(nat_R_eq rm2) // ?ifN ?ltnNge ?leq_addl //. by rewrite -addnBA ?subnn ?addn0. by rewrite -addnBA ?subnn ?addn0. by rewrite addnC -addnBA ?subnn ?addn0 -?addnBA ?subnn ?addn0. Qed. Lemma minSS (p q : nat) : minn p.+1 q.+1 = (minn p q).+1. Proof. by rewrite /minn ltnS; case:ifP. Qed. Lemma size_fold (s : seq (seq R)) k (hs : forall i : nat, i < size s -> size (nth [::] s i) = k) : size (foldr (zipwith cons) (nseq k [::]) s) = k. Proof. elim: s hs=> [_|a s ihs hs] /=; first by rewrite size_nseq. rewrite zipwithE size_map size1_zip ?ihs; have /= ha := hs 0%N; rewrite ?ha //. by move=> q hq; rewrite -(hs q.+1). Qed. Lemma size_nth_fold (s : seq (seq R)) j k (ltkj : k < j) (hs : forall l : nat, l < size s -> size (nth [::] s l) = j) : size (nth [::] (foldr (zipwith cons) (nseq j [::]) s) k) = size s. Proof. elim: s hs=> [_|a s ihs hs] /=. by rewrite nth_nseq if_same. rewrite zipwithE (nth_map (0%C, [::])) ?nth_zip /= ?ihs // ?size1_zip ?size_fold; have /= ha := hs 0%N; rewrite ?ha //; by move=> l hl; rewrite -(hs l.+1). Qed. Lemma nth_fold (s : seq (seq R)) j k l (ltks : k < size s) (ltlj : l < j) (hs : forall l : nat, l < size s -> size (nth [::] s l) = j) : nth 0%C (nth [::] (foldr (zipwith cons) (nseq j [::]) s) l) k = nth 0%C (nth [::] s k) l. Proof. elim: s k ltks hs=> [_ _ _|a s ihs k ltks hs] //=. rewrite zipwithE (nth_map (0%C, [::])) ?nth_zip /= ?size1_zip ?size_fold; have /= ha := hs 0%N; rewrite ?ha //; first (case: k ltks=> [|k' ltk's] //=; rewrite ?ihs //); by move=> q hq; rewrite -(hs q.+1). Qed. Instance Rseqmx_trseqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm rn ==> Rseqmx rn rm) trmx (@trseqmx R m2 n2). Proof. rewrite /trseqmx. case: rm=> [|k1 k2 rk] /=; rewrite refinesE=> _ _ [M sM h1 h2 h3]; constructor=> [|i ltim|i j]. by rewrite size_nseq. by rewrite nth_nseq ltim. by rewrite -(nat_R_eq rn) nth_nseq ltn_ord mxE h3 (size0nil h1) !nth_nil. by rewrite size_fold ?h1. by rewrite size_nth_fold ?h1. by rewrite mxE h3 nth_fold ?h1 // -?(nat_R_eq rn) -?(nat_R_eq rk). Qed. Section seqmx_param. Context (C : Type) (rAC : R -> C -> Type). Context (I : nat -> Type) (rI : forall n1 n2, nat_R n1 n2 -> 'I_n1 -> I n2 -> Type). Context `{zero_of C, one_of C, opp_of C, add_of C, mul_of C, eq_of C}. Context `{spec_of C R}. Context `{forall n, implem_of 'I_n (I n)}. Context `{!refines rAC 0%C 0%C, !refines rAC 1%C 1%C}. Context `{!refines (rAC ==> rAC) -%C -%C}. Context `{!refines (rAC ==> rAC ==> rAC) +%C +%C}. Context `{!refines (rAC ==> rAC ==> rAC) *%C *%C}. Context `{!refines (rAC ==> rAC ==> bool_R) eq_op eq_op}. Context `{!refines (rAC ==> Logic.eq) spec_id spec}. Context `{forall n1 n2 (rn : nat_R n1 n2), refines (ordinal_R rn ==> rI rn) implem_id implem}. Definition RseqmxC {m1 m2} (rm : nat_R m1 m2) {n1 n2} (rn : nat_R n1 n2) : 'M[R]_(m1, n1) -> hseqmx m2 n2 -> Type := (Rseqmx rm rn \o (list_R (list_R rAC)))%rel. Local Instance refines_refl_nat : forall m, refines nat_R m m | 999. Proof. by rewrite refinesE; apply: nat_Rxx. Qed. (* Local Instance refines_refl_ord : forall m (i : 'I_m), refines nat_R i i | 999. *) (* Proof. rewrite refinesE; elim=> *; exact: nat_Rxx. Qed. *) (* Local Instance refines_eq_refl_nat : forall (m : nat), refines eq m m | 999. *) (* Proof. by rewrite refinesE. Qed. *) Local Instance refines_ordinal_eq (m : nat) (i j : 'I_m) : refines (ordinal_R (nat_Rxx m)) i j -> refines eq i j. Proof. rewrite !refinesE=> [[m0 m1 mR i0 i1 _]]. apply: ord_inj; exact: nat_R_eq. Qed. Local Instance refines_fun_refl m n (f : 'I_m -> 'I_n -> R) : refines (eq ==> eq ==> eq) f f. Proof. by rewrite refinesE=> _ x -> _ y ->. Qed. #[export] Instance RseqmxC_seqmx_of_fun m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) f g `{forall x y, refines (rI rm) x y -> forall z t, refines (rI rn) z t -> refines (rAC \o @unify _) (f x z) (g y t)} : refines (RseqmxC rm rn) (\matrix_(i, j) f i j) (seqmx_of_fun (I:=I) g). Proof. eapply refines_trans; tc. rewrite refinesE. eapply (@seqmx_of_fun_R _ _ _ _ _ rI)=> // *; apply refinesP. rewrite /implem_of_R refinesE => *; apply refinesP. eapply refines_apply; tc. eapply refines_comp_unify; tc. Qed. #[export] Instance refine_seqmx_of_fun m n f g `{forall x y, refines (rI (nat_Rxx m)) x y -> forall z t, refines (rI (nat_Rxx n)) z t -> refines (rAC \o @unify _) (f x z) (g y t)} : refines (RseqmxC (nat_Rxx m) (nat_Rxx n)) (\matrix_(i, j) f i j) (seqmx_of_fun (I:=I) g). Proof. exact: RseqmxC_seqmx_of_fun. Qed. #[export] Instance RseqmxC_mkseqmx_ord m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines ((eq ==> eq ==> rAC) ==> RseqmxC rm rn) (matrix_of_fun matrix_key) (@mkseqmx_ord C m1 n1). Proof. param_comp mkseqmx_ord_R. Qed. #[export] Instance refine_mkseqmx_ord m n : refines ((eq ==> eq ==> rAC) ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) (matrix_of_fun matrix_key) (@mkseqmx_ord C m n). Proof. exact: RseqmxC_mkseqmx_ord. Qed. #[export] Instance RseqmxC_const_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (rAC ==> RseqmxC rm rn) (@matrix.const_mx R m1 n1) (const_seqmx m2 n2). Proof. param_comp const_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_const_seqmx m n : refines (rAC ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) (@matrix.const_mx R m n) (const_seqmx m n). Proof. exact: RseqmxC_const_seqmx. Qed. #[export] Instance RseqmxC_0 m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn) (const_mx 0%C) (@hzero_op _ _ _ m2 n2). Proof. param_comp seqmx0_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_0_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n)) (const_mx 0%C) (@hzero_op _ _ _ m n). Proof. exact: RseqmxC_0. Qed. #[export] Instance RseqmxC_top_left_seqmx m1 m2 (rm : nat_R m1 m2) : refines (RseqmxC (S_R rm) (S_R rm) ==> rAC) (fun M => M ord0 ord0) (@top_left_seqmx C _). Proof. param_comp top_left_seqmx_R. Qed. #[export] Instance refine_top_left_seqmx m : refines (RseqmxC (S_R (nat_Rxx m)) (S_R (nat_Rxx m)) ==> rAC) (fun M => M ord0 ord0) (@top_left_seqmx C _). Proof. exact: RseqmxC_top_left_seqmx. Qed. #[export] Instance RseqmxC_usubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC (addn_R rm1 rm2) rn ==> RseqmxC rm1 rn) (@matrix.usubmx R m11 m21 n1) (@usubseqmx C m12 m22 n2). Proof. param_comp usubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_usubseqmx m1 m2 n : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (nat_Rxx n) ==> RseqmxC (nat_Rxx m1) (nat_Rxx n)) (@matrix.usubmx R m1 m2 n) (@usubseqmx C m1 m2 n). Proof. exact: RseqmxC_usubseqmx. Qed. #[export] Instance RseqmxC_dsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC (addn_R rm1 rm2) rn ==> RseqmxC rm2 rn) (@matrix.dsubmx R m11 m21 n1) (@dsubseqmx C m12 m22 n2). Proof. param_comp dsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_dsubseqmx m1 m2 n : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (nat_Rxx n) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n)) (@matrix.dsubmx R m1 m2 n) (@dsubseqmx C m1 m2 n). Proof. exact: RseqmxC_dsubseqmx. Qed. #[export] Instance RseqmxC_lsubseqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC rm (addn_R rn1 rn2) ==> RseqmxC rm rn1) (@matrix.lsubmx R m1 n11 n21) (@lsubseqmx C m2 n12 n22). Proof. param_comp lsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_lsubseqmx m n1 n2 : refines (RseqmxC (nat_Rxx m) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m) (nat_Rxx n1)) (@matrix.lsubmx R m n1 n2) (@lsubseqmx C m n1 n2). Proof. exact: RseqmxC_lsubseqmx. Qed. #[export] Instance RseqmxC_rsubseqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC rm (addn_R rn1 rn2) ==> RseqmxC rm rn2) (@matrix.rsubmx R m1 n11 n21) (@rsubseqmx C m2 n12 n22). Proof. param_comp rsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_rsubseqmx m n1 n2 : refines (RseqmxC (nat_Rxx m) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m) (nat_Rxx n2)) (@matrix.rsubmx R m n1 n2) (@rsubseqmx C m n1 n2). Proof. exact: RseqmxC_rsubseqmx. Qed. #[export] Instance RseqmxC_ulsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RseqmxC rm1 rn1) (@matrix.ulsubmx R m11 m21 n11 n21) (@ulsubseqmx C m12 m22 n12 n22). Proof. param_comp ulsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_ulsubseqmx m1 m2 n1 n2 : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m1) (nat_Rxx n1)) (@matrix.ulsubmx R m1 m2 n1 n2) (@ulsubseqmx C m1 m2 n1 n2). Proof. exact: RseqmxC_ulsubseqmx. Qed. #[export] Instance RseqmxC_ursubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RseqmxC rm1 rn2) (@matrix.ursubmx R m11 m21 n11 n21) (@ursubseqmx C m12 m22 n12 n22). Proof. param_comp ursubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_ursubseqmx m1 m2 n1 n2 : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m1) (nat_Rxx n2)) (@matrix.ursubmx R m1 m2 n1 n2) (@ursubseqmx C m1 m2 n1 n2). Proof. exact: RseqmxC_ursubseqmx. Qed. #[export] Instance RseqmxC_dlsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RseqmxC rm2 rn1) (@matrix.dlsubmx R m11 m21 n11 n21) (@dlsubseqmx C m12 m22 n12 n22). Proof. param_comp dlsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_dlsubseqmx m1 m2 n1 n2 : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n1)) (@matrix.dlsubmx R m1 m2 n1 n2) (@dlsubseqmx C m1 m2 n1 n2). Proof. exact: RseqmxC_dlsubseqmx. Qed. #[export] Instance RseqmxC_drsubseqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC (addn_R rm1 rm2) (addn_R rn1 rn2) ==> RseqmxC rm2 rn2) (@matrix.drsubmx R m11 m21 n11 n21) (@drsubseqmx C m12 m22 n12 n22). Proof. param_comp drsubseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_drsubseqmx m1 m2 n1 n2 : refines (RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (addn_R (nat_Rxx n1) (nat_Rxx n2)) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n2)) (@matrix.drsubmx R m1 m2 n1 n2) (@drsubseqmx C m1 m2 n1 n2). Proof. exact: RseqmxC_drsubseqmx. Qed. #[export] Instance RseqmxC_row_seqmx m1 m2 (rm : nat_R m1 m2) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC rm rn1 ==> RseqmxC rm rn2 ==> RseqmxC rm (addn_R rn1 rn2)) (@matrix.row_mx R m1 n11 n21) (@row_seqmx C m2 n12 n22). Proof. param_comp row_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_row_seqmx m n1 n2 : refines (RseqmxC (nat_Rxx m) (nat_Rxx n1) ==> RseqmxC (nat_Rxx m) (nat_Rxx n2) ==> RseqmxC (nat_Rxx m) (addn_R (nat_Rxx n1) (nat_Rxx n2))) (@matrix.row_mx R m n1 n2) (@row_seqmx C m n1 n2). Proof. exact: RseqmxC_row_seqmx. Qed. #[export] Instance RseqmxC_col_seqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm1 rn ==> RseqmxC rm2 rn ==> RseqmxC (addn_R rm1 rm2) rn) (@matrix.col_mx R m11 m21 n1) (@col_seqmx C m12 m22 n2). Proof. param_comp col_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_col_seqmx m1 m2 n : refines (RseqmxC (nat_Rxx m1) (nat_Rxx n) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n) ==> RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (nat_Rxx n)) (@matrix.col_mx R m1 m2 n) (@col_seqmx C m1 m2 n). Proof. exact: RseqmxC_col_seqmx. Qed. #[export] Instance RseqmxC_block_seqmx m11 m12 (rm1 : nat_R m11 m12) m21 m22 (rm2 : nat_R m21 m22) n11 n12 (rn1 : nat_R n11 n12) n21 n22 (rn2 : nat_R n21 n22) : refines (RseqmxC rm1 rn1 ==> RseqmxC rm1 rn2 ==> RseqmxC rm2 rn1 ==> RseqmxC rm2 rn2 ==> RseqmxC (addn_R rm1 rm2) (addn_R rn1 rn2)) (@matrix.block_mx R m11 m21 n11 n21) (@block_seqmx C m12 m22 n12 n22). Proof. param_comp block_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_block_seqmx m1 m2 n1 n2 : refines (RseqmxC (nat_Rxx m1) (nat_Rxx n1) ==> RseqmxC (nat_Rxx m1) (nat_Rxx n2) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n1) ==> RseqmxC (nat_Rxx m2) (nat_Rxx n2) ==> RseqmxC (addn_R (nat_Rxx m1) (nat_Rxx m2)) (addn_R (nat_Rxx n1) (nat_Rxx n2))) (@matrix.block_mx R m1 m2 n1 n2) (@block_seqmx C m1 m2 n1 n2). Proof. exact: RseqmxC_block_seqmx. Qed. #[export] Instance RseqmxC_tr m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> RseqmxC rn rm) trmx (@trseqmx C m2 n2). Proof. param_comp trseqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_trseqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx n) (nat_Rxx m)) trmx (@trseqmx C m n). Proof. exact: RseqmxC_tr. Qed. End seqmx_param. End seqmx. Section seqmx_ring. Variable R : ringType. (* The "#[export]" is needed for lemma RseqmxC_char_poly_mx below. *) #[export] Instance zeroR : zero_of R := 0%R. Local Instance oneR : one_of R := 1%R. Local Instance oppR : opp_of R := -%R. Local Instance addR : add_of R := +%R. Local Instance mulR : mul_of R := *%R. Local Instance eqR : eq_of R := eqtype.eq_op. Local Instance specR_ring : spec_of R R := spec_id. Local Instance implem_ord_ring : forall n, (implem_of 'I_n 'I_n) := fun _ => implem_id. Local Open Scope rel_scope. Instance Rseqmx_diag_seqmx m1 m2 (rm : nat_R m1 m2) : refines (Rseqmx (S_R O_R) rm ==> Rseqmx rm rm) diag_mx (diag_seqmx (A:=R)). Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim|i j]. by rewrite size_map ord_enum_eqE size_enum_ord h2. by rewrite /diag_seqmx /mkseqmx_ord ord_enum_eqE h2 // (nth_map (Ordinal ltim)) ?size_enum_ord // size_map size_enum_ord. rewrite mxE h3 /diag_seqmx /mkseqmx_ord ord_enum_eqE h2 // -(nat_R_eq rm) (nth_map i) ?size_enum_ord // (nth_map j) ?size_enum_ord // !nth_ord_enum. by case: (i == j). Qed. Existing Instance Rseqmx_const_seqmx. Instance Rseqmx_scalar_seqmx m1 m2 (rm : nat_R m1 m2) : refines (eq ==> Rseqmx rm rm) scalar_mx (scalar_seqmx (A:=R) m2). Proof. rewrite refinesE=> x y rxy. rewrite /scalar_seqmx -diag_const_mx. exact: refinesP. Qed. Instance Rseqmx_1 m1 m2 (rm : nat_R m1 m2) : refines (Rseqmx rm rm) 1%:M (seqmx1 (A:=R) m2). Proof. rewrite /seqmx1. eapply refines_apply; first exact: Rseqmx_scalar_seqmx. by rewrite refinesE. Qed. Instance Rseqmx_opp m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (R:=R) rm rn ==> Rseqmx rm rn) -%R -%C. Proof. rewrite refinesE=> ? ? [A M h1 h2 h3]. constructor=> [|i ltim|i j]; first by rewrite size_map h1. rewrite (nth_map [::]); last by rewrite h1. by rewrite size_map h2. rewrite mxE (nth_map [::]); last by rewrite h1 -(nat_R_eq rm) ltn_ord. rewrite (nth_map 0); first by rewrite h3. by rewrite h2 -?(nat_R_eq rm) -?(nat_R_eq rn) ltn_ord. Qed. Instance Rseqmx_add m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (R:=R) rm rn ==> Rseqmx rm rn ==> Rseqmx rm rn) +%R +%C. Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. constructor=> [|i ltim|i j]; rewrite [(_ + _)%C]zipwithE. by rewrite size_map size1_zip h1 ?h'1. by rewrite (nth_map ([::], [::])) ?nth_zip ?zipwithE ?size_map ?size1_zip /= ?h1 ?h'1 ?h2 ?h'2 ?ltim. by rewrite (nth_map ([::], [::])) ?nth_zip /= ?size1_zip ?h1 ?h'1 -?(nat_R_eq rm) ?ltn_ord // mxE h3 h'3 zipwithE -[[seq _ | _ <- _]](mkseq_nth 0%C) nth_mkseq /= ?(nth_map (0%C, 0%C)) ?nth_zip ?size_map /= ?size1_zip ?h2 ?h'2 -?(nat_R_eq rm) -?(nat_R_eq rn) ?ltn_ord. Qed. Instance Rseqmx_sub m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (R:=R) rm rn ==> Rseqmx rm rn ==> Rseqmx rm rn) (fun M N => M - N) sub_op. Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. constructor=> [|i ltim|i j]; rewrite [(_ - _)%C]zipwithE. by rewrite size_map size1_zip ?size_map h1 ?h'1. by rewrite (nth_map ([::], [::])) ?nth_zip ?zipwithE ?size_map ?size1_zip /= ?(nth_map [::]) ?size_map ?h1 ?h'1 ?h2 ?h'2 ?ltim. by rewrite !mxE h3 h'3 (nth_map ([::], [::])) ?zipwithE ?(nth_map (0%C, 0%C)) ?nth_zip /= ?(nth_map [::]) ?size1_zip ?size_map ?(nth_map 0%C) ?h1 ?h'1 ?h2 ?h'2 -?(nat_R_eq rm) -?(nat_R_eq rn) ?ltn_ord. Qed. Instance Rseqmx_mul m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) p1 p2 (rp : nat_R p1 p2) : refines (Rseqmx (R:=R) rm rn ==> Rseqmx rn rp ==> Rseqmx rm rp) mulmx (@hmul_op _ _ _ m2 n2 p2). Proof. case: rn=> [|k1 k2 rk]; rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. constructor=> [|i ltim|i j]; rewrite /hmul_op /mul_seqmx /seqmx0. by rewrite size_nseq. by rewrite nth_nseq h1 ltim size_nseq. by rewrite nth_nseq h1 -(nat_R_eq rm) ltn_ord nth_nseq -(nat_R_eq rp) ltn_ord mxE big_ord0. constructor=> [|i ltim|i j]; rewrite /hmul_op /mul_seqmx. by rewrite size_map. by rewrite (nth_map [::]) ?h1 // size_map /trseqmx /= size_fold ?h'1. rewrite (nth_map [::]) ?h1 -?(nat_R_eq rm) // (nth_map [::]) /trseqmx ?size_fold ?h'1 ?h'2 // -?(nat_R_eq rp) //. set F := (fun z x y => _). have ->: forall s1 s2 (t : R), (foldl2 F t s1 s2) = (t + \sum_(0 <= k < minn (size s1) (size s2)) s1`_k * s2`_k). elim=>[s2 t|t1 s1 IHs s2 t]. by rewrite min0n big_mkord big_ord0 GRing.addr0. case:s2=>[|t2 s2]; first by rewrite minn0 big_mkord big_ord0 GRing.addr0. by rewrite /= IHs minSS big_nat_recl // /F [(_ + t)%C]addrC addrA. rewrite add0r big_mkord size_nth_fold ?h'1 ?h2 -?(nat_R_eq rm) // ?(nat_R_eq rp) // /minn if_same mxE -(nat_R_eq rk). apply: eq_bigr=> k _. by rewrite h3 h'3 nth_fold ?h'1 ?(nat_R_eq rp) // -(nat_R_eq rk). Qed. Instance Rseqmx_scale m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (eq ==> Rseqmx (R:=R) rm rn ==> Rseqmx rm rn) *:%R *:%C. Proof. rewrite refinesE=> _ x -> _ _ [M sM h1 h2 h3]. constructor=> [|i ltim|i j]; rewrite [(_ *: _)%C]/scale_seqmx. by rewrite size_map. by rewrite (nth_map [::]) ?size_map ?h1 ?h2. by rewrite mxE (nth_map [::]) ?(nth_map 0%C) ?h1 ?h2 ?h3 -?(nat_R_eq rm) -?(nat_R_eq rn). Qed. Lemma eq_seqE (T : Type) (f : T -> T -> bool) s1 s2 : size s1 = size s2 -> eq_seq f s1 s2 = all (fun xy => f xy.1 xy.2) (zip s1 s2). Proof. elim: s1 s2 => [|x1 s1 IHs] [] //= x2 s2 /eqP eq_sz. by rewrite IHs //; apply/eqP. Qed. Instance Rseqmx_eq m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (R:=R) rm rn ==> Rseqmx rm rn ==> bool_R) eqtype.eq_op eq_op. Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3] _ _ [N sN h'1 h'2 h'3]. suff ->: (M == N) = (eq_seq (eq_seq eqR) sM sN). exact: bool_Rxx. apply/eqP/idP=> [/matrixP heq|]. rewrite eq_seqE ?h1 ?h'1 //. apply/(all_nthP ([::], [::]))=> i. rewrite size1_zip ?nth_zip ?h1 ?h'1 //=; move=> ltim. rewrite eq_seqE ?h2 ?h'2 //. apply/(all_nthP (0, 0))=> j. rewrite size1_zip ?nth_zip ?h2 ?h'2 //= -(nat_R_eq rn); move=> ltjn. rewrite -(nat_R_eq rm) in ltim. have := heq (Ordinal ltim) (Ordinal ltjn); rewrite h3 h'3=> ->. by apply/eqP. rewrite eq_seqE ?h1 ?h'1 //. move/(all_nthP ([::], [::])). rewrite size1_zip ?h1 ?h'1 //; move=> heq. apply/matrixP=> i j. have := heq i; rewrite -(nat_R_eq rm) ltn_ord; move/implyP; rewrite implyTb. rewrite nth_zip ?h1 ?h'1 //= eq_seqE ?h2 ?h'2 -?(nat_R_eq rm) //. move/(all_nthP (0, 0))=> /(_ j). rewrite nth_zip ?size1_zip ?h2 ?h'2 -?(nat_R_eq rm) //= h3 h'3 -?(nat_R_eq rn) (ltn_ord _) /eqR. move=> he. by apply/eqP; rewrite he. Qed. Instance Rseqmx_delta_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) (i1 : 'I_m1) (i2 : 'I_m2) (ri : nat_R i1 i2) (j1 : 'I_n1) (j2 : 'I_n2) (rj : nat_R j1 j2) : refines (Rseqmx (R:=R) rm rn) (delta_mx i1 j1) (delta_seqmx m2 n2 i2 j2). Proof. rewrite refinesE -(nat_R_eq ri) -(nat_R_eq rj); constructor=> [|k ltkm|k l]. by rewrite size_map ord_enum_eqE size_enum_ord. by rewrite (nth_map (Ordinal ltkm)) !ord_enum_eqE ?size_enum_ord // size_map size_enum_ord. rewrite mxE /delta_seqmx /mkseqmx_ord !ord_enum_eqE -(nat_R_eq rm) -(nat_R_eq rn) (nth_map k) ?size_enum_ord // (nth_map l) ?size_enum_ord // !nth_ord_enum. by case: ifP. Qed. Instance Rseqmx_trace_seqmx m1 m2 (rm : nat_R m1 m2) : refines (Rseqmx rm rm ==> eq) mxtrace (trace_seqmx (A:=R) (m:=m2)). Proof. apply refines_abstr. rewrite !refinesE /mxtrace. elim: rm=> [|n1 n2 rn ih] /= M sM rM. by rewrite big_ord0. rewrite big_ord_recl -(ih (drsubmx (M : 'M_(1 + n1, 1 + n1)))). have <- : M ord0 ord0 = top_left_seqmx sM. apply refinesP; rewrite -[M _ _]/((fun (M : 'M_(_)) => M _ _) _). eapply refines_apply. apply Rseqmx_top_left_seqmx. rewrite refinesE; eassumption. apply: congr2=> //; apply eq_bigr=> i _. by rewrite -[in LHS](@submxK R 1 n1 1 n1 M) -zmodp.rshift1 [LHS](@block_mxEdr R 1 n1 1 n1). apply refinesP; eapply refines_apply. apply Rseqmx_drsubseqmx. rewrite refinesE. have H : S_R rn = addn_R (S_R O_R) rn by []. rewrite H in rM. eassumption. Qed. Instance Rseqmx_pid_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) r1 r2 (rr : nat_R r1 r2) : refines (Rseqmx (R:=R) rm rn) (pid_mx r1) (pid_seqmx m2 n2 r2). Proof. rewrite refinesE; constructor=> [|i ltim|i j]. by rewrite size_map ord_enum_eqE size_enum_ord. by rewrite (nth_map (Ordinal ltim)) !ord_enum_eqE ?size_enum_ord // size_map size_enum_ord. rewrite mxE /pid_seqmx /mkseqmx_ord !ord_enum_eqE -(nat_R_eq rm) -(nat_R_eq rn) (nth_map i) ?size_enum_ord // (nth_map j) ?size_enum_ord // !nth_ord_enum -(nat_R_eq rr). by case: ifP. Qed. Instance Rseqmx_copid_seqmx m1 m2 (rm : nat_R m1 m2) r1 r2 (rr : nat_R r1 r2) : refines (Rseqmx (R:=R) rm rm) (copid_mx r1) (copid_seqmx m2 r2). Proof. rewrite /copid_mx /copid_seqmx /sub_op /sub_seqmx. eapply refines_apply; tc. eapply refines_apply; tc. exact: Rseqmx_pid_seqmx. Qed. Instance Rseqmx_spec_l m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx (R:=R) rm rn ==> Logic.eq) spec_id spec. Proof. rewrite refinesE=> _ _ [M sM h1 h2 h3]. rewrite /spec /spec_seqmx /spec_id /spec /specR /spec_id /map_seqmx map_id_in; last first. by move=> x; rewrite map_id. by apply/matrixP=> i j; rewrite h3 mxE. Qed. Section seqmx_ring_param. Context (C : Type) (rAC : R -> C -> Type). Context (I : nat -> Type) (rI : forall n1 n2, nat_R n1 n2 -> 'I_n1 -> I n2 -> Type). Context `{zero_of C, one_of C, opp_of C, add_of C, mul_of C, eq_of C}. Context `{spec_of C R}. Context `{forall n, implem_of 'I_n (I n)}. Context `{!refines rAC 0%R 0%C, !refines rAC 1%R 1%C}. Context `{!refines (rAC ==> rAC) -%R -%C}. Context `{!refines (rAC ==> rAC ==> rAC) +%R +%C}. Context `{!refines (rAC ==> rAC ==> rAC) *%R *%C}. Context `{!refines (rAC ==> rAC ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rAC ==> Logic.eq) spec_id spec}. Context `{forall n1 n2 (rn : nat_R n1 n2), refines (ordinal_R rn ==> rI rn) implem_id implem}. Notation RseqmxC := (RseqmxC rAC). #[export] Instance RseqmxC_diag_seqmx m1 m2 (rm : nat_R m1 m2) : refines (RseqmxC (S_R O_R) rm ==> RseqmxC rm rm) diag_mx (diag_seqmx (A:=C)). Proof. param_comp diag_seqmx_R. Qed. #[export] Instance refine_diag_seqmx m : refines (RseqmxC (S_R O_R) (nat_Rxx m) ==> RseqmxC (nat_Rxx m) (nat_Rxx m)) diag_mx (diag_seqmx (A:=C)). Proof. exact: RseqmxC_diag_seqmx. Qed. #[export] Instance RseqmxC_scalar_seqmx m1 m2 (rm : nat_R m1 m2) : refines (rAC ==> RseqmxC rm rm) scalar_mx (scalar_seqmx m2). Proof. param_comp scalar_seqmx_R; rewrite refinesE; apply nat_Rxx. Qed. #[export] Instance refine_scalar_seqmx m : refines (rAC ==> RseqmxC (nat_Rxx m) (nat_Rxx m)) scalar_mx (scalar_seqmx m). Proof. exact: RseqmxC_scalar_seqmx. Qed. #[export] Instance RseqmxC_1 m1 m2 (rm : nat_R m1 m2) : refines (RseqmxC rm rm) 1%:M (seqmx1 m2). Proof. param_comp seqmx1_R; rewrite refinesE; apply nat_Rxx. Qed. #[export] Instance refine_1_seqmx m : refines (RseqmxC (nat_Rxx m) (nat_Rxx m)) 1%:M (seqmx1 m). Proof. exact: RseqmxC_1. Qed. #[export] Instance RseqmxC_opp m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> RseqmxC rm rn) -%R -%C. Proof. param_comp opp_seqmx_R. Qed. #[export] Instance refine_opp_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) -%R -%C. Proof. exact: RseqmxC_opp. Qed. #[export] Instance RseqmxC_add m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> RseqmxC rm rn ==> RseqmxC rm rn) +%R +%C. Proof. param_comp add_seqmx_R. Qed. #[export] Instance refine_add_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) +%R +%C. Proof. exact: RseqmxC_add. Qed. #[export] Instance RseqmxC_sub m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> RseqmxC rm rn ==> RseqmxC rm rn) (fun M N => M - N) sub_op. Proof. param_comp sub_seqmx_R. Qed. #[export] Instance refine_sub_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) (fun M N => M - N) sub_op. Proof. exact: RseqmxC_sub. Qed. #[export] Instance RseqmxC_mul m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) p1 p2 (rp : nat_R p1 p2) : refines (RseqmxC rm rn ==> RseqmxC rn rp ==> RseqmxC rm rp) mulmx (@hmul_op _ _ _ m2 n2 p2). Proof. param_comp mul_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_mul_seqmx m n p : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx n) (nat_Rxx p) ==> RseqmxC (nat_Rxx m) (nat_Rxx p)) mulmx (@hmul_op _ _ _ m n p). Proof. exact: RseqmxC_mul. Qed. #[export] Instance RseqmxC_scale m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (rAC ==> RseqmxC rm rn ==> RseqmxC rm rn) *:%R *:%C. Proof. param_comp scale_seqmx_R. Qed. #[export] Instance refine_scale_seqmx m n : refines (rAC ==> RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n)) *:%R *:%C. Proof. exact: RseqmxC_scale. Qed. #[export] Instance RseqmxC_eq m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> RseqmxC rm rn ==> bool_R) eqtype.eq_op eq_op. Proof. param_comp eq_seqmx_R. Qed. #[export] Instance refine_eq_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC (nat_Rxx m) (nat_Rxx n) ==> bool_R) eqtype.eq_op eq_op. Proof. exact: RseqmxC_eq. Qed. #[export] Instance RseqmxC_delta_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) (i1 : 'I_m1) (i2 : 'I_m2) (ri : nat_R i1 i2) (j1 : 'I_n1) (j2 : 'I_n2) (rj : nat_R j1 j2) : refines (RseqmxC rm rn) (delta_mx i1 j1) (delta_seqmx (A:=C) m2 n2 i2 j2). Proof. eapply refines_trans; tc. eapply Rseqmx_delta_seqmx; eassumption. rewrite refinesE; eapply delta_seqmx_R; try exact: refinesP; apply nat_Rxx. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_delta_seqmx m n i j : refines (RseqmxC (nat_Rxx m) (nat_Rxx n)) (delta_mx i j) (delta_seqmx m n i j). Proof. apply RseqmxC_delta_seqmx; exact: nat_Rxx. Qed. #[export] Instance RseqmxC_trace_seqmx m1 m2 (rm : nat_R m1 m2) : refines (RseqmxC rm rm ==> rAC) mxtrace (trace_seqmx (A:=C) (m:=m2)). Proof. param_comp trace_seqmx_R. Unshelve. all: exact: nat_Rxx. Qed. #[export] Instance refine_trace_seqmx m : refines (RseqmxC (nat_Rxx m) (nat_Rxx m) ==> rAC) mxtrace (trace_seqmx (A:=C) (m:=m)). Proof. exact: RseqmxC_trace_seqmx. Qed. #[export] Instance RseqmxC_pid_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) r1 r2 (rr : nat_R r1 r2) : refines (RseqmxC rm rn) (pid_mx r1) (pid_seqmx m2 n2 r2). Proof. eapply refines_trans; tc. eapply Rseqmx_pid_seqmx; eassumption. rewrite refinesE; eapply pid_seqmx_R; try exact: refinesP; apply nat_Rxx. Qed. #[export] Instance refine_pid_seqmx m n r : refines (RseqmxC (nat_Rxx m) (nat_Rxx n)) (pid_mx r) (pid_seqmx m n r). Proof. apply RseqmxC_pid_seqmx; exact: nat_Rxx. Qed. #[export] Instance RseqmxC_copid_seqmx m1 m2 (rm : nat_R m1 m2) r1 r2 (rr : nat_R r1 r2) : refines (RseqmxC rm rm) (copid_mx r1) (copid_seqmx m2 r2). Proof. eapply refines_trans; tc. eapply Rseqmx_copid_seqmx; eassumption. rewrite refinesE. eapply copid_seqmx_R=> *; try exact: refinesP; apply nat_Rxx. Qed. #[export] Instance refine_copid_seqmx m r : refines (RseqmxC (nat_Rxx m) (nat_Rxx m)) (copid_mx r) (copid_seqmx m r). Proof. apply RseqmxC_copid_seqmx; exact: nat_Rxx. Qed. #[export] Instance RseqmxC_spec m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rm rn ==> Logic.eq) spec_id spec. Proof. eapply refines_trans; tc. rewrite refinesE /spec /spec_seqmx /spec /specR=> l l' rl. have -> : map_seqmx spec l = (map_seqmx spec l' : @seqmx R). elim: rl=> [|a b ra p q rp ih] //=. rewrite ih. apply: congr2=> //. elim: ra=> [|x y rxy s t rst ihs] //=. by rewrite ihs [specR_ring _]refines_eq. by []. Qed. #[export] Instance refine_spec_seqmx m n : refines (RseqmxC (nat_Rxx m) (nat_Rxx n) ==> Logic.eq) spec_id spec. Proof. exact: RseqmxC_spec. Qed. End seqmx_ring_param. End seqmx_ring. Section seqmx2. Local Open Scope rel_scope. Variable R R' : Type. Context `{!zero_of R, !zero_of R'}. Instance Rseqmx_map_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (eq ==> Rseqmx (R:=R) rm rn ==> Rseqmx (R:=R') rm rn) (fun f => @map_mx _ _ f m1 n1) map_mx_op. Proof. rewrite refinesE=> _ f -> _ _ [M sM h1 h2 h3]; constructor=> [|i ltim|i j]. by rewrite size_map. by rewrite (nth_map [::]) ?h1 // size_map h2. rewrite mxE (nth_map [::]) ?h1 -?(nat_R_eq rm) ?ltn_ord //. rewrite (nth_map (M i j)) ?h2 -?(nat_R_eq rm) -?(nat_R_eq rn) ?ltn_ord //. apply: congr1; rewrite {1}h3; apply set_nth_default. by rewrite h2 -?(nat_R_eq rm) -?(nat_R_eq rn) ltn_ord. Qed. Section seqmx2_param. Context (C : Type) (rAC : R -> C -> Type). Context (D : Type) (rBD : R' -> D -> Type). #[export] Instance RseqmxC_map_mx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines ((rAC ==> rBD) ==> RseqmxC rAC rm rn ==> RseqmxC rBD rm rn) (fun f => @map_mx _ _ f m1 n1) map_mx_op. Proof. param_comp map_seqmx_R. Qed. #[export] Instance refine_map_seqmx m n : refines ((rAC ==> rBD) ==> RseqmxC rAC (nat_Rxx m) (nat_Rxx n) ==> RseqmxC rBD (nat_Rxx m) (nat_Rxx n)) (fun f => @map_mx _ _ f m n) map_mx_op. Proof. exact: RseqmxC_map_mx. Qed. End seqmx2_param. End seqmx2. Section seqmx_poly. Local Open Scope rel_scope. Variable R : ringType. Context (C : Type) (rAC : R -> C -> Type). Context (polyC : Type) (RpolyC : {poly R} -> polyC -> Type). Variable polyX : polyC. Context `{zero_of polyC, one_of polyC, add_of polyC, mul_of polyC, opp_of polyC}. Context `{cast_of C polyC}. Context `{!refines RpolyC 'X polyX}. Context `{!refines RpolyC 0 0%C, !refines RpolyC 1 1%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) +%R +%C}. Context `{!refines (RpolyC ==> RpolyC ==> RpolyC) *%R *%C}. Context `{!refines (RpolyC ==> RpolyC) -%R -%C}. Context `{!refines (rAC ==> RpolyC) poly.polyC cast}. #[export] Instance RseqmxC_char_poly_mx m1 m2 (rm : nat_R m1 m2) : refines (RseqmxC rAC rm rm ==> RseqmxC RpolyC rm rm) (char_poly_mx (n:=m1)) (fun s => (scalar_seqmx m2 polyX) - (map_seqmx cast s))%C. Proof. rewrite refinesE /char_poly_mx /sub_op /sub_seqmx=> M sM rM. apply refinesP; eapply refines_apply. eapply refines_apply; tc. eapply refines_apply. tc. eapply refines_apply; tc. rewrite -[map_mx _ (n:=_)]/((fun f => @map_mx _ _ f _ _) _). tc. Qed. #[export] Instance refine_char_poly_seqmx m : refines (RseqmxC rAC (nat_Rxx m) (nat_Rxx m) ==> RseqmxC RpolyC (nat_Rxx m) (nat_Rxx m)) (char_poly_mx (n:=m)) (fun s => (scalar_seqmx m polyX) - (map_seqmx cast s))%C. Proof. exact: RseqmxC_char_poly_mx. Qed. End seqmx_poly. End seqmx_theory. From mathcomp Require Import ssrint poly. From CoqEAL Require Import binnat binint seqpoly binord. Section testmx. Goal ((0 : 'M[int]_(2,2)) == 0). by coqeal. Abort. Goal (1 : 'M[int]_(2)) == 1. by coqeal. Abort. Goal ((- 0 : 'M[int]_(2,2)) == - - - 0). by coqeal. Abort. Goal ((- 0 : 'M[{poly int}]_(2,2)) == - - - 0). by coqeal. Abort. Goal (\tr (1 : 'M[{poly int}]_(10)) == 10%:Z%:P). by coqeal. Abort. Goal (pid_mx 3 + copid_mx 3 == 1 :> 'M[int]_(10)). by coqeal. Abort. Goal (pid_mx 4 * copid_mx 4 == 0 :> 'M[{poly {poly int}}]_(5)). Time by coqeal. Abort. Definition Maddm : 'M[int]_(2) := \matrix_(i, j < 2) (i + j * i)%:Z. Goal (Maddm == Maddm). by coqeal. Abort. Definition M3 : 'M[int]_(2,2) := \matrix_(i,j < 2) 3%:Z. Definition Mn3 : 'M[int]_(2,2) := \matrix_(i,j < 2) - 3%:Z. Definition M6 : 'M[int]_(2,2) := \matrix_(i,j < 2) 6%:Z. Definition V : 'rV[int]_(3) := \matrix_(i < 1, j < 3) 3%:Z. Goal (diag_mx V == 2%:Z *: diag_mx V - diag_mx V). by coqeal. Abort. Goal (delta_mx ord0 ord0 + delta_mx (Ordinal (ltnSn 1)) (Ordinal (ltnSn 1)) == 1 :> 'M[{poly int}]_(2)). by coqeal. Abort. Goal (- - M3 == M3). by coqeal. Abort. Goal (- M3 == Mn3). by coqeal. Abort. Goal (M3 - M3 == 0). by coqeal. Abort. Goal (M3 + M3 == M6). rewrite -[X in X == _]/(spec_id _) [spec_id _]refines_eq /=. by coqeal. Abort. Definition Mp : 'M[{poly {poly int}}]_(2,2) := \matrix_(i,j < 2) (Poly [:: Poly [:: 3%:Z; 0; 1]; 0]). Goal (Mp + -Mp == 0). by coqeal. Abort. Goal (Mp *m 0 == 0 :> 'M[_]_(2,2)). by coqeal. Abort. Definition M := \matrix_(i,j < 2) 1%:Z. Definition N := \matrix_(i,j < 2) 2%:Z. Definition P := \matrix_(i,j < 2) 14%:Z. Goal (M + N + M + N + M + N + N + M + N) *m (M + N + M + N + M + N + N + M + N) = (P *m M + P *m N + P *m M + P *m N + P *m M + P *m N + P *m N + P *m M + P *m N). Proof. apply/eqP. Time by coqeal. Abort. End testmx. coqeal-2.1.0/refinements/seqmx_complements.v000066400000000000000000000235001475512565300212440ustar00rootroot00000000000000(** * A few operations missing in seqmx *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. From mathcomp Require Import choice fintype bigop matrix. From CoqEAL Require Import hrel param refinements seqmx seqpoly. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope ring_scope. Import Refinements.Op. (** * Extra material about CoqEAL *) Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *) Arguments refinesP {T T' R x y} _. #[export] Hint Resolve nil_R : core. Notation ord_instN := (fun _ : nat => nat) (only parsing). Definition Rord n1 n2 (rn : nat_R n1 n2) : 'I_n1 -> ord_instN n2 -> Type := fun x y => x = y :> nat. (** [ord0] is the only value in ['I_1]. *) Lemma ord_1_0 (i : 'I_1) : i = ord0. Proof. by case: i => [[]] // HH; apply /eqP. Qed. Section classes. (** ** Definition of operational type classes *) Class fun_of_of A I B := fun_of_op : forall (m n : nat), B m n -> I m -> I n -> A. Class row_of I B := row_op : forall (m n : nat), I m -> B m n -> B 1%N n. Class store_of A I B := store_op : forall (m n : nat), B m n -> I m -> I n -> A -> B m n. Class trmx_of B := trmx_op : forall m n : nat, B m n -> B n m. End classes. #[export] Typeclasses Transparent fun_of_of row_of store_of trmx_of. Notation "A ^T" := (trmx_op A) : hetero_computable_scope. (** ** General definitions for seqmx *) Section seqmx_op. Context {A : Type}. Context `{zero_of A}. #[export] Instance fun_of_seqmx : fun_of_of A ord_instN hseqmx := fun (_ _ : nat) M i j => nth 0%C (nth [::] M i) j. #[export] Instance row_seqmx : row_of ord_instN (@hseqmx A) := fun (_ _ : nat) i M => [:: nth [::] M i]. Fixpoint store_aux T s k (v : T) := match s, k with | [::], _ => [::] | _ :: t, O => v :: t | h :: t, S k => h :: store_aux t k v end. Fixpoint store_seqmx0 T m i j (v : T) := match m, i with | [::], _ => [::] | h :: t, O => store_aux h j v :: t | h :: t, S i => h :: store_seqmx0 t i j v end. #[export] Instance store_seqmx : store_of A ord_instN hseqmx := fun (_ _ : nat) M i j v => store_seqmx0 M i j v. #[export] Instance trmx_seqmx : trmx_of hseqmx := fun m n : nat => @trseqmx A m n. Context `{eq_of A}. #[export] Instance heq_seqmx : heq_of (@hseqmx A) := fun (_ _ : nat) => eq_seq (eq_seq eq_op). End seqmx_op. (** ** Refinement proofs *) Require Import Equivalence RelationClasses Morphisms. Section seqmx_theory. Context {A : Type}. Context `{!zero_of A}. Local Instance : spec_of A A := spec_id. Lemma Rseqmx_spec_seqmx m n (M : @seqmx A) : (size M == m) && all (fun r => size r == n) M -> Rseqmx (nat_Rxx m) (nat_Rxx n) (spec_seqmx m n M) M. Proof. move/andP=>[] /eqP Hm /all_nthP Hn; split=>[//||]. { by move=> i Hi; apply/eqP /Hn; rewrite Hm. } move=> i j; rewrite mxE. rewrite /map_seqmx /spec /spec_of_instance_0 /spec_id /=. by rewrite (nth_map [::]) ?Hm ?(ltn_ord i) // map_id. Qed. #[export] Instance Rseqmx_fun_of_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm rn ==> Rord rm ==> Rord rn ==> eq) ((@fun_of_matrix A m1 n1) : matrix A m1 n1 -> ordinal m1 -> ordinal n1 -> A) (@fun_of_seqmx A _ m2 n2). Proof. rewrite refinesE => _ _ [M sM h1 h2 h3] i _ <- j _ <-. by rewrite /fun_of_seqmx. Qed. #[export] Instance Rseqmx_row_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rord rm ==> Rseqmx rm rn ==> Rseqmx (S_R O_R) rn) (@row A m1 n1) (@row_seqmx A m2 n2). Proof. rewrite refinesE=> i _ <- _ _ [M sM h1 h2 h3]. rewrite /row_seqmx; constructor=> [//||i' j]. { by case=>//= _; apply h2; rewrite -(nat_R_eq rm). } rewrite mxE (ord_1_0 i') /=; apply h3. Qed. Lemma store_aux_correct n (l : seq A) (j : 'I_n) v (j' : 'I_n) : size l = n -> nth 0%C (store_aux l j v) j' = if j' == j then v else nth 0%C l j'. Proof. elim: n j j' l; [by case|]; move=> n IH j j'. case=>// h t [Ht]; case j' => {j'}; case; case j => {j}; case=>//= j Hj j' Hj'. rewrite /eqtype.eq_op /= eqSS; rewrite !ltnS in Hj, Hj'. apply (IH (Ordinal Hj) (Ordinal Hj') _ Ht). Qed. Lemma size_store_seqmx0 s i j x : seq.size (@store_seqmx0 A s j i x) = seq.size s. Proof. elim: s j => [|a s IHs] j; first by case: j. case: j IHs => [|j] IHs //=. by rewrite -(IHs j). Qed. Lemma size_store_aux s i x : size (@store_aux A s i x) = size s. Proof. elim: s i => [|a s IHs] i; first by case: i. case: i IHs => [|i] IHs //=. by rewrite -(IHs i). Qed. Lemma size_nth_store_seqmx0 s i j k x : size (nth [::] (@store_seqmx0 A s j i x) k) = size (nth [::] s k). Proof. elim: s j k => [|a s IHs] j k; first by case: j. case: j IHs => [|j] IHs //=; case: k IHs => [|k] IHs //=. by rewrite size_store_aux. Qed. #[export] Instance store_ssr : store_of A ordinal (matrix A) := fun m n (M : 'M[A]_(m, n)) (i : 'I_m) (j : 'I_n) v => \matrix_(i', j') if ((nat_of_ord i' == i) && (nat_of_ord j' == j))%N then v else M i' j'. #[export] Instance Rseqmx_store_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm rn ==> Rord rm ==> Rord rn ==> eq ==> Rseqmx rm rn) (@store_ssr m1 n1) (@store_seqmx A m2 n2). Proof. rewrite refinesE =>_ _ [M sM h1 h2 h3] i _ <- j _ <- v _ <-. constructor=>[|i' Hi'|i' j']. { by rewrite size_store_seqmx0. } { by rewrite size_nth_store_seqmx0; apply h2. } rewrite mxE {}h3; move: i i' sM h2 h1; rewrite -(nat_R_eq rm) -(nat_R_eq rn). elim m1; [by case|]; move=> m IH i i'. case=>// h t h2 [Ht]; case i' => {i'}; case. { case (nat_of_ord i)=>//= _. by rewrite store_aux_correct //; move: (h2 O erefl). } move=> i' Hi'; case i => {i}; case=>// i Hi. rewrite {1}/eqtype.eq_op /=; rewrite !ltnS in Hi, Hi'. apply (IH (Ordinal Hi) (Ordinal Hi')) => //. by move=> k Hk; move: (h2 k.+1); apply. Qed. Context `{eq_of A}. #[export] Instance heq_ssr : heq_of (matrix A) := fun n1 n2 a b => [forall i, [forall j, (a i j == b i j)%C]]. #[export] Instance Rseqmx_heq_op m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (Rseqmx rm rn ==> Rseqmx rm rn ==> bool_R) (@heq_ssr m1 n1) (heq_seqmx (n:=n2)). Proof. rewrite refinesE=> _ _ [a a' ha1 ha2 ha3] _ _ [b b' hb1 hb2 hb3]. rewrite /heq_ssr /heq_seqmx. rewrite eq_seqE; [|by rewrite ha1 hb1]. have SzAs : seq.size (zip a' b') = m2. { by rewrite size1_zip ha1 // hb1. } match goal with | [ |- ?R ?a ?b ] => let H := fresh in suff H : a = b; first (rewrite H; eapply bool_Rxx =>//) end. apply/idP/idP. { move/forallP=> H1; apply/all_nthP=> i; rewrite SzAs=> Hi. erewrite (nth_zip [::] [::]); rewrite ?hb1 //= eq_seqE ?ha2 ?hb2 //. apply/all_nthP=> j. erewrite (nth_zip 0%C 0%C); rewrite ?ha2 ?hb2 //= size1_zip ?ha2 ?hb2 // => Hj. rewrite -(nat_R_eq rm) in Hi; rewrite -(nat_R_eq rn) in Hj. move: (H1 (Ordinal Hi)); move/forallP => H2; move: (H2 (Ordinal Hj)). by rewrite ha3 hb3. } move/all_nthP=> H1; apply/forallP=> i. have Hi : (i < m2)%N; [by rewrite -(nat_R_eq rm) ltn_ord|]. apply/forallP=> j; rewrite ha3 hb3. move: (H1 ([::], [::]) i); rewrite size1_zip ?ha1 ?hb1 // -(nat_R_eq rm)=> H2. move: (H2 (ltn_ord i)); rewrite nth_zip ?ha1 ?hb1 //= eq_seqE ?ha2 ?hb2 //. move/all_nthP=>H3; move: (H3 (zero_of0, zero_of0) j). rewrite nth_zip ?ha2 ?hb2 //=; apply. by rewrite size1_zip ha2 ?hb2 // -(nat_R_eq rn). Qed. (** ** Parametricity *) Elpi derive.param2 fun_of_of. Elpi derive.param2 fun_of_seqmx. Elpi derive.param2 row_of. Elpi derive.param2 row_seqmx. Elpi derive.param2 store_of. Elpi derive.param2 store_aux. Elpi derive.param2 store_seqmx0. Elpi derive.param2 store_seqmx. Elpi derive.param2 trmx_of. Elpi derive.param2 trmx_seqmx. Elpi derive.param2 heq_of. Elpi derive.param2 heq_seqmx. Section seqmx_param. Context (C : Type) (rAC : A -> C -> Type). Context `{!zero_of C, !spec_of C A}. Context `{!eq_of C}. Lemma RseqmxC_spec_seqmx m n (M : @seqmx C) : (size M == m) && all (fun r => size r == n) M -> (list_R (list_R rAC)) (map_seqmx spec M) M -> RseqmxC rAC (nat_Rxx m) (nat_Rxx n) (spec_seqmx m n M) M. Proof. move=> /andP [] /eqP Hm /all_nthP Hn Hc; apply refinesP. eapply (refines_trans (b:=map_seqmx spec M)); [by tc| |]. { rewrite refinesE; split; [by rewrite size_map| |]. { move=> i Hi; rewrite (nth_map 0%C) ?Hm // size_map. by apply/eqP/Hn; rewrite Hm. } by move=> i j; rewrite mxE. } by rewrite refinesE. Qed. Lemma nth_R_lt (T1 T2 : Type) (T_R : T1 -> T2 -> Type) x01 x02 s1 s2 : list_R T_R s1 s2 -> forall n, (n < size s1)%N -> T_R (nth x01 s1 n) (nth x02 s2 n). Proof. move=> Hs n; elim: n s1 s2 Hs=> [|n IH] s1 s2 Hs Hn /=. { by move: Hs Hn; case s1=> [//|h1 t1] Hs _; inversion Hs. } move: Hs Hn IH; case s1=> [//|h1 t1] Hs Hn IH. by inversion Hs; apply IH. Qed. Lemma RseqmxC_fun_of_seqmx m1 m2 (rm : nat_R m1 m2) n1 n2 (rn : nat_R n1 n2) : refines (RseqmxC rAC rm rn ==> Rord rm ==> Rord rn ==> rAC) ((@fun_of_matrix A m1 n1) : matrix A m1 n1 -> ordinal m1 -> ordinal n1 -> A) (@fun_of_seqmx C _ m2 n2). Proof. rewrite refinesE => _ a' [_ [[a a'' h1 h2 h3] ra'']] i i' ri j j' rj. rewrite h3 /fun_of_seqmx -ri -rj. apply nth_R_lt. { apply nth_R_lt=>//; rewrite h1 -(nat_R_eq rm); apply ltn_ord. } rewrite h2 -?(nat_R_eq rm) -?(nat_R_eq rn); apply ltn_ord. Qed. #[export] Instance refine_fun_of_seqmx m n : refines (RseqmxC rAC (nat_Rxx m) (nat_Rxx n) ==> Rord (nat_Rxx m) ==> Rord (nat_Rxx n) ==> rAC) ((@fun_of_matrix A m n) : matrix A m n -> ordinal m -> ordinal n -> A) (@fun_of_seqmx C _ m n). Proof. exact: RseqmxC_fun_of_seqmx. Qed. #[export] Instance refine_foldl (T1 T2 : Type) (rT : T1 -> T2 -> Type) (R1 R2 : Type) (rR : R1 -> R2 -> Type) : refines ((rR ==> rT ==> rR) ==> rR ==> list_R rT ==> rR) (@foldl T1 R1) (@foldl T2 R2). Proof. rewrite refinesE=> f f' rf z z' rz s' s'' rs'. elim: s' s'' rs' z z' rz=> [|h t IH] s'' rs' z z' rz. { case: s'' rs'=> [//|h' t'] rs'; inversion rs'. } case: s'' rs'=> [|h' t'] rs' /=; [by inversion rs'|]. apply IH; [by inversion rs'|]. by apply refinesP; refines_apply; rewrite refinesE; inversion rs'. Qed. End seqmx_param. End seqmx_theory. coqeal-2.1.0/refinements/seqpoly.v000066400000000000000000000606721475512565300172100ustar00rootroot00000000000000From Coq Require List. From elpi Require Import derive. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg. From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv. From CoqEAL Require Import hrel param refinements poly_op. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Import Refinements.Op Poly.Op. Local Open Scope ring_scope. Section seqpoly_op. Local Open Scope computable_scope. Variable A N : Type. Definition seqpoly := seq A. Context `{zero_of A, one_of A}. Context `{add_of A, opp_of A, mul_of A, eq_of A}. Context `{zero_of N, one_of N, add_of N, eq_of N}. Context `{spec_of N nat}. #[export] Instance cast_seqpoly : cast_of A seqpoly := fun x => [:: x]. #[export] Instance seqpoly0 : zero_of seqpoly := [::]. #[export] Instance seqpoly1 : one_of seqpoly := [:: 1]. #[export] Instance opp_seqpoly : opp_of seqpoly := List.map -%C. Fixpoint add_seqpoly_fun (p q : seqpoly) : seqpoly := match p,q with | [::], q => q | p, [::] => p | a :: p', b :: q' => a + b :: add_seqpoly_fun p' q' end. #[export] Instance add_seqpoly : add_of seqpoly := add_seqpoly_fun. #[export] Instance sub_seqpoly : sub_of seqpoly := fun x y => (x + - y)%C. Lemma sub_seqpoly_0 (s : seqpoly) : s - 0 = s. Proof. by elim: s. Qed. #[export] Instance scale_seqpoly : scale_of A seqpoly := fun a => map ( *%C a). (* 0%C :: aux p = shift 1 (aux p) *) #[export] Instance mul_seqpoly : mul_of seqpoly := fun p q => let fix aux p := if p is a :: p then (a *: q + (0%C :: aux p))%C else 0 in aux p. #[export] Instance exp_seqpoly : exp_of seqpoly N := fun p n => iter (spec n) (mul_seqpoly p) 1. #[export] Instance size_seqpoly : size_of seqpoly N := let fix aux p := if p is a :: p then let sp := aux p in if (sp == 0)%C then if (a == 0)%C then 0%C else 1%C else (sp + 1)%C else 0%C in aux. #[export] Instance eq_seqpoly : eq_of seqpoly := fun p q => all (fun x => x == 0)%C (p - q)%C. #[export] Instance shift_seqpoly : shift_of seqpoly N := fun n => ncons (spec n) 0%C. #[export] Instance split_seqpoly : split_of seqpoly N := fun n p => (drop (spec n) p,take (spec n) p). #[export] Instance lead_coef_seqpoly : lead_coef_of A seqpoly := fun p => nth 0 p (spec (size_seqpoly p)).-1. End seqpoly_op. Elpi derive.param2 seqpoly. Elpi derive.param2 cast_seqpoly. Elpi derive.param2 seqpoly0. Elpi derive.param2 seqpoly1. Elpi derive.param2 List.map. Elpi derive.param2 opp_seqpoly. Elpi derive.param2 add_seqpoly_fun. Elpi derive.param2 add_seqpoly. Elpi derive.param2 sub_seqpoly. Elpi derive.param2 scale_seqpoly. Elpi derive.param2 mul_seqpoly. Definition exp_seqpoly' := Eval compute in exp_seqpoly. Elpi derive.param2 exp_seqpoly'. Definition exp_seqpoly_R := exp_seqpoly'_R. Elpi derive.param2.register exp_seqpoly exp_seqpoly_R. Elpi derive.param2 size_seqpoly. Elpi derive.param2 eq_seqpoly. Elpi derive.param2 shift_seqpoly. Elpi derive.param2 split_seqpoly. Elpi derive.param2 predn. Elpi derive.param2 lead_coef_seqpoly. Section seqpoly_more_op. Variable R : ringType. Context (C : Type). Context `{zero_of C, one_of C, add_of C, opp_of C, eq_of C}. Context `{spec_of C R}. Fixpoint spec_seqpoly_aux n (s : seqpoly C) : {poly R} := match s with | [::] => 0 | (hd :: tl) => if (hd == 0)%C then spec_seqpoly_aux n.+1 tl else let c := if (n == 0%N) then if (hd == 1)%C then 1 else (spec hd)%:P else let mon := if (n == 1%N) then 'X else 'X^n in if (hd == 1)%C then mon else (spec hd) *: mon in if (tl == 0)%C then c else (spec_seqpoly_aux n.+1 tl) + c end. #[export] Instance spec_seqpoly : spec_of (seqpoly C) {poly R}:= spec_seqpoly_aux 0%N. Lemma spec_aux_shift n s : spec_seqpoly_aux n s = spec_seqpoly_aux 0 s * 'X^n. Proof. elim: s n=> [n|a s ih n] /=; first by rewrite mul0r. simpC; case: ifP=> _. by rewrite ih [in RHS]ih exprS expr1 mulrA. have h : (if n == 0%N then if (a ==1)%C then 1 else (spec a)%:P else if (a == 1)%C then if n == 1%N then 'X : {poly R} else 'X^n else spec a *: (if n == 1%N then 'X else 'X^n)) = (if (a == 1)%C then 1 else (spec a)%:P) * 'X^n. case: n=> [|n] /=; simpC. rewrite expr0 mulr1. by case: ifP=> [/eqP a1|_]. case: ifP=> [/eqP a1|_]. rewrite mul1r. by case: ifP; move/eqP=> // ->; rewrite expr1. rewrite mul_polyC. by case: ifP; move/eqP=> // ->; rewrite expr1. case: ifP=> _; first by rewrite h. rewrite ih [in RHS]ih mulrDl exprS expr1 mulrA. exact: congr2. Qed. (* Cyril: fix this *) Lemma spec_aux_eq0 s : (s == 0)%C -> spec_seqpoly_aux 0 s = 0. Proof. elim: s=> [_|a s ih aseq0] //=. have heq0 : (a == 0)%C /\ (s == 0)%C. move: aseq0; rewrite /(_ == _)%C /eq_seqpoly /= => /andP [a0 s0]. split => //; rewrite /eq_op /eq_seqpoly sub_seqpoly_0. by rewrite s0. by rewrite (proj1 heq0) spec_aux_shift ih ?(proj2 heq0) // mul0r. Qed. End seqpoly_more_op. Arguments spec_seqpoly / _ _ _ _ _ _ _ _ _ : assert. (* (* translations for ringType *) *) (* Parametricity Logic.False. *) (* Parametricity reflect. *) (* Parametricity Equality.mixin_of as equality_mixin_of_R. *) (* Parametricity Logic.ex. *) (* Parametricity Choice.mixin_of as choice_mixin_of_R. *) (* Parametricity Choice.class_of as choice_class_of_R. *) (* Parametricity GRing.Zmodule.mixin_of as gRing_Zmodule_mixin_of_R. *) (* Parametricity GRing.Zmodule.class_of as gRing_Zmodule_class_of_R. *) (* Parametricity GRing.Zmodule.type as gRing_Zmodule_type_R. *) (* Parametricity Equality.type as equality_type_R. *) (* Parametricity GRing.Ring.mixin_of as gRing_Ring_mixin_of_R. *) (* Parametricity GRing.Ring.class_of as gRing_Ring_class_of_R. *) (* Parametricity GRing.Ring.type as gRing_Ring_type_R. *) (* (* translations for poly *) *) (* Parametricity phant. *) (* Parametricity polynomial. *) Section seqpoly_theory. Variable R : ringType. Local Instance zeroR : zero_of R := 0%R. Local Instance oneR : one_of R := 1%R. Local Instance addR : add_of R := +%R. Local Instance mulR : mul_of R := *%R. Local Instance oppR : opp_of R := -%R. Local Instance eqR : eq_of R := eqtype.eq_op. Local Instance specR : spec_of R R := spec_id. Local Instance zero_nat : zero_of nat := 0%N. Local Instance one_nat : one_of nat := 1%N. Local Instance add_nat : add_of nat := addn. Local Instance eq_nat : eq_of nat := eqtype.eq_op. Local Instance spec_nat : spec_of nat nat := spec_id. Definition seqpoly_of_poly (p : {poly R}) : seqpoly R := polyseq p. Definition poly_of_seqpoly (sp : seqpoly R) : {poly R} := \poly_(i < size sp) nth 0 sp i. Definition Rseqpoly : {poly R} -> seqpoly R -> Type := fun_hrel poly_of_seqpoly. Local Open Scope rel_scope. (* zero and one *) Local Instance Rseqpoly_0 : refines Rseqpoly 0%R 0%C. Proof. by rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly poly_def big_ord0. Qed. Local Instance Rseqpoly_1 : refines Rseqpoly 1%R 1%C. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly poly_def /=. by rewrite zmodp.big_ord1 expr0 alg_polyC [(1%:P)]/(1%C) polyC1. Qed. Local Instance Rseqpoly_cons : refines (eq ==> Rseqpoly ==> Rseqpoly) (@cons_poly R) cons. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x -> _ sp <-. rewrite cons_poly_def poly_def big_ord_recl /= expr0 alg_polyC addrC. rewrite /bump poly_def big_distrl /=. apply: congr2=> //. apply: eq_bigr=> i _. by rewrite -[in RHS]mul_polyC -mulrA -exprSr mul_polyC. Qed. Local Instance Rseqpoly_cast : refines (eq ==> Rseqpoly) polyC cast_op. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x ->. rewrite /cast /cast_seqpoly /= poly_def zmodp.big_ord1 /=. by rewrite expr0 alg_polyC. Qed. Local Instance Rseqpoly_opp : refines (Rseqpoly ==> Rseqpoly) -%R -%C. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <-. rewrite !poly_def -GRing.sumrN size_map. apply: eq_bigr=> i _. rewrite -[in RHS]mul_polyC -mulNr -polyCN mul_polyC. by rewrite (nth_map 0%C). Qed. Lemma coef_poly_of_seqpoly (sp : seqpoly R) (i : nat) : (\poly_(j < size sp) sp`_j)`_i = sp`_i. Proof. rewrite coef_poly. have [iltp|pleqi] := ltnP i (size sp)=> //. by rewrite nth_default. Qed. Lemma coef_add_seqpoly (sp sq : seqpoly R) (i : nat) : (sp + sq)%C`_i = sp`_i + sq`_i. Proof. elim: sp sq i=> [sq i|a p ihp [|b q] [|i]] //=. by rewrite [(_ + _)%C]/add_seqpoly /add_seqpoly_fun nth_nil add0r. by rewrite addr0. by rewrite addr0. by rewrite ihp. Qed. Local Instance Rseqpoly_add : refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) +%R +%C. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-. apply/polyP=> i. by rewrite coef_add_poly !coef_poly_of_seqpoly coef_add_seqpoly. Qed. Lemma coef_opp_seqpoly (sp : seqpoly R) (i : nat) : (- sp)%C`_i = - sp`_i. Proof. have [iltp|pleqi] := ltnP i (size sp). by rewrite (nth_map 0%C). by rewrite !nth_default ?oppr0 ?size_map. Qed. Local Instance Rseqpoly_sub : refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) (fun x y => x - y) sub_op. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-. apply/polyP=> i. rewrite coef_add_poly coef_opp_poly !coef_poly_of_seqpoly coef_add_seqpoly. by rewrite coef_opp_seqpoly. Qed. (* scaling *) Lemma coef_scale_seqpoly (sp : seqpoly R) (a : R) (i : nat) : (a *: sp)%C`_i = a * sp`_i. Proof. have [iltp|pleqi] := ltnP i (size sp). by rewrite (nth_map 0%C). by rewrite !nth_default ?mulr0 ?size_map. Qed. Local Instance Rseqpoly_scale : refines (eq ==> Rseqpoly ==> Rseqpoly) *:%R *:%C. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x -> _ sp <-. apply/polyP=> i. by rewrite coefZ !coef_poly_of_seqpoly coef_scale_seqpoly. Qed. (* multiplication *) Local Instance Rseqpoly_mul : refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) *%R *%C. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-. apply/polyP=> i. rewrite coef_poly_of_seqpoly. elim: sp i=> [i|a p ihp i]. by rewrite [(_ * _)%C]/mul_seqpoly poly_def big_ord0 mul0r coef0 nth_nil. rewrite [(_ * _)%C]/mul_seqpoly coef_add_seqpoly coefM big_ord_recl. rewrite !coef_poly_of_seqpoly subn0. apply: congr2; first by rewrite coef_scale_seqpoly. move: ihp; case: i=> [_|i ihp]; first by rewrite big_ord0. rewrite [(_ :: _)`_ _]/= ihp coefM=> {ihp}. apply: eq_bigr=> j _. by rewrite !coef_poly_of_seqpoly. Qed. Local Instance Rseqpoly_exp : refines (Rseqpoly ==> Logic.eq ==> Rseqpoly) (@GRing.exp _) exp_op. Proof. apply refines_abstr2=> p sp hp m n; rewrite refinesE=> -> {m}. rewrite /exp_op /exp_seqpoly. elim: n=> [|n ihn] /=; by rewrite ?(expr0, exprS); tc. Qed. Lemma poly_cons (p : seqpoly R) (a : R) : \poly_(i < size (a :: p)) (a :: p)`_i = a%:P + (\poly_(i < size p) p`_i) * 'X. Proof. rewrite !poly_def big_ord_recl big_distrl /= expr0 alg_polyC /bump /=. apply: congr2=> //; apply: eq_bigr=> i _. by rewrite add1n exprSr scalerAl. Qed. Local Instance Rseqpoly_size : refines (Rseqpoly ==> eq) (sizep (R:=R)) (size_op (N:=nat)). Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <-. rewrite sizepE /size_op. elim: sp=> [|a p ihp]. by rewrite poly_def big_ord0 size_poly0. rewrite poly_cons /= -ihp. case sp: (size (\poly_(i < size p) p`_i))=> [|n] /=; simpC. move /eqP: sp; rewrite size_poly_eq0; move/eqP=> ->. by rewrite mul0r addr0 size_polyC; case: (a == 0). by rewrite addrC size_addl size_mulX ?sp ?size_polyC ?[RHS]addn1; case: (a != 0)=> //; apply/negP; rewrite -size_poly_eq0 sp. Qed. Local Instance Rseqpoly_eq : refines (Rseqpoly ==> Rseqpoly ==> bool_R) eqtype.eq_op eq_op. Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-. have -> : (\poly_(i < size sp) sp`_i == \poly_(i < size sq) sq`_i) = (sp == sq)%C. apply/eqP/allP=> [/polyP heq|heq]. move=> x /(nthP 0%C) [i] hi <-. rewrite coef_add_seqpoly coef_opp_seqpoly; simpC. by have := (heq i); rewrite !coef_poly_of_seqpoly subr_eq0=> ->. apply/polyP=> i; rewrite !coef_poly_of_seqpoly; apply/eqP. have [hlt|] := ltnP i (size (sp - sq)%C). rewrite -subr_eq0 -coef_opp_seqpoly -coef_add_seqpoly [_ == _]heq //. by rewrite mem_nth. have -> : size (sp - sq)%C = maxn (size sp) (size sq)=> [{heq}|hleq]. elim: sp sq=> [sq|a p ihp [|b q]] /=. by rewrite max0n [(_ - _)%C]/add_seqpoly /add_seqpoly_fun size_map. by rewrite maxn0. by rewrite ihp maxnSS. by rewrite !nth_default // (leq_trans _ hleq) // leq_max leqnn ?orbT. exact: bool_Rxx. Qed. (* These can be done with eq instead of nat_R *) Local Instance Rseqpoly_shift : refines (eq ==> Rseqpoly ==> Rseqpoly) (shiftp (R:=R)) (shift_op (N:=nat)). Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ n -> _ sp <-. apply/polyP=> i. rewrite /shiftp coefMXn !coef_poly_of_seqpoly /shift_op /shift_seqpoly. by rewrite nth_ncons. Qed. Local Instance Rseqpoly_split : refines (eq ==> Rseqpoly ==> prod_R Rseqpoly Rseqpoly) (splitp (R:=R)) (split_op (N:=nat)). Proof. rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ n -> _ sp <-. rewrite /split_op /split_seqpoly /splitp /=. apply: prod_RI; rewrite /prod_hrel /=. elim: sp n=> [n|a p ihp [|n]]. by rewrite poly_def big_ord0 rdiv0p rmod0p. by rewrite expr0 rdivp1 rmodp1 [\poly_(_ < 0) _]poly_def big_ord0. rewrite !poly_cons [\poly_(i < size p) p`_i](@rdivp_eq _ 'X^n) ?monicXn //. have [/= -> ->] := ihp n. rewrite mulrDl -mulrA -exprSr addrC -addrA. suff htnp : size (rmodp (\poly_(i < size p) p`_i) 'X^n * 'X + a%:P) < size ('X^n.+1 : {poly R}). by rewrite rdivp_addl_mul_small ?rmodp_addl_mul_small ?monicXn // addrC. rewrite size_polyXn size_MXaddC ltnS; case: ifP=> // _. by rewrite (leq_trans (ltn_rmodpN0 _ _)) ?monic_neq0 ?monicXn ?size_polyXn. Qed. Local Instance Rseqpoly_lead_coef : refines (Rseqpoly ==> eq) lead_coef (lead_coef_seqpoly (N:=nat)). Proof. rewrite refinesE /lead_coef_seqpoly /lead_coef=> p sp hp. rewrite -sizepE [sizep _]refines_eq /size_op -hp /poly_of_seqpoly. by rewrite coef_poly_of_seqpoly. Qed. Local Instance Rseqpoly_head : refines (Rseqpoly ==> Logic.eq) (fun p => p`_0) (fun sp => nth 0%C sp 0). Proof. rewrite refinesE=> _ sp <-. rewrite /poly_of_seqpoly coef_poly_of_seqpoly. by case: sp. Qed. Local Instance Rseqpoly_spec_l : refines (Rseqpoly ==> Logic.eq) spec_id spec. Proof. rewrite refinesE=> _ sp <-. rewrite /spec_id /spec /spec_seqpoly /poly_of_seqpoly. elim: sp=> [|a p ih] /=. by rewrite poly_def big_ord0. rewrite spec_aux_shift expr1 poly_cons ih. simpC. case: ifP=> [/eqP a0|_]; first by rewrite a0 polyC0 add0r. rewrite /spec /specR /spec_id addrC. by case: ifP=> p0; case: ifP=> [/eqP a1|_]; rewrite ?a1 ?polyC1 // spec_aux_eq0 // ?mul0r ?add0r. Qed. Section seqpoly_param. Context (C : Type) (rAC : R -> C -> Type). Context (N : Type) (rN : nat -> N -> Type). Context `{zero_of C, one_of C}. Context `{opp_of C, add_of C, mul_of C, eq_of C}. Context `{implem_of R C, spec_of C R}. Context `{zero_of N, one_of N, add_of N, eq_of N}. Context `{spec_of N nat}. Context `{!refines rAC 0%R 0%C, !refines rAC 1%R 1%C}. Context `{!refines (rAC ==> rAC) -%R -%C}. Context `{!refines (rAC ==> rAC ==> rAC) +%R +%C}. Context `{!refines (rAC ==> rAC ==> rAC) *%R *%C}. Context `{!refines (rAC ==> rAC ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rAC ==> Logic.eq) spec_id spec}. Context `{!refines rN 0%N 0%C, !refines rN 1%N 1%C}. Context `{!refines (rN ==> rN ==> rN) addn +%C}. Context `{!refines (rN ==> rN ==> bool_R) eqtype.eq_op eq_op}. Context `{!refines (rN ==> nat_R) spec_id spec}. Definition RseqpolyC : {poly R} -> seq C -> Type := (Rseqpoly \o list_R rAC)%rel. #[export] Instance RseqpolyC_cons : refines (rAC ==> RseqpolyC ==> RseqpolyC) (@cons_poly R) cons. Proof. param_comp cons_R. Qed. #[export] Instance RseqpolyC_cast : refines (rAC ==> RseqpolyC) polyC cast_op. Proof. param_comp cast_seqpoly_R. Qed. #[export] Instance RseqpolyC_0 : refines RseqpolyC 0%R 0%C. Proof. param_comp seqpoly0_R. Qed. #[export] Instance RseqpolyC_1 : refines RseqpolyC 1%R 1%C. Proof. param_comp seqpoly1_R. Qed. #[export] Instance RseqpolyCN : refines (RseqpolyC ==> RseqpolyC) -%R -%C. Proof. param_comp opp_seqpoly_R. Qed. #[export] Instance RseqpolyCD : refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) +%R +%C. Proof. param_comp add_seqpoly_R. Qed. #[export] Instance RseqpolyC_sub : refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) (fun x y => x - y) sub_op. Proof. param_comp sub_seqpoly_R. Qed. #[export] Instance RseqpolyC_scale : refines (rAC ==> RseqpolyC ==> RseqpolyC) *:%R *:%C. Proof. param_comp scale_seqpoly_R. Qed. #[export] Instance RseqpolyCM : refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) *%R *%C. Proof. param_comp mul_seqpoly_R. Qed. #[export] Instance RseqpolyC_exp : refines (RseqpolyC ==> rN ==> RseqpolyC) (@GRing.exp _) exp_op. Proof. eapply refines_trans; tc. rewrite refinesE; do ?move=> ?*. eapply (@exp_seqpoly_R _ _ _ _ _ rN)=> // *; exact: refinesP. Qed. #[export] Instance RseqpolyC_size : refines (RseqpolyC ==> rN) (sizep (R:=R)) size_op. Proof. rewrite /size_op; param_comp size_seqpoly_R. Qed. #[export] Instance RseqpolyC_eq : refines (RseqpolyC ==> RseqpolyC ==> bool_R) eqtype.eq_op eq_op. Proof. param_comp eq_seqpoly_R. Qed. #[export] Instance RseqpolyC_shift : refines (rN ==> RseqpolyC ==> RseqpolyC) (shiftp (R:=R)) shift_op. Proof. (* param_comp shift_seqpoly_R does a mistake on the instantiation of a relation, why? *) eapply refines_trans; tc. rewrite refinesE; do ?move=> ?*. eapply (@shift_seqpoly_R _ _ _ _ _ rN)=> // *; exact: refinesP. Qed. #[export] Instance RseqpolyCMXn p sp n rn : refines rN n rn -> refines RseqpolyC p sp -> refines RseqpolyC (p * 'X^n) (shift_op rn sp). Proof. move=> hn hp; rewrite -[_ * 'X^_]/(shiftp _ _). apply: refines_apply. Qed. Lemma mulXnC (p : {poly R}) n : p * 'X^n = 'X^n * p. Proof. apply/polyP=> i. by rewrite coefMXn coefXnM. Qed. #[export] Instance RseqpolyC_Xnmul p sp n rn : refines rN n rn -> refines RseqpolyC p sp -> refines RseqpolyC ('X^n * p) (shift_op rn sp). Proof. rewrite -mulXnC; exact: RseqpolyCMXn. Qed. #[export] Instance RseqpolyC_scaleXn c rc n rn : refines rN n rn -> refines rAC c rc -> refines RseqpolyC (c *: 'X^n) (shift_op rn (cast rc)). Proof. move=> hn hc; rewrite -mul_polyC -[_ * 'X^_]/(shiftp _ _). apply: refines_apply. Qed. #[export] Instance RseqpolyCMX p sp : refines RseqpolyC p sp -> refines RseqpolyC (p * 'X) (shift_op (1%C : N) sp). Proof. rewrite -['X]expr1; exact: RseqpolyCMXn. Qed. #[export] Instance RseqpolyC_Xmul p sp : refines RseqpolyC p sp -> refines RseqpolyC ('X * p) (shift_op (1%C : N) sp). Proof. rewrite -['X]expr1 -mulXnC; exact: RseqpolyCMX. Qed. #[export] Instance RseqpolyC_scaleX c rc : refines rAC c rc -> refines RseqpolyC (c *: 'X) (shift_op (1%C : N) (cast rc)). Proof. rewrite -['X]expr1; exact: RseqpolyC_scaleXn. Qed. (* Uses composable_prod *) #[export] Instance RseqpolyC_split : refines (rN ==> RseqpolyC ==> prod_R RseqpolyC RseqpolyC) (splitp (R:=R)) split_op. Proof. have: refines (rN ==> list_R rAC ==> prod_R (list_R rAC) (list_R rAC)) split_op split_op. rewrite refinesE; do ?move=> ?*. eapply (@split_seqpoly_R _ _ _ _ _ rN)=> // *. exact: refinesP. exact: refines_trans Rseqpoly_split. Qed. #[export] Instance RseqpolyC_splitn n rn p sp : refines rN n rn -> refines RseqpolyC p sp -> refines (prod_R RseqpolyC RseqpolyC) (splitp n p) (split_op rn sp). Proof. by move=> hn hp; apply: refines_apply. Qed. Definition eq_prod_seqpoly (x y : (seqpoly C * seqpoly C)) := (eq_op x.1 y.1) && (eq_op x.2 y.2). #[export] Instance refines_prod_RseqpolyC_eq : refines (prod_R RseqpolyC RseqpolyC ==> prod_R RseqpolyC RseqpolyC ==> bool_R) eqtype.eq_op eq_prod_seqpoly. Proof. rewrite refinesE => _ _ [x1 x'1 hx1 x2 x'2 hx2] _ _ [y1 y'1 hy1 y2 y'2 hy2]. by apply: andb_R => /=; apply: refinesP. Qed. #[export] Instance RseqpolyC_lead_coef : refines (RseqpolyC ==> rAC) lead_coef (lead_coef_seqpoly (N:=N)). Proof. param_comp lead_coef_seqpoly_R. Qed. Local Instance refines_refl_nat : forall m, refines nat_R m m | 999. Proof. by rewrite refinesE; apply: nat_Rxx. Qed. #[export] Instance RseqpolyC_head : refines (RseqpolyC ==> rAC) (fun p => p`_0) (fun sp => nth 0%C sp 0). Proof. eapply refines_trans; tc. rewrite refinesE=> l l' rl. apply nth_R; exact: refinesP. Qed. #[export] Instance RseqpolyC_X : refines RseqpolyC 'X (shift_op (1%C : N) 1)%C. Proof. rewrite -['X]mul1r; exact: RseqpolyCMX. Qed. #[export] Instance RseqpolyC_Xn n rn : refines rN n rn -> refines RseqpolyC 'X^n (shift_op rn 1)%C. Proof. move=> hn; rewrite -['X^_]mul1r; exact: RseqpolyCMXn. Qed. (* Lemma gRing_Ring_type_Rxx r : gRing_Ring_type_R r r. *) (* Proof. *) (* Admitted. *) (* #[export] Instance RseqpolyC_spec_l : *) (* refines (RseqpolyC ==> (@polynomial_R _ _ (gRing_Ring_type_Rxx R))) *) (* spec_id spec. *) (* Proof. *) (* Admitted. *) #[export] Instance RseqpolyC_spec : refines (RseqpolyC ==> eq) spec_id spec. Proof. eapply refines_trans; tc. rewrite refinesE=> l l' rl. elim: rl=> [|x y rx p q rp] {l l'}; rewrite /spec /spec_seqpoly //=. rewrite ![spec_seqpoly_aux 1 _]spec_aux_shift=> ->. have -> : (p == 0)%C = (q == 0)%C. elim: rp=> [|a b ra l l' rl] {p q} //=. rewrite /eq_op /eq_seqpoly /=. by simpC; rewrite [(_ == _)]refines_eq !sub_seqpoly_0=> ->. rewrite /spec /specR [spec_id _]refines_eq /spec [(_ == _)%C]refines_eq. by rewrite [(_ == 1)%C]refines_eq. Qed. End seqpoly_param. End seqpoly_theory. (* Always simpl Poly. Maybe have refinement instance instead? Is this *) (* more efficient? *) #[export] Hint Extern 0 (refines _ (Poly _) _) => simpl : typeclass_instances. #[export] Hint Extern 0 (refines _ _ (Poly _)) => simpl : typeclass_instances. From mathcomp Require Import ssrint. From CoqEAL Require Import binnat binint. Section testpoly. Goal (0 == 0 :> {poly int}). by coqeal. Abort. Goal (0 == (0 : {poly {poly {poly int}}})). (* by coqeal. *) Abort. Goal (1 == 1 :> {poly int}). by coqeal. Abort. Goal (1 == (1 : {poly {poly {poly int}}})). (* by coqeal. *) Abort. Goal ((1 + 2%:Z *: 'X + 3%:Z *: 'X^2) + (1 + 2%:Z%:P * 'X + 3%:Z%:P * 'X^2) == (1 + 1 + (2%:Z + 2%:Z) *: 'X + (3%:Z + 3%:Z)%:P * 'X^2)). rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. (* by coqeal. *) Abort. Goal (Poly [:: 1; 2%:Z; 3%:Z] + Poly [:: 1; 2%:Z; 3%:Z]) == Poly [:: 1 + 1; 2%:Z + 2%:Z; 2%:Z + 4%:Z]. by coqeal. Abort. Goal (- 1 == - (1: {poly {poly int}})). (* by coqeal. *) Abort. Goal (- (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2) == -1 - 2%:Z%:P * 'X - 3%:Z *: 'X^2). by coqeal. Abort. Goal (- Poly [:: 1; 2%:Z; 3%:Z]) == Poly [:: - 1; - 2%:Z; - 3%:Z]. by coqeal. Abort. Goal (1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) == 0). by coqeal. Abort. Goal (Poly [:: 1; 2%:Z; 3%:Z] - Poly [:: 1; 2%:Z; 3%:Z]) == 0. by coqeal. Abort. Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z *: 'X^2). by coqeal. Abort. Goal (Poly [:: 1; 2%:Z] * Poly [:: 1; 2%:Z]) == Poly [:: 1; 4%:Z; 4%:Z]. by coqeal. Abort. (* (1 + xy) * x = x + x^2y *) Goal ((1 + 'X * 'X%:P) * 'X == 'X + 'X^2 * 'X%:P :> {poly {poly int}}). rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. (* by coqeal. *) Abort. Goal (Poly [:: Poly [:: 1; 0]; 1] * Poly [:: 1; 0]) == Poly [:: Poly [:: 1; 0]; 1 ; 0] :> {poly {poly int}}. rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=. by coqeal. Abort. Goal (sizep ('X^2 : {poly int}) == sizep (- 3%:Z *: 'X^(sizep ('X : {poly int})))). by coqeal. Abort. Goal (sizep (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) == 3%N). by coqeal. Abort. Goal (sizep (Poly [:: 1; 2%:Z; 3%:Z]) == 3%nat). by coqeal. Abort. Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int}))) == 1 + 4%:Z *: 'X + 4%:Z *: 'X^(sizep (10%:Z *: 'X))). by coqeal. Abort. Goal (splitp 2 (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) == (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)). by coqeal. Abort. Goal (splitp (sizep ('X : {poly int})) (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) == (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)). by coqeal. Abort. Goal (splitp 2%nat (Poly [:: 1; 2%:Z; 3%:Z; 4%:Z]) == (Poly [:: 3%:Z; 4%:Z], Poly [:: 1; 2%:Z])). rewrite /= [_ == _]refines_eq. by compute. Abort. (* Test shiftp *) Goal (2%:Z *: shiftp 2%nat 1 == Poly [:: 0; 0; 2%:Z]). by coqeal. Abort. End testpoly. coqeal-2.1.0/refinements/trivial_seq.v000066400000000000000000000043201475512565300200220ustar00rootroot00000000000000From elpi Require Import derive. Require Import ZArith. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq zmodp. From mathcomp Require Import path choice fintype tuple finset ssralg ssrnum bigop ssrint. From CoqEAL Require Import hrel param refinements. Import Refinements.Op. Section size_seq. Context (A : Type) (N : Type) `{zero_of N} `{one_of N} `{add_of N}. #[export] Instance size_seq : size_of (seq A) N := fix size xs := if xs is x :: s then (size s + 1)%C else 0%C. End size_seq. Elpi derive.param2 size_seq. Lemma size_seqE T (s : seq T) : (@size_seq _ _ 0%N 1%N addn) s = size s. Proof. by elim: s => //= x s ->; rewrite [(_ + _)%C]addn1. Qed. Section seq_refines. Local Open Scope rel_scope. Variable (A C : Type) (rAC : A -> C -> Type). Variable (N : Type) (rN : nat -> N -> Type). Context `{implem_of A C} `{spec_of N nat}. Context `{zero_of N} `{one_of N} `{add_of N}. Context `{!refines (Logic.eq ==> rAC) implem_id implem}. Context `{!refines (rN ==> nat_R) spec_id spec}. Context `{!refines rN 0%N 0%C}. Context `{!refines rN 1%N 1%C}. Context `{!refines (rN ==> rN ==> rN) addn add_op}. #[export] Instance refine_nth1 : refines (rAC ==> list_R rAC ==> rN ==> rAC) nth (fun x s (n : N) => nth x s (spec n)). Proof. param nth_R. rewrite -[X in refines _ X _]/(spec_id _); exact: refines_apply. Qed. #[export] Instance refine_nth2 : refines (list_R (list_R rAC) ==> rN ==> list_R rAC) (nth [::]) (fun s (n : N) => nth [::] s (spec n)). Proof. param nth_R. rewrite refinesE; exact: nil_R. rewrite -[X in refines _ X _]/(spec_id _); exact: refines_apply. Qed. #[export] Instance refine_list_R2_implem s : refines (list_R (list_R rAC)) s (map (map implem) s). Proof. rewrite refinesE. elim: s=> [|a s ihs] /=. exact: nil_R. apply: cons_R. elim: a=> [|hd tl ih] /=. exact: nil_R. apply: cons_R. have heq : refines eq hd hd by rewrite refinesE. rewrite -[X in rAC X _]/(implem_id _). exact: refinesP. exact: ih. exact: ihs. Qed. #[export] Instance refine_size : refines (list_R rAC ==> rN) size size_op. Proof. by rewrite refinesE => s s' rs; rewrite -[size s]size_seqE; param size_seq_R. Qed. End seq_refines. coqeal-2.1.0/theory/000077500000000000000000000000001475512565300143055ustar00rootroot00000000000000coqeal-2.1.0/theory/atomic_operations.v000066400000000000000000000157631475512565300202270ustar00rootroot00000000000000 From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. From mathcomp Require Import ssralg fintype perm choice. From mathcomp Require Import matrix bigop zmodp mxalgebra poly mxpoly. Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. Open Scope ring_scope. Section atomic_operations. Variable R: comRingType. (* describe simple line / column combination operators *) (* Operation to multiply Lk by a the scalar a *) Definition line_scale n m k (a: R) (M: 'M[R]_(n,m)) := \matrix_(i < n) ((if i == k then a else 1) *: row i M). Lemma line_scale_row_eq n m k a (M: 'M[R]_(n,m)): row k (line_scale k a M) = a *: row k M. Proof. by apply/rowP => i; rewrite !mxE eqxx. Qed. Lemma line_scale_row_neq n m k l a (M: 'M[R]_(n,m)): k != l -> row l (line_scale k a M) = row l M. Proof. move/negbTE => hkl. by apply/rowP => i; rewrite !mxE eq_sym hkl mul1r. Qed. (* several application of the line_scale operation *) Lemma lines_scale_row m n a (M: 'M[R]_(m,n)): forall s, uniq s -> (forall i, i \in s -> row i (foldl (fun N i => line_scale i a N) M s) = a *: row i M) /\ (forall i, i \notin s -> row i (foldl (fun N i => line_scale i a N) M s) = row i M). Proof. move => s. elim : s n M => [ | hd tl hi] //= n M /andP [h1 h2]. split => i; rewrite in_cons. - move/orP => [/eqP{i}-> | hin]. + case: (hi _ (line_scale hd a M) h2) => _ hr. by rewrite hr // line_scale_row_eq. case: (hi _ (line_scale hd a M) h2) => -> // _. rewrite line_scale_row_neq //. by apply: contraNneq h1 => ->. rewrite negb_or => /andP[hl hr]. case: (hi _ (line_scale hd a M) h2) => _ hR. by rewrite hR // line_scale_row_neq // eq_sym. Qed. (* alternative definition of the same operation by matrix multiplication this definition is easier to prove determinant property of the operator *) Definition line_scale_mx n m k (a: R) (M: 'M[R]_(n,m)) := diag_mx (\row_(i < n) (if i == k then a else 1)) *m M. Lemma line_scale_eq : forall n m k a (M: 'M[R]_(n,m)), line_scale k a M = line_scale_mx k a M. Proof. move => n m k a M; apply/matrixP => i j; rewrite !mxE. rewrite (bigD1 i) //= big1 /=; first by rewrite !mxE addr0 eqxx. by move => x /negbTE hx; rewrite !mxE [i == x]eq_sym hx mulr0n mul0r. Qed. (* line_scale_mx scales the determinant by a *) Lemma det_line_scale_mx : forall n k a (M: 'M[R]_n), \det (line_scale_mx k a M) = a * \det M. Proof. rewrite /line_scale_mx => n k a M. rewrite det_mulmx det_diag (bigD1 k) //= big1 /=; first by rewrite !mxE mulr1 eqxx. by move => i /negbTE h; rewrite !mxE h. Qed. (* line_scale scales the determinant by a *) Lemma det_line_scale : forall n k a (M: 'M[R]_n), \det (line_scale k a M) = a * \det M. Proof. move => n k a M. by rewrite line_scale_eq det_line_scale_mx. Qed. Lemma det_lines_scale m a (M: 'M[R]_m) s: \det (foldl (fun N i => line_scale i a N) M s) = a ^+ (size s) * \det M. Proof. elim : s M => [ | hd tl hi] M //=. - by rewrite expr0 mul1r. by rewrite hi det_line_scale mulrA exprSr. Qed. (* Operation to change Lk by Lk + a Ll *) Definition line_comb n m k l (a: R) (M: 'M[R]_(n,m)) := \matrix_(i < n) if i == k then row k M + a*: row l M else row i M. Lemma line_comb_row_eq n m k l a (M: 'M[R]_(n,m)): row k (line_comb k l a M) = row k M + a *: row l M. Proof. by apply/rowP => i; rewrite !mxE eqxx !mxE. Qed. Lemma line_comb_row_neq n m k k' l a (M: 'M[R]_(n,m)): k != k' -> row k' (line_comb k l a M) = row k' M. Proof. move/negbTE => hkk'. by apply/rowP => i; rewrite !mxE eq_sym hkk' !mxE. Qed. (* several application of the line_comb operation *) Lemma lines_comb_row m n a l (M: 'M[R]_(m,n)): forall s, uniq s -> l \notin s -> (forall i, i \in s -> row i (foldl (fun N i => line_comb i l a N) M s) = row i M + a *: row l M) /\ (forall i, i \notin s -> row i (foldl (fun N i => line_comb i l a N) M s) = row i M). Proof. move => s. elim : s M => [ | hd tl hi] //= M /andP [h1 h2]. rewrite in_cons negb_or => /andP [hl1 hl2]. split => i; rewrite in_cons. - move/orP => [/eqP{i}-> | hin]. + case: (hi (line_comb hd l a M) h2 hl2) => _ hr. by rewrite hr // line_comb_row_eq. case: (hi (line_comb hd l a M) h2 hl2) => -> // _. rewrite !line_comb_row_neq // eq_sym // eq_sym. by apply: contraNneq h1 => ->. rewrite negb_or => /andP [hl hr]. case: (hi (line_comb hd l a M) h2 hl2) => _ hR. by rewrite hR // !line_comb_row_neq // eq_sym. Qed. Lemma lines_comb_row_dep m n (a: 'I_m -> R) l (M: 'M[R]_(m,n)): forall s, uniq s -> l \notin s -> (forall i, i \in s -> row i (foldl (fun N i => line_comb i l (a i) N) M s) = row i M + (a i) *: row l M) /\ (forall i, i \notin s -> row i (foldl (fun N i => line_comb i l (a i) N) M s) = row i M). Proof. move => s. elim : s M => [ | hd tl hi] //= M /andP [h1 h2]. rewrite in_cons negb_or => /andP [hl1 hl2]. split => i; rewrite in_cons. - move/orP => [/eqP{i}-> | hin]. + case: (hi (line_comb hd l (a hd) M) h2 hl2) => _ hr. by rewrite hr // line_comb_row_eq. case: (hi (line_comb hd l (a hd) M) h2 hl2) => -> // _. rewrite !line_comb_row_neq // eq_sym // eq_sym. by apply: contraNneq h1 => ->. rewrite negb_or => /andP [hl hr]. case: (hi (line_comb hd l (a hd) M) h2 hl2) => _ hR. by rewrite hR // !line_comb_row_neq // eq_sym. Qed. (* if k != l, line_comb doesn't change the det *) Lemma det_line_comb : forall n k l a (M: 'M[R]_n), k != l -> \det (line_comb k l a M) = \det M. Proof. move => n k l a M hkl. have h : row k (line_comb k l a M) = 1 *: row k M + a *: row k (\matrix_(i < n) if i == k then row l M else row i M). by rewrite scale1r; apply/rowP => i; rewrite !mxE eqxx !mxE. rewrite (determinant_multilinear h). - rewrite mul1r [X in a * X](determinant_alternate hkl). + by rewrite mulr0 addr0. by move => x; rewrite !mxE eqxx eq_sym (negbTE hkl). - by apply/matrixP => i j; rewrite !mxE eq_sym (negbTE (neq_lift k i)) !mxE. by apply/matrixP => i j; rewrite !mxE eq_sym (negbTE (neq_lift k i)) !mxE. Qed. Lemma det_lines_comb m a l (M: 'M[R]_m) s: l \notin s -> \det (foldl (fun N i => line_comb i l a N) M s) = \det M. Proof. elim : s M => [ | hd tl hi] M //=. rewrite in_cons negb_or => /andP [hl1 hl2]. by rewrite hi // det_line_comb // eq_sym. Qed. Lemma det_lines_comb_dep m (a: 'I_m -> R) l (M: 'M[R]_m) s: l \notin s -> \det (foldl (fun N i => line_comb i l (a i) N) M s) = \det M. Proof. elim : s M => [ | hd tl hi] M //=. rewrite in_cons negb_or => /andP [hl1 hl2]. by rewrite hi // det_line_comb // eq_sym. Qed. (* if k == l, line_comb == line_scale *) Lemma det_line_comb_eq : forall n k l a (M: 'M[R]_n), k == l -> \det (line_comb k l a M) = (1 + a) * \det M. Proof. move => n k l a M /eqP ->; clear k. have h : row l (line_comb l l a M) = 1 *: row l M + a *: row l M. - rewrite /line_scale. by apply/rowP => i; rewrite !mxE eqxx !mxE mul1r. rewrite (determinant_multilinear h) ?mulrDl //. rewrite /line_scale; apply/matrixP => i j; rewrite !mxE. by rewrite eq_sym (negbTE (neq_lift l i)) !mxE. rewrite /line_scale; apply/matrixP => i j; rewrite !mxE. by rewrite eq_sym (negbTE (neq_lift l i)) !mxE. Qed. End atomic_operations. coqeal-2.1.0/theory/bareiss.v000066400000000000000000000350661475512565300161360ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) (* Formalization of the Sasaki-Murao algorithm *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path ssralg. From mathcomp Require Import fintype perm choice matrix bigop zmodp poly polydiv mxpoly. From CoqEAL Require Import ssrcomplements minor dvdring. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. (* First some general lemmas *) Section prelude. Variable R : comRingType. Lemma bareiss_key_lemma m d l (c : 'cV[R]_m) M : d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l). Proof. rewrite -[d ^+ m]mul1r -det_scalar -(det1 _ 1) -(det_ublock _ 0) -det_mulmx. rewrite mulmx_block ?(mul0mx,addr0,add0r,mul1mx,mul_scalar_mx) -2![LHS]mul1r. rewrite -{1}(@det1 _ 1) -{2}(@det1 _ m) mulrA -(@det_lblock _ _ _ _ (- c)). rewrite -det_mulmx mulmx_block ?(mul1mx,mul0mx,addr0) addrC mul_mx_scalar. by rewrite scalerN subrr det_ublock det_scalar1 addrC mulNmx. Qed. (* The key lemma of our proof: after simplification, all the k-minors *) (* (involving 1st line/column) can be divided by (M 0 0)^k *) Lemma bareiss_key_lemma_sub m n k d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n): d * (minor f1 f2 (d *: M - c *m l)) = d ^+ k * (minor (lift_pred f1) (lift_pred f2) (block_mx d%:M l c M)). Proof. by rewrite /minor submatrix_lift_block bareiss_key_lemma submatrix_add submatrix_scale submatrix_opp submatrix_mul. Qed. Lemma bareiss_block_key_lemma_sub m n k (M : 'M[R]_(1 + m,1 + n)) (f : 'I_k -> 'I_m) (g : 'I_k -> 'I_n) : M 0 0 * (minor f g (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)) = M 0 0 ^+ k * (minor (lift_pred f) (lift_pred g) M). Proof. rewrite /minor -{7}[M]submxK submatrix_add submatrix_scale submatrix_opp. have -> : ulsubmx M = (M 0 0)%:M by apply/rowP=> i; rewrite ord1 !mxE !lshift0. by rewrite submatrix_lift_block bareiss_key_lemma submatrix_mul. Qed. End prelude. Require Import polydvd. Module poly. Section bareiss. Variable R : comRingType. Fixpoint bareiss_rec m (a : {poly R}) : 'M[{poly R}]_(1 + m, 1 + m) -> {poly R} := if m is p.+1 then fun M => let d := M 0 0 in let l := ursubmx M in let c := dlsubmx M in let N := drsubmx M in let M' := d *: N - c *m l in let M'' := map_mx (fun x => rdivp x a) M' in bareiss_rec d M'' else fun M => M 0 0. Definition bareiss n (M : 'M_(1 + n, 1 + n)) : {poly R} := bareiss_rec 1 M. Definition bareiss_char_poly n (M : 'M_(1 + n, 1 + n)) : {poly R} := bareiss (char_poly_mx M). (* The actual determinant function based on Bareiss *) Definition bdet n (M : 'M_(1 + n, 1 + n)) : R := (bareiss_char_poly (- M))`_0. End bareiss. Section bareiss_correctness. Variable R : comRingType. Lemma bareiss_recE : forall m a (M : 'M[{poly R}]_(1 + m)), a \is monic -> (forall p (h h' : p < 1 + m), pminor h h' M \is monic) -> (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) -> a ^+ m * (bareiss_rec a M) = \det M. Proof. elim=> [a M _ _ _|m ih a M am hpm hdvd] /=. by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1. have ak_monic k : a ^+ k \is monic by apply/monic_exp. set d := M 0 0; set M' := (_ - _); set M'' := map_mx _ _; rewrite /= in M' M'' *. have d_monic : d \is monic. have -> // : d = pminor (ltn0Sn _) (ltn0Sn _) M. have h : widen_ord (ltn0Sn m.+1) =1 (fun=> 0) by move=> x; apply/ord_inj; rewrite [x]ord1. by rewrite /pminor (minor_eq h h) minor1. have dk_monic : forall k, d ^+ k \is monic by move=> k; apply/monic_exp. have hM' : M' = a *: M''. pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else lift 0 i. apply/matrixP => i j. rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //. move: (hdvd 1%nat (f _ i) (f _ j)). by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1. rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)). have -> : matrix.ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0. rewrite bareiss_key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA. rewrite ih // => [p h h'|k f g]. rewrite -(@monicMl _ (a ^+ p.+1)) // -detZ -submatrix_scale -hM'. rewrite -(monicMl _ d_monic) bareiss_block_key_lemma_sub monicMr //. by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm. case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)) => // x hx. apply/rdvdpP => //; exists x. apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic). rewrite -detZ -submatrix_scale -hM' bareiss_block_key_lemma_sub. by rewrite mulrA [x * _]mulrC mulrACA -exprS [_ * x]mulrC -hx. Qed. Lemma bareissE n (M : 'M[{poly R}]_(1 + n)) (H : forall p (h h' : p < 1 + n), pminor h h' M \is monic) : bareiss M = \det M. Proof. rewrite /bareiss -(@bareiss_recE n 1 M) ?monic1 ?expr1n ?mul1r //. by move=> k f g; rewrite expr1n rdvd1p. Qed. Lemma bareiss_char_polyE n (M : 'M[R]_(1 + n)) : bareiss_char_poly M = char_poly M. Proof. rewrite /bareiss_char_poly bareissE // => p h h'. exact: pminor_char_poly_mx_monic. Qed. Lemma bdetE n (M : 'M[R]_(1 + n)) : bdet M = \det M. Proof. rewrite /bdet bareiss_char_polyE char_poly_det. by rewrite -scaleN1r detZ mulrA -expr2 sqrr_sign mul1r. Qed. End bareiss_correctness. End poly. Module dvdring. Section Bareiss2. Variable R: dvdRingType. Definition dvd_step (m n:nat) (d: R) (M: 'M[R]_(m,n)) : 'M[R]_(m,n) := map_mx (fun x => odflt 0 (x %/? d)) M. (* determinant equality for division step *) Lemma det_dvd_step: forall n a (M: 'M[R]_n), (forall i j, a %| M i j) -> a^+n * \det (dvd_step a M) = \det M. Proof. rewrite /dvd_step => n a M hj. rewrite -detZ; f_equal. apply/matrixP => i j; rewrite !mxE. case: odivrP=>[d|h] /=; first by rewrite mulrC. case/dvdrP: (hj i j) => d hd. by move: (h d); rewrite hd eqxx. Qed. Lemma det_dvd_step_tool : forall m n a (M N: 'M[R]_(m,n)), M = a *: N -> forall i j, a %| M i j. Proof. move => m n a M N /matrixP h i j. rewrite (h i j) !mxE mulrC. by apply/dvdr_mull/dvdrr. Qed. Let lreg := GRing.lreg. (* some rewriting lemmas to make the main proof more clear *) Lemma blockE00 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)): (block_mx d%:M l c M) 0 0 = d. Proof. rewrite !mxE. case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. by case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. Qed. Lemma blockE0i m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i: (block_mx d%:M l c M) 0 (lift 0 i) = (l 0 i). Proof. rewrite !mxE. case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. case: splitP => x; first by rewrite [x]ord1. by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. Qed. Lemma blockEi0 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i: (block_mx d%:M l c M) (lift 0 i) 0 = (c i 0). Proof. rewrite !mxE. case: splitP => x; first by rewrite [x]ord1. rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. rewrite !mxE. by case: splitP => y //; rewrite [y]ord1 {y} => _. Qed. Lemma blockEij m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i j: (block_mx d%:M l c M) (lift 0 i) (lift 0 j) = (M i j). Proof. rewrite !mxE. case: splitP => x; first by rewrite [x]ord1. rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. rewrite !mxE. case: splitP => y; first by rewrite [y]ord1. by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. Qed. (* main step of the proof *) Lemma sketch m n (a d: R) (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)): lreg a -> (forall (k:nat) (f1: 'I_k.+1 -> 'I_(1 + m)) (f2: 'I_k.+1 -> 'I_(1 + n)), a ^+ k %| minor f1 f2 (block_mx d%:M l c M))-> (forall p (h: p.+1 <= 1 + m) (h': p.+1 <= 1 + n), lreg (pminor h h' (block_mx d%:M l c M))) -> let M' := d *: M - c *m l in let M'':= dvd_step a M' in [/\ lreg d, (forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n), d ^+ k %| minor f1 f2 M''), M' = a *: M'' & (forall p (h: p.+1 <= m) (h': p.+1 <= n), lreg (pminor h h' M''))]. Proof. rewrite /pminor => ha hM hN. set M0 := block_mx d%:M l c M. (* d is the 1x1 principal minor of M0 *) have hh : d = minor (widen_ord (ltn0Sn _)) (widen_ord (ltn0Sn _)) M0. - rewrite (@minor_eq _ _ _ _ _ (fun _ => 0) _ (fun _ => 0)) ?minor1 //. + by rewrite /M0 blockE00. + by move => x; rewrite ord1; apply: val_inj. + by move => x; rewrite ord1; apply: val_inj. (* all principal minors of M0 are lreg, so M 0 0 is *) have h2 : lreg d. - by rewrite hh /M0; apply hN. set M' := d *: M - c *m l. set M'' := dvd_step a M'. set f : forall m, 'I_m -> 'I_2 -> 'I_(1 + m) := fun m (i: 'I_m) (x: 'I_2) => if x == 0 then 0 else (lift 0 i). (* all elements of M' can be expressed as 2x2 minors of M, so a divide all these *) have h4 : forall i j, a %| M' i j. - move => i j; rewrite /M' !mxE big_ord_recl big_ord0 addr0. move: (hM 1%nat (f _ i) (f _ j)). (* (hstrict _ i)). *) by rewrite !minor2 /f /= expr1 blockE00 blockEi0 blockE0i blockEij. (* since a divides all M' i j, all the divisions are exact, and thus M' = a * M'' *) have h6 : forall i j, M' i j = a * M'' i j. - move => i j; rewrite [(dvd_step _ _) i j]mxE. case: odivrP => [dv|h] /=; first by rewrite mulrC. case/dvdrP: (h4 i j) => dv hdv. by move: (h dv); rewrite hdv eqxx. have h6' : M' = a *: M'' by apply/matrixP => i j; rewrite h6 !mxE. (* from this equality, we can have more information about the minors of M' and M'' *) have h7 : forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n), minor f1 f2 M' = a ^+ k * minor f1 f2 M''. - move => k f1 f2. by rewrite h6' /minor submatrix_scale detZ. (* using all theses, we can now prove our goals *) have h8: forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n), d * minor f1 f2 M' = d ^+ k * minor (lift_pred f1) (lift_pred f2) M0. - move => k f1 f2. by rewrite /M0 /M' bareiss_key_lemma_sub. have ak : forall k, lreg (a^+k). - by move => k; apply/lregX. have h10 : forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n), d ^+ k %| minor f1 f2 M''. - move => k f1 f2. move/lregP : (ak k.+1) => ak'. rewrite -(@dvdr_mul2l _ (a^+k.+1)) // -h7. have hM0 : d != 0 by apply/lregP. have hMk : d^+ k.+1 != 0 by apply/lregP/lregX. rewrite -(@dvdr_mul2l _ d) // mulrA h8 //. by rewrite mulrAC -exprS dvdr_mul2l //. split=> //. rewrite -/M'' => p h h'. apply/(@lregMl _ (a ^+ p.+1)). rewrite -h7. apply/(@lregMl _ d). rewrite h8. apply/lregM; first by apply/lregX. rewrite (@minor_eq _ _ _ _ _ (widen_ord (size_tool h)) _ (widen_ord (size_tool h'))) ?hN. - by apply: hN. - by move => x; apply: val_inj; rewrite lift_pred_widen_ord. - by move => x; apply: val_inj; rewrite lift_pred_widen_ord. Qed. (* formal definition of bareiss algorithm *) Fixpoint bareiss_rec m a : 'M[R]_(1 + m) -> R := if m is p.+1 return 'M[R]_(1 + m) -> R then fun (M: 'M[R]_(1 + _)) => let d := M 0 0 in let l := ursubmx M in let c := dlsubmx M in let N := drsubmx M in let M' := d *: N - c *m l in let M'' := dvd_step a M' in bareiss_rec d M'' else fun M => M 0 0. (* from sketch, we can express the properties of bareiss *) Lemma bareiss_recE : forall m a (M: 'M[R]_(1 + m)), lreg a -> (forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_m.+1), a ^+ k %| minor f1 f2 M) -> (forall p (h h' :p.+1 <= 1 + m), lreg (minor (widen_ord h) (widen_ord h') M)) -> a ^+ m * (bareiss_rec a M) = \det M. Proof. elim => [ | m hi] //=. - move => a M ha h1 h2. by rewrite expr0 {2}[M]mx11_scalar det_scalar1 mul1r. rewrite [(1 + m.+1)%nat]/(1 + (1 + m))%nat => a M ha. set d := M 0 0. set l := ursubmx M. set c := dlsubmx M. set N := drsubmx M. have heq : block_mx (M 0 0)%:M (ursubmx M) (dlsubmx M) (drsubmx M) = M. - have -> : (M 0 0)%:M = ulsubmx M by apply/matrixP => i j; rewrite !mxE [i]ord1 [j]ord1 {i j} !lshift0. by rewrite submxK. rewrite -{1 2}heq => hM hm. have : forall p (h h': p.+1 <= 1 + (1 + m)), lreg (minor (widen_ord h) (widen_ord h') M). - rewrite -heq => p h h'. rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)) ?hm//. by move => x; apply/ord_inj. case: (@sketch _ _ a (M 0 0) (ursubmx M) (dlsubmx M) (drsubmx M) ha hM hm) => hM00 h1 h2 h3 hlreg. have h3' : forall p (h h': p < 1 + m), lreg (pminor h h' (dvd_step a (d *: N - c *m l))) by move => p h h'; apply/h3. move: (hi d (dvd_step a (d *: N - c *m l)) hM00 h1 h3'). set r := bareiss_rec _ _ => hh. have : a ^+ m.+1 *( d ^+m * r) = a ^+ m.+1 * \det (dvd_step a (d *: N - c *m l)) by rewrite hh. rewrite det_dvd_step //; last by move => i j; apply (det_dvd_step_tool h2). move => heq2. have hX : lreg (M 0 0 ^+ (1 + m)) by apply/lregX. apply/hX. rewrite -{3}heq bareiss_key_lemma -heq2 [M 0 0 ^+ (1 + m)]exprS -mulrA. congr(_ * _). by rewrite mulrCA. Qed. (* we start the algorithm with a = 1 *) Definition bareiss (n: nat) (M: 'M[R]_(1 + n)) := bareiss_rec 1 M. Lemma bareissE : forall n (M: 'M[R]_(1 + n)), (forall p (h h': p.+1 <= 1 + n), lreg (pminor h h' M)) -> bareiss M = \det M. Proof. rewrite /bareiss => n M h. have h1 : lreg (1: R) by apply/lreg1. have h2 : forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_n.+1), 1 ^+ k %| minor f1 f2 M. - by move => k f1 f2; rewrite expr1n dvd1r. move: (bareiss_recE h1 h2 h). by rewrite expr1n mul1r. Qed. End Bareiss2. (* In practice, we apply this algorithm to the characteristic matrix so we get the characteristic polynomial in polynomial time *) Import PolyDvdRing. Section bareiss_det. Variable R: dvdRingType. (* all principal minor of the characteristic matrix are monic *) Lemma pminor_char_poly_mx_monic: forall m p (M: 'M[R]_m) (h h': p.+1 <= m), pminor h h' (char_poly_mx M) \is monic. Proof. rewrite /pminor => m p M h h'. rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)); first last. - by apply: widen_ord_eq. - by move => x. rewrite /minor submatrix_char_poly_mx; last by apply: inj_widen_ord. by apply/char_poly_monic. Qed. Definition char_poly_alt n (M: 'M[R]_(1 + n)) := bareiss (char_poly_mx M : 'M[polydvd.poly_of R]__). (* Here is our alternative definition of char_poly *) Lemma char_poly_altE : forall n (M: 'M[R]_(1 + n)), char_poly_alt M = char_poly M. Proof. rewrite /char_poly_alt /char_poly => n M. by rewrite bareissE // => p h h'; exact/monic_lreg/pminor_char_poly_mx_monic. Qed. (* The actual determinant function based on bareiss *) Definition bdet n (M : 'M[R]_(1 + n)) := (char_poly_alt (-M))`_0. Lemma bdetE : forall n (M : 'M[R]_(1 + n)), bdet M = \det M. Proof. move=> n M. rewrite /bdet char_poly_altE char_poly_det. have -> : - M = -1 *: M by apply/matrixP => i j; rewrite !mxE mulN1r. by rewrite detZ mulrA -expr2 sqrr_sign mul1r. Qed. End bareiss_det. End dvdring. coqeal-2.1.0/theory/bareiss_dvdring.v000066400000000000000000000326701475512565300176510ustar00rootroot00000000000000(* Version of Bareiss/Sasaki-Murao based on dvdrings *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm choice. From mathcomp Require Import matrix bigop zmodp mxalgebra poly polydiv mxpoly. Require Import ssrcomplements dvdring minor atomic_operations. Import Pdiv.Ring Pdiv.RingComRreg Pdiv.RingMonic GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope ring_scope. Section Bareiss1. Variable R: comRingType. Lemma L1 m (a d: R) (l: 'rV[R]_m) (c: 'cV[R]_m) (M: 'M[R]_m): \det (block_mx d%:M l (a *: c) (a *: M)) = a ^+ m * \det (block_mx d%:M l c M). Proof. set X := block_mx d%:M l c M. have huniq : uniq (map (lift 0) (enum 'I_m)). - rewrite map_inj_in_uniq; first exact: enum_uniq. by move => i j hi hj /= /lift_inj. have htool : forall s, 0 \notin map (lift 0) s by move => n /=; elim. have -> : block_mx d%:M l (a *: c) (a *: M) = foldl (fun N i => line_scale i a N) X (map (lift 0) (enum 'I_m)). - apply/row_matrixP => i. case: (lines_scale_row a X huniq) => hl hr. move: (hl i) (hr i) => {hl hr}. case: (splitP i) => j. + rewrite [j]ord1 {j} => hi. have {i hi}-> : i = 0 by apply/ord_inj. move => _ /= ->; last exact: htool. apply/rowP => j; rewrite !mxE. by case: splitP. move => hi. have {i hi}-> : i = lift 0 j by apply/ord_inj. move => -> /=. + move => _. apply/rowP => k; rewrite !mxE. case: splitP => x; first by rewrite [x]ord1. rewrite !mxE => _. case: splitP => y; by rewrite !mxE. rewrite mem_map ?mem_enum //. by apply/lift_inj. by rewrite det_lines_scale size_map size_enum_ord /=. Qed. Definition L3tool m (c: 'cV[R]_m) (d: R) (i: 'I_(1 + m)) := if split i is inr j then c j 0 else d. Lemma L3toolE0 m (c: 'cV[R]_m) d : L3tool c d 0 = d. Proof. by rewrite /L3tool; case: splitP. Qed. Lemma L3toolES m (c: 'cV[R]_m) d (i: 'I_m) : L3tool c d (lift 0 i) = c i 0. Proof. rewrite /L3tool. case: splitP => x /=; first by rewrite [x]ord1. by rewrite /bump leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. Qed. Lemma L3 m (d: R) (l: 'rV[R]_m) (c c0: 'cV[R]_m) (M: 'M[R]_m): \det (block_mx d%:M l c M) = \det (block_mx d%:M l (c - d *: c0) (M - c0 *m l)). Proof. pose X := block_mx d%:M l c M. have huniq : uniq (map (lift 0) (enum 'I_m)). - rewrite map_inj_in_uniq ?enum_uniq //. move => i j hi hj /=. by apply/lift_inj. have htool : forall s, 0 \notin map (lift 0) s by move => n /=; elim. have {}htool := htool _ (enum 'I_m). have -> : block_mx d%:M l (c -d *: c0) (M - c0 *m l) = foldl (fun N i => line_comb i 0 (-(L3tool c0 d i)) N) X (map (lift 0) (enum 'I_m)). - apply/row_matrixP => i. case: (lines_comb_row_dep (fun i => - (L3tool c0 d i)) X huniq htool) => hl hr. move: (hl i) (hr i) => {hl hr}. case: (splitP i) => j. + rewrite [j]ord1 {j} => hi. have {hi i}-> : i = 0 by apply/ord_inj. move => _ -> //=. apply/rowP => j; rewrite !mxE. by case: splitP. move => hi. have {i hi}-> : i = lift 0 j by apply/ord_inj. move => -> /=. + rewrite L3toolES => _. apply/rowP => k; rewrite !mxE. case: splitP => x /= ; first by rewrite [x]ord1. rewrite /bump leq0n => /eqP; rewrite eqSS => /eqP/ord_inj{j}->. case: splitP => z //; rewrite [z]ord1 {z} !mxE => _. case: splitP => y; rewrite !mxE. * rewrite [y]ord1 {y} => _. by rewrite mulrC mulr1n mulNr. by move => _; rewrite big_ord_recl big_ord0 addr0 mulNr. rewrite mem_map ?mem_enum //. by apply/lift_inj. by rewrite det_lines_comb_dep // size_map size_enum_ord /=. Qed. Lemma key_lemma m d (l: 'rV[R]_m) (c: 'cV[R]_m) M: d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l). Proof. by rewrite -L1 (L3 d l (d *: c) c (d *: M)) subrr det_ublock det_scalar1. Qed. (* The key lemma of our proof: after simplification, all the p-minors (involving 1st line/column) can be divided by (M 0 0)^p-1 *) Lemma key_lemma_sub m n k d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n): d * (minor f1 f2 (d *: M - c *m l)) = d ^+ k * (minor (lift_pred f1) (lift_pred f2) (block_mx d%:M l c M)). Proof. by rewrite /minor submatrix_lift_block key_lemma submatrix_add submatrix_scale submatrix_opp submatrix_mul. Qed. End Bareiss1. Section Bareiss2. Variable R: dvdRingType. Definition dvd_step (m n:nat) (d: R) (M: 'M[R]_(m,n)) : 'M[R]_(m,n) := map_mx (fun x => odflt 0 (x %/? d)) M. (* determinant equality for division step *) Lemma det_dvd_step: forall n a (M: 'M[R]_n), (forall i j, a %| M i j) -> a^+n * \det (dvd_step a M) = \det M. Proof. rewrite /dvd_step => n a M hj. rewrite -detZ; f_equal. apply/matrixP => i j; rewrite !mxE. case: odivrP => [d|h] /=; first by rewrite mulrC. case/dvdrP: (hj i j) => d hd. by move: (h d); rewrite hd eqxx. Qed. Lemma det_dvd_step_tool : forall m n a (M N: 'M[R]_(m,n)), M = a *: N -> forall i j, a %| M i j. Proof. move => m n a M N /matrixP h i j. rewrite (h i j) !mxE mulrC. by apply/dvdr_mull/dvdrr. Qed. Let lreg := GRing.lreg. (* some rewriting lemmas to make the main proof more clear *) Lemma blockE00 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)): (block_mx d%:M l c M) 0 0 = d. Proof. rewrite !mxE. case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. by case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. Qed. Lemma blockE0i m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i: (block_mx d%:M l c M) 0 (lift 0 i) = (l 0 i). Proof. rewrite !mxE. case: splitP => x //; rewrite [x]ord1 {x} !mxE => _. case: splitP => x; first by rewrite [x]ord1. by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. Qed. Lemma blockEi0 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i: (block_mx d%:M l c M) (lift 0 i) 0 = (c i 0). Proof. rewrite !mxE. case: splitP => x; first by rewrite [x]ord1. rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. rewrite !mxE. by case: splitP => y //; rewrite [y]ord1 {y} => _. Qed. Lemma blockEij m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i j: (block_mx d%:M l c M) (lift 0 i) (lift 0 j) = (M i j). Proof. rewrite !mxE. case: splitP => x; first by rewrite [x]ord1. rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. rewrite !mxE. case: splitP => y; first by rewrite [y]ord1. by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->. Qed. (* main step of the proof *) Lemma sketch m n (a d: R) (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)): lreg a -> (forall (k:nat) (f1: 'I_k.+1 -> 'I_(1 + m)) (f2: 'I_k.+1 -> 'I_(1 + n)), a ^+ k %| minor f1 f2 (block_mx d%:M l c M))-> (forall p (h: p.+1 <= 1 + m) (h': p.+1 <= 1 + n), lreg (pminor h h' (block_mx d%:M l c M))) -> let M' := d *: M - c *m l in let M'':= dvd_step a M' in [/\ lreg d, (forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n), d ^+ k %| minor f1 f2 M''), M' = a *: M'' & (forall p (h: p.+1 <= m) (h': p.+1 <= n), lreg (pminor h h' M''))]. Proof. rewrite /pminor => ha hM hN. set M0 := block_mx d%:M l c M. (* d is the 1x1 principal minor of M0 *) have hh : d = minor (widen_ord (ltn0Sn _)) (widen_ord (ltn0Sn _)) M0. - rewrite (@minor_eq _ _ _ _ _ (fun=> 0) _ (fun=> 0)) ?minor1 //. + by rewrite /M0 blockE00. + by move => x; rewrite ord1; apply: val_inj. + by move => x; rewrite ord1; apply: val_inj. (* all principal minors of M0 are lreg, so M 0 0 is *) have h2 : lreg d. - by rewrite hh /M0; apply hN. set M' := d *: M - c *m l. set M'' := dvd_step a M'. set f : forall m, 'I_m -> 'I_2 -> 'I_(1 + m) := fun m (i: 'I_m) (x: 'I_2) => if x == 0 then 0 else lift 0 i. (* all elements of M' can be expressed as 2x2 minors of M, so a divide all these *) have h4 : forall i j, a %| M' i j. - move => i j; rewrite /M' !mxE big_ord_recl big_ord0 addr0. move: (hM 1%nat (f _ i) (f _ j)). (* (hstrict _ i)). *) by rewrite !minor2 /f /= expr1 blockE00 blockEi0 blockE0i blockEij. (* since a divides all M' i j, all the divisions are exact, and thus M' = a * M'' *) have h6 : forall i j, M' i j = a * M'' i j. - move => i j; rewrite [(dvd_step _ _) i j]mxE. case: odivrP => [dv|h] /=; first by rewrite mulrC. case/dvdrP: (h4 i j) => dv hdv. by move: (h dv); rewrite hdv eqxx. have h6' : M' = a *: M'' by apply/matrixP => i j; rewrite h6 !mxE. (* from this equality, we can have more information about the minors of M' and M'' *) have h7 : forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n), minor f1 f2 M' = a ^+ k * minor f1 f2 M''. - move => k f1 f2. by rewrite h6' /minor submatrix_scale detZ. (* using all theses, we can now prove our goals *) have h8: forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n), d * minor f1 f2 M' = d ^+ k * minor (lift_pred f1) (lift_pred f2) M0. - move => k f1 f2. by rewrite /M0 /M' key_lemma_sub. have ak : forall k, lreg (a^+k). - by move => k; apply/lregX. have h10 : forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n), d ^+ k %| minor f1 f2 M''. - move => k f1 f2. move/lregP : (ak k.+1) => ak'. rewrite -(@dvdr_mul2l _ (a^+k.+1)) // -h7. have hM0 : d != 0 by apply/lregP. have hMk : d^+ k.+1 != 0 by apply/lregP/lregX. rewrite -(@dvdr_mul2l _ d) // mulrA h8 //. by rewrite mulrAC -exprS dvdr_mul2l //. split => //. rewrite -/M'' => p h h'. apply/(@lregMl _ (a ^+ p.+1)). rewrite -h7. apply/(@lregMl _ d). rewrite h8. apply/lregM; first by apply/lregX. rewrite (@minor_eq _ _ _ _ _ (widen_ord (size_tool h)) _ (widen_ord (size_tool h'))) ?hN. - by apply: hN. - by move => x; apply: val_inj; rewrite lift_pred_widen_ord. - by move => x; apply: val_inj; rewrite lift_pred_widen_ord. Qed. (* formal definition of Bareiss algorithm *) Fixpoint Bareiss_rec m a : 'M[R]_(1 + m) -> R := if m is p.+1 return 'M[R]_(1 + m) -> R then fun (M: 'M[R]_(1 + _)) => let d := M 0 0 in let l := ursubmx M in let c := dlsubmx M in let N := drsubmx M in let M' := d *: N - c *m l in let M'' := dvd_step a M' in Bareiss_rec d M'' else fun M => M 0 0. (* from sketch, we can express the properties of Bareiss *) Lemma Bareiss_recE : forall m a (M: 'M[R]_(1 + m)), lreg a -> (forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_m.+1), a ^+ k %| minor f1 f2 M) -> (forall p (h h' :p.+1 <= 1 + m), lreg (minor (widen_ord h) (widen_ord h') M)) -> a ^+ m * (Bareiss_rec a M) = \det M. Proof. elim => [ | m hi] //=. - move => a M ha h1 h2. by rewrite expr0 {2}[M]mx11_scalar det_scalar1 mul1r. rewrite [(1 + m.+1)%nat]/(1 + (1 + m))%nat => a M ha. set d := M 0 0. set l := ursubmx M. set c := dlsubmx M. set N := drsubmx M. have heq : block_mx (M 0 0)%:M (ursubmx M) (dlsubmx M) (drsubmx M) = M. - have -> : (M 0 0)%:M = ulsubmx M by apply/matrixP => i j; rewrite !mxE [i]ord1 [j]ord1 {i j} !lshift0. by rewrite submxK. rewrite -{1 2}heq => hM hm. have : forall p (h h': p.+1 <= 1 + (1 + m)), lreg (minor (widen_ord h) (widen_ord h') M). - rewrite -heq => p h h'. rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)) ?hm //. by move => x; apply/ord_inj. case: (@sketch _ _ a (M 0 0) (ursubmx M) (dlsubmx M) (drsubmx M) ha hM hm) => hM00 h1 h2 h3 hlreg. have h3' : forall p (h h': p < 1 + m), lreg (pminor h h' (dvd_step a (d *: N - c *m l))) by move => p h h'; apply/h3. move: (hi d (dvd_step a (d *: N - c *m l)) hM00 h1 h3'). set r := Bareiss_rec _ _ => hh. have : a ^+ m.+1 *( d ^+m * r) = a ^+ m.+1 * \det (dvd_step a (d *: N - c *m l)) by rewrite hh. rewrite det_dvd_step //; last by move => i j; exact: (det_dvd_step_tool h2). move => heq2. have hX : lreg (M 0 0 ^+ (1 + m)) by apply/lregX. apply/hX. rewrite -{3}heq key_lemma -heq2 [M 0 0 ^+ (1 + m)]exprS -mulrA. by congr (_ * _); rewrite mulrCA. Qed. (* we start the algorithm with a = 1 *) Definition Bareiss (n: nat) (M: 'M[R]_(1 + n)) := Bareiss_rec 1 M. Lemma BareissE : forall n (M: 'M[R]_(1 + n)), (forall p (h h': p.+1 <= 1 + n), lreg (pminor h h' M)) -> Bareiss M = \det M. Proof. rewrite /Bareiss => n M h. have h1 : lreg (1: R) by apply/lreg1. have h2 : forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_n.+1), 1 ^+ k %| minor f1 f2 M. - by move => k f1 f2; rewrite expr1n dvd1r. move: (Bareiss_recE h1 h2 h). by rewrite expr1n mul1r. Qed. End Bareiss2. (* In practice, we apply this algorithm to the characteristic matrix so we get the characteristic polynomial in polynomial time *) Require Import polydvd. Import PolyDvdRing. Section Bareiss_det. Variable R: dvdRingType. (* all principal minor of the characteristic matrix are monic *) Lemma pminor_char_poly_mx_monic: forall m p (M: 'M[R]_m) (h h': p.+1 <= m), pminor h h' (char_poly_mx M) \is monic. Proof. rewrite /pminor => m p M h h'. rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)); first last. - by apply: widen_ord_eq. - by move => x. rewrite /minor submatrix_char_poly_mx; last by apply: inj_widen_ord. by apply/char_poly_monic. Qed. Definition char_poly_alt n (M: 'M[R]_(1 + n)) := Bareiss (char_poly_mx M : 'M[polydvd.poly_of R]__). (* Here is our alternative definition of char_poly *) Lemma char_poly_altE : forall n (M: 'M[R]_(1 + n)), char_poly_alt M = char_poly M. Proof. rewrite /char_poly_alt /char_poly => n M. rewrite BareissE //. move => p h h'; apply/monic_lreg. exact: pminor_char_poly_mx_monic. Qed. (* The actual determinant function based on Bareiss *) Definition bdet n (M : 'M[R]_(1 + n)) := (char_poly_alt (-M))`_0. Lemma bdetE : forall n (M : 'M[R]_(1 + n)), bdet M = \det M. Proof. move=> n M. rewrite /bdet char_poly_altE char_poly_det. have -> : - M = -1 *: M by apply/matrixP => i j; rewrite !mxE mulN1r. by rewrite detZ mulrA -expr2 sqrr_sign mul1r. Qed. End Bareiss_det. coqeal-2.1.0/theory/binetcauchy.v000066400000000000000000000445501475512565300170020ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) (* This proof is from: Linear Algebra and its Applications Volume 184, 15 April 1993, Pages 79–82 A bijective proof of Muir's identity and the Cauchy-Binet formula Jiang Zeng Département de Mathématiques Université Louis-Pasteur 7, rue René Descartes 67000 Strasbourg Cedex, France Received 30 March 1992. Available online 25 March 2002. Submitted by Richard A. Brualdi. *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm choice finfun. From mathcomp Require Import matrix bigop zmodp mxalgebra fingroup. Require Import minor. Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope ring_scope. Section BinetCauchy. Variable R : comRingType. Variable k l : nat. Let Z := ({ffun 'I_k -> 'I_l} * ('S_k))%type. Variable A : 'M[R]_(k,l). Variable B : 'M[R]_(l,k). Definition weight (f: {ffun 'I_k -> 'I_l}) (s : 'S_k) := ((-1) ^+ s) * \prod_(i : 'I_k) (A i (f i) * B (f i) (s i)). Lemma split_sumZ_sf (P : Z -> R) (C : pred {ffun 'I_k -> 'I_l}): \sum_(fz : Z | C fz.1) (P fz) = \sum_(s: 'S_k) (\sum_(f: {ffun 'I_k -> 'I_l} | C f) (P (f,s))). Proof. rewrite exchange_big pair_big /=. by apply/eq_big; case=> //= [f s]; rewrite andbT. Qed. Lemma split_sumZ_fs (P : Z -> R) (C : pred {ffun 'I_k -> 'I_l}): \sum_(fz : Z | C fz.1) (P fz) = \sum_(f: {ffun 'I_k -> 'I_l} | C f) (\sum_(s: 'S_k) (P (f,s))). Proof. rewrite pair_big /=. by apply/eq_big; case=>//= [f s]; rewrite andbT. Qed. Lemma detAB_weight : \det (A *m B) = \sum_(fz : Z) (weight fz.1 fz.2). Proof. rewrite /determinant /weight. rewrite (split_sumZ_sf _ xpredT) /=. apply/eq_big => // s _. rewrite -big_distrr /=; congr (_ * _). set F := fun n m => A n m * B m (s n). rewrite -(bigA_distr_bigA F) /=. apply/eq_big => // i _. by rewrite !mxE. Qed. Definition tilt (i j: 'I_k) (z: 'S_k) := (tperm i j * z)%g. Lemma tiltK (i j: 'I_k) : involutive (tilt i j). Proof. by move => s; apply/permP => x; rewrite !permM tpermK. Qed. Lemma tilt_bij (i j: 'I_k) : bijective (tilt i j). Proof. by apply inv_bij; apply tiltK. Qed. Lemma tilt_inj (i j : 'I_k) : injective (tilt i j). Proof. by apply bij_inj; apply tilt_bij. Qed. Lemma sign_tilt2 (z: 'S_k) (i j: 'I_k) : i != j -> (-1)^+(tilt i j z) = -1* ((-1) ^+ z) :>R. Proof. move => hij. rewrite odd_mul_tperm hij /= mulNr mul1r. by case: (odd_perm z); rewrite /= expr0 expr1 ?opprK. Qed. Lemma sig_tilt (z: 'S_k) (i j: 'I_k) : i != j -> ~~ odd_perm (tilt i j z) = odd_perm z. Proof. by move => hij; rewrite odd_mul_tperm hij negbK /=. Qed. Lemma reindex_with_tilt (P: 'S_k -> R) (i j: 'I_k) : i != j -> \sum_(z : 'S_k) (P z) = \sum_(z: 'S_k | odd_perm z) (P z + P (tilt i j z)). Proof. move => hij. rewrite (bigID (fun z:'S_k => odd_perm z)) big_split /=; congr (_ + _). pose C := fun z => ~~ odd_perm z. pose D := fun z => odd_perm z. pose D' := fun z => C _ (tilt i j z). have hD : D _ =1 D' by move=> p; rewrite /D /D' /C sig_tilt. by rewrite (eq_bigl _ _ hD) /D' -(reindex_inj (@tilt_inj i j)). Qed. Lemma fz_tilt_0 (i j: 'I_k) (f: {ffun 'I_k -> 'I_l}) z: i != j -> f i = f j -> weight f z + weight f (tilt i j z) = 0. Proof. rewrite /weight => hij hf. rewrite sign_tilt2 // !mulNr mul1r -mulrBr. set b1 := \big[*%R/1]_( _ < _ ) _. set b2 := \big[*%R/1]_( _ < _ ) _. suff -> : b1 = b2 by rewrite subrr mulr0. rewrite /b1 {b1} /b2 {b2} (bigD1 j) //= (bigD1 i) //=. rewrite [RHS](bigD1 j) //= [X in _ = _ * X](bigD1 i) //=. rewrite !permM tpermR tpermL hf !mulrA. congr (_ * _). by rewrite -!mulrA; congr (_ * _); rewrite mulrC -mulrA mulrCA. by apply/eq_big => // x /andP [h1 h2]; rewrite permM tpermD // eq_sym. Qed. Lemma sum_bad : \sum_(fz : Z | ~~ injectiveb fz.1) (weight fz.1 fz.2) = 0. Proof. rewrite (split_sumZ_fs _ (fun x => ~~ injectiveb x)). apply/big1 => f /injectivePn [x [y hxy hf]] /=. rewrite (reindex_with_tilt _ hxy). by apply/big1 => s _; rewrite fz_tilt_0. Qed. Definition strictf (p q: nat) (f: 'I_p -> 'I_q) := [forall x : 'I_p, [forall y : 'I_p, (x < y) == (f x < f y)]]. Lemma inj_strictf (p q : nat) (f: 'I_p -> 'I_q) : strictf f -> injective f. Proof. move/forallP=> /= hf x y heq. move/forallP: (hf x) => /= hfx. move/forallP: (hf y) => /= hfy. case: (ltngtP x y)=> [||h]; last by apply/ord_inj. by rewrite (eqP (hfx y)) heq ltnn. by rewrite (eqP (hfy x)) heq ltnn. Qed. Lemma inj_strictf_ffun (p q : nat) (f: {ffun 'I_p -> 'I_q}) : strictf f -> injective f. Proof. by move=> h; apply: inj_strictf. Qed. Remark trans_ltn : ssrbool.transitive ltn. Proof. by move => x y z; apply (@ltn_trans x y z). Qed. Lemma sorted_enum n (P : pred 'I_n): sorted ltn (map val (enum P)). Proof. apply (@subseq_sorted _ ltn trans_ltn _ (map val (enum 'I_n))). - by apply: map_subseq; rewrite {1}/enum_mem enumT filter_subseq. by rewrite val_enum_ord iota_ltn_sorted. Qed. Lemma path_drop : forall (s: seq nat) (i j d x : nat), path ltn x s -> i < j -> path ltn (nth d (x :: s) i) (drop i.+1 (x :: s)). Proof. elim => [ | hd tl hi] //= [ | i] j d x /andP [hx hp] hij /=. - by rewrite hx. by apply: (hi _ j.-1 _ hd) => //; move: hij; case: j. Qed. Lemma path_ordered_nth (i j d d' x : nat) (s: seq nat): path ltn x s -> i < j -> i < size (x::s) -> j < size (x::s) -> nth d (x::s) i < nth d' (x::s) j. Proof. move => hp hij h1 h2. have hin : nth d' (x :: s) j \in (drop i.+1 (x :: s)). - move=> {hp}/=. elim : s x d' i j hij h1 h2 => [ | hd tl hi] x d' [ | i] [ | j] hij //=. + rewrite -[j.+1]add1n -[(size tl).+1]add1n ltn_add2l => _ h. by rewrite mem_nth. rewrite -[i.+1]add1n -[(size tl).+1]add1n -[j.+1]add1n !ltn_add2l => h1 h2. by apply: hi. move/(order_path_min trans_ltn)/allP: (path_drop d hp hij)=> h. by apply: (h _ hin). Qed. Lemma sorted_ordered_nth i j d d' (s: seq nat): sorted ltn s -> i < j -> i < size s -> j < size s -> nth d s i < nth d' s j. Proof. case: s => [ | hd tl] //= /path_ordered_nth => h h1 h2 h3. by apply: h. Qed. Lemma nth_change_default: forall (s: seq nat) d d' n, n < size s -> nth d s n = nth d' s n. Proof. elim => [ | hd tl hi] d d' [ | n] //=. rewrite -[n.+1]add1n -[(size tl).+1]add1n ltn_add2l => h. by apply: hi. Qed. Lemma sorted_ordered_nth_gen (i j d d' x : nat) (s: seq nat): sorted ltn s -> i < size s -> j < size s -> nth d s i < nth d' s j -> i < j. Proof. move => h hi hj hltn. case: (ltngtP i j) => // [hji|heq]. - have hgtn := sorted_ordered_nth d d' h hji hj hi. rewrite -(ltnn (nth d s i)). apply: (ltn_trans hltn). by rewrite (nth_change_default d' d hj) (nth_change_default d d' hi). by move: hltn; rewrite heq (nth_change_default d' d hj) ltnn. Qed. Lemma tool_nth : forall (s: seq 'I_l) (n:nat) (x: 'I_n) (d: 'I_l), nth (val d) (map val s) x = val (nth d s x). Proof. elim => [ | hd tl hi] //= n x d. - by rewrite !nth_nil. case: n x => [[] // | n]. rewrite [n.+1]/(1 + n)%nat => x. case: (splitP x) => [j | j -> /=]. - by rewrite [j]ord1 => ->. exact: hi. Qed. Lemma cast0 (f: {ffun 'I_k -> 'I_l}) : size (enum (codom f)) = #|codom f|. Proof. by rewrite cardE. Qed. Lemma cast1 (f: {ffun 'I_k -> 'I_l}) : injective f -> k = #|codom f|. Proof. move => hf. by rewrite (card_codom hf) cardT /= size_enum_ord. Qed. Lemma step_weight (g f: {ffun 'I_k -> 'I_l}) (pi: 'S_k) (hf : injective f) (phi : 'S_k) : (forall x, f x = g (phi x)) -> let: sigma := (phi^-1 * pi)%g in weight f pi = ((-1)^+ phi * \prod_i (A i (g (phi i)))) * ((-1)^+ sigma * \prod_i (B (g i) (sigma i))). Proof. move => heq. rewrite mulrAC mulrA -signr_addb -odd_permM mulgA mulgV mul1g -mulrA. rewrite /weight big_split /=. congr (_ * _); rewrite mulrC. congr (_ * _); last first. - apply/eq_big => // i _. by rewrite heq. have hinf : injective phi by apply: perm_inj. rewrite [X in _ = X](reindex_inj hinf) /=. apply/eq_big => // i _. by rewrite -permM mulgA mulgV mul1g heq. Qed. (* need the trunk this codom has changed since 1.3 (maybe backward compatible, but I couldn't try *) Definition same_codomb m n (f g: {ffun 'I_m -> 'I_n}) : bool := [forall x, (x \in codom f) == (x \in codom g)]. Definition same_codom m n (f g: {ffun 'I_m -> 'I_n}) := forall x, (x \in codom f) = (x \in codom g). Lemma same_codomP m n (f g : {ffun 'I_m -> 'I_n}) : reflect (same_codom f g) (same_codomb f g). Proof. apply: (iffP forallP) => h x. - by rewrite (eqP (h x)). by rewrite (h x). Qed. Definition good (g: {ffun 'I_k -> 'I_l}) : pred {ffun 'I_k -> 'I_l} := fun f => injectiveb f && (same_codomb f g). Lemma goodP (g f: {ffun 'I_k -> 'I_l}) : reflect (injective f /\ same_codom f g) (good g f). Proof. (* TODO: `andPP` is only available in Coq 8.15+ *) (* by apply: andPP; [exact: injectiveP | exact: same_codomP]. *) apply: (iffP andP). - case => /injectiveP h1 /forallP h2. split => // x. by rewrite (eqP (h2 x)). case => h1 h2. split; first by apply/injectiveP. by apply/forallP => x; rewrite (h2 x). Qed. Lemma mem_same_codom (f g: {ffun 'I_k -> 'I_l}) : same_codom f g -> forall x, f x \in codom g. Proof. by move => h x; rewrite -h codom_f. Qed. (* g^-1 (f x) *) Definition inv_g_of_fx (g f: {ffun 'I_k -> 'I_l}) := if same_codomP f g isn't ReflectT b then finfun id else finfun (fun x => iinv (mem_same_codom b x)). Lemma inv_g_of_fxE (g f: {ffun 'I_k -> 'I_l}) : same_codom f g -> forall x, g (inv_g_of_fx g f x) = f x. Proof. rewrite /inv_g_of_fx => heq. - case: same_codomP => h x. by rewrite !ffunE f_iinv. by case: h. Qed. Lemma inv_g_of_fx_inj (g f: {ffun 'I_k -> 'I_l}): injective f -> same_codom f g -> injectiveb (inv_g_of_fx g f). Proof. move => hf hc. apply/injectiveP => x y heq. apply: hf. by rewrite -!(inv_g_of_fxE hc) heq. Qed. (* forall g f, if g and f have the same image and f is injective, there is a permutation p such that g = f p. we build this p from g and f *) Definition perm_f (g f: {ffun 'I_k -> 'I_l}) := if goodP g f isn't ReflectT b then 1%g else Perm (inv_g_of_fx_inj (proj1 b) (proj2 b)). Lemma perm_fE (g f: {ffun 'I_k -> 'I_l}) : injective f -> same_codom f g -> forall x, f x = g ((perm_f g f) x). Proof. move => hf hc /= x. rewrite /perm_f unlock /=. case: goodP => [/= _|[]] //. by rewrite inv_g_of_fxE. Qed. Lemma codom_perm (g: {ffun 'I_k -> 'I_l}) (p: 'S_k) : forall x, (x \in codom (finfun (g \o p))) = (x \in codom g). Proof. move => x. apply/imageP/imageP. - case => /= y h1; rewrite ffunE => h2. by exists (p y). case => y h1 h2. exists (p^-1 y)%g => //=. by rewrite ffunE /= permKV. Qed. Lemma from_good_to_perm (g: {ffun 'I_k -> 'I_l}) (P : {ffun 'I_k -> 'I_l} -> R) : injective g -> \sum_(f | good g f) P f = \sum_(phi : 'S_k) (P (finfun (g \o phi))). Proof. move => hg. rewrite (reindex_onto (fun p:'S_k => finfun (g \o p)) (perm_f g)) /=. - apply/eq_big => // p. have hinj : injective (finfun (g \o p)). + have htemp : injective (g \o p) by apply: inj_comp => //; apply: perm_inj. move => x y; rewrite !ffunE => heq. exact: htemp. have hcodom : forall x, (x \in codom (finfun (g \o p))) = (x \in codom g) by move => x; rewrite codom_perm. apply/andP; split. + apply/andP; split; first exact/injectiveP. apply/forallP => x; by rewrite hcodom. apply/eqP/permP => x. have := perm_fE hinj hcodom x. by rewrite ffunE => /hg ->. move => /= f. case/goodP => h1 h2. apply/ffunP => /= x. by rewrite ffunE (perm_fE h1 h2). Qed. Lemma one_step (g : {ffun 'I_k -> 'I_l}) : injective g -> minor id g A * minor g id B = \sum_(fz : Z | good g fz.1) weight fz.1 fz.2. Proof. move => hg. rewrite split_sumZ_fs from_good_to_perm //=. pose sigma (phi pi: 'S_k) : 'S_k := (phi^-1 * pi)%g. transitivity (\sum_(phi: 'S_k) \sum_(pi : 'S_k) ( ((-1)^+ phi * \prod_i (A i (g (phi i)))) * ((-1)^+ (sigma phi pi) * \prod_i (B (g i) (sigma phi pi i))) ) ); last first. - apply/eq_big => // phi _. apply/eq_big => // pi _. have hinj : injective (finfun (g \o phi)). + have htemp : injective (g \o phi) by apply: inj_comp => //; apply: perm_inj. move => x y; rewrite !ffunE => heq. by apply: htemp. rewrite (@step_weight g (finfun (g \o phi)) pi hinj phi) //. by move => x; rewrite ffunE. transitivity( \sum_(phi: 'S_k) ((-1) ^+ phi * \big[*%R/1]_i A i (g (phi i)) * ( \big[+%R/0]_pi ((-1) ^+ sigma phi pi * \big[*%R/1]_i B (g i) ((sigma phi pi) i))))); last first. - apply/eq_big => // phi _. by rewrite -big_distrr /=. rewrite big_distrl /=. apply/eq_big => // phi _. congr ( _ * _). - by congr (_ * _); apply/eq_big => // i _; rewrite mxE. have inj_s : injective (sigma phi). - rewrite /sigma => p1 p2 /permP heq. apply/permP => x. move: (heq (phi x)). by rewrite !permE /= /invg /= permK. rewrite /minor /determinant. rewrite (reindex_inj inj_s) /=. apply/eq_big => // pi _. congr (_ * _). apply/eq_big => // i _. by rewrite !mxE. Qed. Lemma gather_by_strictness : \sum_(g : {ffun 'I_k -> 'I_l} | strictf g) \sum_(fz : Z | good g fz.1) weight fz.1 fz.2 = \sum_(g : {ffun 'I_k -> 'I_l} | strictf g) (minor id g A) * (minor g id B). Proof. apply/eq_big => // g hg. rewrite one_step //. by apply/inj_strictf. Qed. (* from any injective function f, builds a strictly increasing function g with the same image ( == enum_val) *) Definition strict_from (f: {ffun 'I_k -> 'I_l}) (hf: injective f) := finfun (fun x => @enum_val _ (mem (codom f)) (cast_ord (cast1 hf) x)). Lemma strict_fromP (f: {ffun 'I_k -> 'I_l}) (hf: injective f): strictf (strict_from hf) /\ same_codom f (strict_from hf). Proof. split. - apply/forallP => x. apply/forallP => y. have hsorted : sorted ltn (map val (enum (codom f))) by apply: sorted_enum. apply/eqP. rewrite !ffunE /enum_val -!tool_nth. apply/idP/idP => [ hxy | ]. + apply: sorted_ordered_nth => //. * by rewrite size_map cast0 ltn_ord. by rewrite size_map cast0 ltn_ord. apply: sorted_ordered_nth_gen => //=. + by rewrite size_map cast0 -(cast1 hf) ltn_ord. by rewrite size_map cast0 -(cast1 hf) ltn_ord. have h1 : enum (codom f) =i codom f by move => y; rewrite mem_enum. move => y. apply/imageP/imageP. - case => x hx hy. have hy' : y \in (enum (codom f)) by rewrite h1 hy codom_f. have hi : index y (enum (codom f)) < #|codom f| by rewrite -cast0 index_mem. have hi' : index y (enum (codom f)) < k by move: hi; rewrite -cast1. exists (Ordinal hi') => //. by rewrite !ffunE /enum_val /= nth_index. case => /= x hx. rewrite !ffunE => hy. have : (y \in codom f) by rewrite hy; apply/enum_valP. case/imageP => x' _ hx'. by exists x'. Qed. Lemma strictf_lift m n (f: {ffun 'I_m.+1 -> 'I_n}) : strictf f -> strictf (finfun (fun x => f (lift 0 x))). Proof. move/forallP => hf. apply/forallP => /= x. apply/forallP => /= y. rewrite !ffunE. move/forallP : (hf (lift 0 x)) => hf'. by rewrite -(eqP (hf' (lift 0 y))). Qed. (* such a function is unique : two stricly increasing function with the same image are pointwise equal *) Lemma strictf_uniq : forall m n (f g: {ffun 'I_m -> 'I_n}), strictf f -> strictf g -> same_codom f g -> f = g. Proof. clear A B Z R k l. elim => [ | m hi] n f g hf hg hsame; apply/ffunP; first by case. move/forallP : (hf) => hf1. move/forallP : (hg) => hg1. rewrite [m.+1]/(1 + m)%nat => x. case: (ltngtP (f 0) (g 0)) => h. - have h1 : f 0 \in codom g by rewrite -hsame codom_f. have [x' heq] : { x' | f 0 = g x'} by exists (iinv h1); rewrite f_iinv. move: h; rewrite heq. move/forallP : (hg1 x') => hg'. by rewrite -(eqP (hg' 0)) ltn0. - have h1 : g 0 \in codom f by rewrite hsame codom_f. have [x' heq] : { x' | g 0 = f x'} by exists (iinv h1); rewrite f_iinv. move: h; rewrite heq. move/forallP : (hf1 x') => hf'. by rewrite -(eqP (hf' 0)) ltn0. case: (splitP x) => y. - rewrite [y]ord1 => hy. have {x hy}-> : x = 0 by apply/ord_inj. by apply/ord_inj. move => hy. have {x hy}-> : x = lift 0 y by apply/ord_inj. set f' := finfun (fun x => f (lift 0 x)). set g' := finfun (fun x => g (lift 0 x)). have hsame' : forall x, (x \in codom f') = (x \in codom g'). - move => z. apply/imageP/imageP. + case => /= a _; rewrite ffunE => hz. have : z \in codom g by rewrite -hsame hz codom_f. case/imageP; rewrite [m.+1]/(1 + m)%nat => x' _. case: (splitP x') => j. * rewrite [j]ord1 => hx'. have {x' hx'}-> : x' = 0 by apply/ord_inj. move => h'. have : f (lift 0 a) = f 0 by apply/ord_inj; rewrite -hz h h'. by move/(inj_strictf hf). move => hx'. have {x' hx'}-> : x' = lift 0 j by apply/ord_inj. move => hz'. by exists j => //; rewrite ffunE. case => /= a _; rewrite ffunE => hz. have : z \in codom f by rewrite hsame hz codom_f. case/imageP; rewrite [m.+1]/(1 + m)%nat => x' _. case: (splitP x') => j. * rewrite [j]ord1 => hx'. have {x' hx'}-> : x' = 0 by apply/ord_inj. move => h'. have : g (lift 0 a) = g 0 by apply/ord_inj; rewrite -hz -h h'. by move/(inj_strictf hg). move => hx'. have {x' hx'}-> : x' = lift 0 j by apply/ord_inj. move => hz'. by exists j => //; rewrite ffunE. move/ffunP : (hi n f' g' (strictf_lift hf) (strictf_lift hg) hsame') => heq. by move: (heq y); rewrite !ffunE => ->. Qed. Definition strict_from_f (fz :Z) := if injectiveP fz.1 is ReflectT h then strict_from h else fz.1. Lemma strict_from_fP (fz : Z) : injective fz.1 -> strictf (strict_from_f fz) /\ same_codom fz.1 (strict_from_f fz). Proof. move => hf. rewrite /strict_from_f. case: injectiveP => [hinj | []] //; exact: strict_fromP. Qed. Lemma BinetCauchy: \det (A *m B) = \sum_(f : {ffun 'I_k -> 'I_l} | strictf f) (minor id f A * minor f id B). Proof. pose cond := fun fz : Z => injectiveb fz.1. pose ffstrictf := fun (f: {ffun 'I_k -> 'I_l}) => strictf f. rewrite detAB_weight (bigID cond) /= sum_bad addr0. rewrite -gather_by_strictness (partition_big strict_from_f ffstrictf) /=. - apply/eq_big => // g hg. apply/congr_big => //. case => f pi; rewrite /cond /good /=. apply/andP/andP; case => /injectiveP h1. + rewrite /strict_from_f /=. case: injectiveP => [hinj | []] //. move/eqP => heq; split => //. case: (strict_fromP hinj) => hlt hrt. apply/forallP => x. by rewrite -heq (hrt x). move/forallP => hsame. have hcodom : forall x, (x \in codom f) = (x \in codom g) by move => x; rewrite (eqP (hsame x)). split; first by apply/injectiveP. case: (@strict_from_fP (f,pi) h1) => hstrict hcodom2. rewrite (strictf_uniq hstrict hg) // => x. by rewrite -hcodom2 hcodom. move => fz /injectiveP hf. by case: (strict_from_fP hf). Qed. End BinetCauchy. coqeal-2.1.0/theory/closed_poly.v000066400000000000000000000254031475512565300170140ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect. From mathcomp Require Import all_algebra. From mathcomp Require Import all_real_closed. From CoqEAL Require Import ssrcomplements. (******************************************************************************) (* *) (* This file contains theory about polynomials with coefficients *) (* in a closed field. *) (* *) (* In follow we pose p = (X - r1)^+a1 * (X - r2)^+a2 * ... * (X - rn)^+an *) (* *) (* root_seq p == the sequence of all roots of polynomial p. *) (* root_seq_uniq p == the sequence of all distinct roots of *) (* polynomial p (i.e the sequence [:: r1; ...; rn]) *) (* root_mu_seq p == the sequence of pair off the roots and *) (* its multiplicity of polynomial p. *) (* (i.e the sequence [:: (r1,a1); ... ; (rn,an)]) *) (* root_seq_poly s == the concatenation of the sequences root_mu_seq p *) (* for all polynomials p in the sequence s. *) (* linear_factor_seq p == the sequence of linear factor tha appear of the *) (* decompositionof polynomial p. (i.e the sequence *) (* [:: (X - r1)^+a1; ... ; (X - rn)^+an]) *) (* *) (******************************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section poly_closedFieldType. Variable F : closedFieldType. Import GRing.Theory. Local Open Scope ring_scope. Definition root_seq : {poly F} -> seq F := let fix loop (p : {poly F}) (n : nat) := if n is n.+1 then if (size p != 1%N) =P true is ReflectT p_neq0 then let x := projT1 (sigW (closed_rootP p p_neq0)) in x :: loop (p %/ ('X - x%:P)) n else [::] else [::] in fun p => loop p (size p). Lemma root_root_seq (p : {poly F}) x : p != 0 -> x \in root_seq p = root p x. Proof. rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. elim: size {-2 5}p (erefl (size p))=> /= {p} [|n ihn] p /=. by move/eqP; rewrite size_poly_eq0 => /eqP->; rewrite eqxx. case: eqP=> /= [sp_neq1 sp_eqn|/negP]; last first. rewrite negbK=> /size_poly1P [c c_neq0 ->] _ _. by rewrite rootC (negPf c_neq0). case: sigW => z /= rpz p_neq0. rewrite in_cons; have [->|neq_xz] //= := altP eqP. move: rpz sp_eqn => /factor_theorem [q ->]. rewrite mulpK ?polyXsubC_eq0 // rootM root_XsubC (negPf neq_xz) orbF. have [->|q_neq0] := eqVneq q 0; first by rewrite mul0r size_poly0. rewrite size_mul ?polyXsubC_eq0 // size_XsubC addn2. by case=> /ihn /(_ q_neq0). Qed. Lemma root_seq_cons (p : {poly F}) x s : root_seq p = x :: s -> s = root_seq (p %/ ('X - x%:P)). Proof. rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. case H: (size p)=> [|n] //=; case: eqP=> // Hp. move/eqP; rewrite eqseq_cons; case/andP=> /eqP {1}<- /eqP <-. suff ->: n = size (p %/ ('X - x%:P))=> //. by rewrite size_divp ?polyXsubC_eq0 // size_XsubC subn1 H. Qed. Lemma root_seq_eq (p : {poly F}) : p = lead_coef p *: \prod_(x <- root_seq p) ('X - x%:P). Proof. move: {2}(root_seq p) (erefl (root_seq p))=> s. elim: s p=> [p | x s IHp p H]. rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _. case H: (size p)=> [|n]. move/eqP: H; rewrite size_poly_eq0=> /eqP ->. by rewrite lead_coef0 scale0r. case: n H => [H | n H] /=; case: eqP => //. move=> _ _; rewrite big_nil. move/eqP: H => /size_poly1P [c H] ->. by rewrite lead_coefC alg_polyC. by move/negP; rewrite negbK H. rewrite H big_cons (root_seq_cons H) mulrC scalerAl. have Hfp : p = p %/ ('X - x%:P) * ('X - x%:P). apply/eqP; rewrite -dvdp_eq dvdp_XsubCl -root_root_seq. by rewrite H mem_head. move: H; rewrite /root_seq. set loop := fix loop p n := if n is _.+1 then _ else _. by apply: contraPneq => ->; rewrite size_poly0. suff -> : lead_coef p = lead_coef (p %/ ('X - x%:P)). by rewrite -IHp ?(root_seq_cons H). by rewrite {1}Hfp lead_coef_Mmonic // monicXsubC. Qed. Lemma root_seq0 : root_seq 0 = [::]. Proof. by rewrite /root_seq size_poly0. Qed. Lemma size_root_seq p : size (root_seq p) = (size p).-1. Proof. have [-> | p0] := eqVneq p 0; first by rewrite root_seq0 size_poly0. rewrite {2}[p]root_seq_eq size_scale ?lead_coef_eq0 //. rewrite (big_nth 0) big_mkord size_prod. rewrite (eq_bigr (fun=> (1 + 1)%N)). by rewrite big_split sum1_card /= subSKn addnK card_ord. by move=> i _; rewrite size_XsubC. by move=> i _; rewrite polyXsubC_eq0. Qed. Lemma root_seq_nil (p : {poly F}) : (size p <= 1)%N = ((root_seq p) == [::]). Proof. by rewrite -subn_eq0 subn1 -size_root_seq size_eq0. Qed. Lemma sub_root_div (p q : {poly F}) (Hq : q != 0) : p %| q -> {subset (root_seq p) <= (root_seq q)} . Proof. case: (eqVneq p 0) => [->|p0]; first by rewrite root_seq0. by case/dvdpP => x Hx y; rewrite !root_root_seq // Hx rootM orbC=> ->. Qed. Definition root_seq_uniq p := undup (root_seq p). Lemma prod_XsubC_count (p : {poly F}): p = (lead_coef p) *: \prod_(x <- root_seq_uniq p) ('X - x%:P)^+ (count_mem x (root_seq p)). Proof. by rewrite {1}[p]root_seq_eq (prod_seq_count (root_seq p)). Qed. Lemma count_root_seq p x : count_mem x (root_seq p) = \mu_x p. Proof. have [-> | Hp] := eqVneq p 0; first by rewrite root_seq0 mu0. apply/eqP; rewrite -muP //. case/boolP: (x \in root_seq p) => [|H]. rewrite -mem_undup => H. move: (prod_XsubC_count p). rewrite (bigD1_seq x) //= ?undup_uniq //. set b:= \big[_/_]_(_ <- _ | _) _ => Hpq. apply/andP; split; apply/dvdpP. by exists (lead_coef p *: b); rewrite -scalerAl mulrC. case=> q Hq. have H1: ~~ (('X - x%:P) %| b). rewrite dvdp_XsubCl; apply/rootP. rewrite horner_prod; apply/eqP. rewrite (big_nth 0) big_mkord. apply/prodf_neq0=> i Hix. by rewrite horner_exp hornerXsubC expf_neq0 // subr_eq0 eq_sym. have H2: (('X - x%:P) %| b). apply/dvdpP; exists ((lead_coef p)^-1 *: q). apply: (@scalerI _ _ (lead_coef p)); first by rewrite lead_coef_eq0. rewrite -scalerAl scalerA mulrV ?unitfE ?lead_coef_eq0 // scale1r. have HX: (('X - x%:P)^+ (count_mem x (root_seq p))) != 0. by apply: expf_neq0; rewrite -size_poly_eq0 size_XsubC. rewrite -(mulpK (_ *: b) HX) -(mulpK (q * _) HX). by rewrite -scalerAl mulrC -Hpq -mulrA -exprS -Hq. by rewrite H2 in H1. have->: count_mem x (root_seq p) = 0%N by apply/count_memPn. by rewrite dvd1p /= dvdp_XsubCl -root_root_seq. Qed. Definition root_mu_seq p := [seq (x,(\mu_x p)) | x <- (root_seq_uniq p)]. Lemma root_mu_seq_pos x p : p != 0 -> x \in root_mu_seq p -> (0 < x.2)%N. Proof. move=> Hp H. have Hr: size (root_seq_uniq p) = size (root_mu_seq p) by rewrite size_map. have Hs: (index x (root_mu_seq p) < size (root_seq_uniq p))%N. by rewrite Hr index_mem. rewrite -(nth_index (0,0%N) H) // (nth_map 0) // mu_gt0 //. by rewrite -root_root_seq // -mem_undup mem_nth. Qed. Definition root_seq_poly (s : seq {poly F}) := flatten (map root_mu_seq s). Lemma root_seq_poly_pos x s : (forall p , p \in s -> p !=0) -> x \in root_seq_poly s -> (0 < x.2)%N. Proof. elim : s=> [|p l IHl H]; first by rewrite in_nil. rewrite mem_cat. case/orP; first by apply: root_mu_seq_pos; apply: H; rewrite mem_head. by apply: IHl=> q Hq; apply: H; rewrite in_cons Hq orbT. Qed. Definition linear_factor_seq p := [seq ('X - x.1%:P)^+x.2 | x <- (root_mu_seq p)]. Lemma monic_linear_factor_seq p : forall q, q \in linear_factor_seq p -> q \is monic. Proof. move=> q Hq; rewrite -(nth_index 0 Hq) (nth_map (0,0%N)). apply: monic_exp; first by apply: monicXsubC. by rewrite -index_mem size_map in Hq. Qed. Lemma size_linear_factor_leq1 p : forall q, q \in linear_factor_seq p -> (1 < size q)%N. Proof. move=> q; have [-> | Hp Hq] := eqVneq p 0. rewrite /linear_factor_seq /root_mu_seq. by rewrite /root_seq_uniq /root_seq size_poly0. rewrite -(nth_index 0 Hq) (nth_map (0,0%N)); last first. by rewrite -index_mem size_map in Hq. rewrite size_exp_XsubC (nth_map 0); last first. by rewrite -index_mem !size_map in Hq. rewrite -(@prednK (\mu_ _ _)) // mu_gt0 // -root_root_seq //. rewrite -mem_undup mem_nth //. by rewrite -index_mem !size_map in Hq. Qed. Lemma coprimep_linear_factor_seq p : forall (i j : 'I_(size (linear_factor_seq p))), i != j -> coprimep (linear_factor_seq p)`_i (linear_factor_seq p)`_j. Proof. move=> [i +] [j +]; rewrite !size_map=> Hi Hj Hij. rewrite !(nth_map (0,0%N)) ?size_map //. apply/coprimep_expl/coprimep_expr/coprimep_factor. by rewrite unitfE subr_eq0 !(nth_map 0) //= nth_uniq // ?undup_uniq // eq_sym. Qed. Lemma prod_XsubC_mu (p : {poly F}): p = (lead_coef p) *: \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p). Proof. rewrite {1}[p]prod_XsubC_count. by congr GRing.scale; apply: eq_bigr => i _; rewrite count_root_seq. Qed. Lemma monic_prod_XsubC p : p \is monic -> p = \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p). Proof. by move/monicP=> H; rewrite {1}[p]prod_XsubC_mu H scale1r. Qed. Lemma prod_factor (p : {poly F}): p = (lead_coef p) *: \prod_(x <- linear_factor_seq p) x. Proof. by rewrite !big_map {1}[p]prod_XsubC_mu. Qed. Lemma monic_prod_factor p : p \is monic -> p = \prod_(x <- linear_factor_seq p) x. Proof. by move/monicP=> H; rewrite {1}[p]prod_factor H scale1r. Qed. Lemma uniq_root_mu_seq (p : {poly F}) : uniq (root_seq p) -> forall x, x \in root_mu_seq p -> x.2 = 1%N. Proof. move=> H x /(nthP (0,0%N)) [] i; rewrite size_map=> Hi. rewrite (nth_map 0) // => <- /=; move: Hi. rewrite /root_seq_uniq undup_id // -count_root_seq => Hi. by rewrite count_uniq_mem // (mem_nth 0 Hi). Qed. Lemma uniq_root_dvdp p q : q != 0 -> (uniq (root_seq q)) -> p %| q -> (uniq (root_seq p)). Proof. move=> Hq Hq2 Hpq. apply: count_mem_uniq=> x. have Hc:= count_uniq_mem x Hq2. have Hle: (count_mem x (root_seq p) <= count_mem x (root_seq q))%N. rewrite !count_root_seq; case/dvdpP: Hpq => r Hr. by rewrite Hr mu_mul -?Hr // leq_addl. have: (count_mem x (root_seq p) <= 1)%N. by rewrite (leq_trans Hle) // Hc; case: (x \in root_seq q). rewrite leq_eqVlt ltnS leqn0. case Hp: (x \in root_seq p). rewrite -has_pred1 has_count in Hp. by rewrite (eqn_leq _ 0%N) leqNgt Hp orbF => /eqP ->. by rewrite eqn_leq -has_count has_pred1 Hp andbF orFb => /eqP ->. Qed. Lemma root_root_mu_seq p : [seq x.1 | x <- root_mu_seq p] = root_seq_uniq p. Proof. apply: (@eq_from_nth _ 0)=>[|i]; rewrite !size_map //. by move=> Hi; rewrite (nth_map (0,0%N)) ?size_map // (nth_map 0) //. Qed. End poly_closedFieldType. coqeal-2.1.0/theory/coherent.v000066400000000000000000000452001475512565300163040ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm choice matrix bigop zmodp mxalgebra poly. Require Import ssrcomplements dvdring stronglydiscrete. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. Declare Scope mxpresentation_scope. Delimit Scope mxpresentation_scope with MP. Local Open Scope mxpresentation_scope. (** Coherent rings *) HB.mixin Record Ring_isCoherent R of GRing.Ring R := { dim_ker : forall m n, 'M[R]_(m,n) -> nat; ker : forall m n (M : 'M_(m,n)), 'M_(dim_ker _ _ M,m); kerP_subproof : forall m n (M : 'M_(m,n)) (X : 'rV_m), reflect (exists Y, X = Y *m ker _ _ M) (X *m M == 0) }. HB.structure Definition CoherentRing := { R of Ring_isCoherent R & StronglyDiscrete R }. Notation coherentRingType := CoherentRing.type. Notation "[ 'coherentRingType' 'of' T 'for' cT ]" := (CoherentRing.clone T cT) (at level 0, format "[ 'coherentRingType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'coherentRingType' 'of' T ]" := (CoherentRing.clone T _) (at level 0, format "[ 'coherentRingType' 'of' T ]") : form_scope. Arguments dim_ker {_} [_ _]. Arguments ker {_} [_ _]. Section CoherentRingTheory. Variable R : coherentRingType. Lemma kerK m n (M : 'M[R]_(m,n)) : ker M *m M = 0. Proof. rewrite -row_matrixP => i; rewrite row_mul row0. by apply/eqP/kerP_subproof; exists (delta_mx 0 i); rewrite rowE. Qed. Lemma kerAK p m n (M : 'M_(m,n)) (N : 'M[R]_(p, _)) : N *m ker M *m M = 0. Proof. by rewrite -mulmxA kerK mulmx0. Qed. Lemma ker1 m : ker (1%:M : 'M[R]_m) = 0. Proof. by rewrite -kerK mulmx1. Qed. Lemma kerP m n k (M : 'M[R]_(m,n)) (X : 'M_(k, m)) : reflect (exists Y : 'M_(k, dim_ker M), X = Y *m ker M) (X *m M == 0). Proof. apply: (iffP eqP); last first. case=> [Y ->]; apply/row_matrixP => i. by rewrite !row_mul row0 kerAK. move=> XM0; have XM0_ i : row i X *m M == 0 by rewrite -row_mul XM0 row0. exists (\matrix_(i, j) (projT1 (sig_eqW (kerP_subproof _ _ _ _ (XM0_ i)))) 0 j). by apply/row_matrixP => i; rewrite row_mul rowK; case: sig_eqW. Qed. (** As everything is based on strongly discrete rings we can solve q systems of the kind XM = B *) Fixpoint divmx m n l : 'M_(l, n) -> 'M[R]_(m, n) -> 'M_(l, m) := if n is p.+1 return 'M_(l, n) -> 'M_(m, n) -> 'M_(l, m) then fun (B: 'M_(_, 1 + _)) (M : 'M_(_, 1 + _)) => let K := ker (lsubmx M) in let W := divid (lsubmx B) (lsubmx M) in divmx (rsubmx B - W *m rsubmx M) (K *m rsubmx M) *m K + W else fun _ _ => 0. Definition dvdmx m n k (M : 'M[R]_(m,n)) (N : 'M_(k, n)) := divmx N M *m M == N. Local Notation "M %| B" := (dvdmx M B) : mxpresentation_scope. Lemma dvdmxP m n l (M : 'M[R]_(m, n)) (B : 'M_(l, n)) : reflect (exists X, B = X *m M) (M %| B). Proof. apply: (iffP eqP)=> [<-|[X -> {B}]]; first by eexists. elim: n => //= [|n ihn] in m l M X *; first by apply/matrixP => i []. rewrite -[n.+1]/(1 + n)%N in M X *. set Ml := lsubmx M; set K := ker _; set W := divid _ _; set k := dim_ker _. rewrite mulmxDl -mulmxA -!mulmx_rsub -!mulmxBl; apply: canLR (@addrNK _ _) _. set Mr := rsubmx M; rewrite -mulmxBl -[M]hsubmxK -/Mr -/Ml !mul_mx_row. have /kerP [Y ->] : (X - W) *m Ml == 0. by rewrite mulmxBl dividK -mulmx_lsub ?subrr ?subidMl. by rewrite -!mulmxA !kerK !mulmx0 ihn. Qed. Lemma divmxK m n l (M : 'M[R]_(m, n)) (B : 'M_(l, n)) : M %| B -> divmx B M *m M = B. Proof. by move/eqP. Qed. Lemma sub_kermxP p m n (A : 'M_(m, n)) (B : 'M_(p, m)) : reflect (B *m A = 0) (ker A %| B). Proof. apply: (iffP (dvdmxP _ _)); last by move=> /eqP /kerP [X ->]; eexists. by case=> D ->; rewrite -mulmxA kerK mulmx0. Qed. Lemma dvdmx_refl m n (M : 'M[R]_(m,n)) : M %| M . Proof. by apply/dvdmxP; exists 1%:M; rewrite mul1mx. Qed. Hint Resolve dvdmx_refl : core. Lemma dvdmxMl m0 m1 m2 m3 (M : 'M[R]_(m1,m2)) (N : 'M[R]_(m3,m2)) (K : 'M[R]_(m0,m3)) : M %| N -> M %| K *m N. Proof. by case/dvdmxP=> X hX; apply/dvdmxP; exists (K *m X); rewrite -mulmxA hX. Qed. Lemma dvdmx_trans m0 m1 m2 m3 (M : 'M[R]_(m0,m1)) (N : 'M[R]_(m2,m1)) (K : 'M_(m3,m1)) : M %| N -> N %| K -> M %| K. Proof. by move=> /dvdmxP [X ->] /dvdmxP [Y ->]; rewrite mulmxA dvdmxMl. Qed. Lemma dvdmx0 k m n (M : 'M[R]_(m,n)) : M %| (0 : 'M[R]_(k,n)). Proof. by apply/dvdmxP; exists 0; rewrite mul0mx. Qed. Hint Extern 0 (is_true (_ %| 0)) => solve [apply: dvdmx0] : core. Lemma dvd1mx m n (M : 'M[R]_(m,n)) : 1%:M %| M. Proof. by apply/dvdmxP; exists M; rewrite mulmx1. Qed. Hint Resolve dvd1mx : core. Lemma dvd0mx k m n (M : 'M[R]_(m,n)) : ((0 : 'M[R]_(k,n)) %| M) = (M == 0). Proof. by apply/idP/eqP => [/dvdmxP [X ->]|-> //]; rewrite mulmx0. Qed. Lemma dvdmxMr (m0 m1 m2 m3 : nat) (K : 'M_(m2, m0)) (M : 'M[R]_(m1, m2)) (N : 'M_(m3, m2)) : (M %| N) -> (M *m K %| N *m K). Proof. by case/dvdmxP=>X hX; apply/dvdmxP; exists X; rewrite mulmxA hX. Qed. Lemma dvdmxD m0 m1 m2 (M : 'M[R]_(m0,m1)) (N K : 'M[R]_(m2,m1)) : M %| N -> M %| K -> M %| N + K. Proof. by move=> /dvdmxP [X ->] /dvdmxP [Y ->]; rewrite -mulmxDl dvdmxMl. Qed. Lemma dvdmxN m0 m1 m2 (M : 'M[R]_(m0,m1)) (N : 'M[R]_(m2,m1)) : (M %| - N) = (M %| N). Proof. by apply/dvdmxP/dvdmxP=> [] [X hX]; exists (- X); rewrite mulNmx -hX ?opprK. Qed. Lemma dvdmxDr (m0 m1 m2 : nat) (N K : 'M_(m2, m1)) (M : 'M[R]_(m0, m1)) : M %| N -> (M %| N + K) = (M %| K) :> bool. Proof. move=> dvdMN; apply/idP/idP; last exact: (dvdmxD dvdMN). by rewrite -dvdmxN in dvdMN => /(dvdmxD dvdMN); rewrite addKr. Qed. Lemma dvdmxDl (m0 m1 m2 : nat) (N K : 'M_(m2, m1)) (M : 'M[R]_(m0, m1)) : M %| N -> (M %| K + N) = (M %| K) :> bool. Proof. by rewrite addrC => /dvdmxDr ->. Qed. Lemma dvdmxBr (m0 m1 m2 : nat) (N K : 'M_(m2, m1)) (M : 'M[R]_(m0, m1)) : M %| N -> (M %| N - K) = (M %| K) :> bool. Proof. by move=> dvdMN; rewrite dvdmxDr // dvdmxN. Qed. Lemma dvdmxBl (m0 m1 m2 : nat) (N K : 'M_(m2, m1)) (M : 'M[R]_(m0, m1)) : M %| N -> (M %| K - N) = (M %| K) :> bool. Proof. by move=> dvdMN; rewrite dvdmxDl // dvdmxN. Qed. Lemma dvdmxB m0 m1 m2 (M : 'M[R]_(m0,m1)) (N K : 'M[R]_(m2,m1)) : M %| N -> M %| K -> M %| N - K. Proof. by move=> /dvdmxBr ->. Qed. Lemma dvdNmx m0 m1 m2 (M : 'M[R]_(m0,m1)) (N : 'M[R]_(m2,m1)) : (- M %| N) = (M %| N). Proof. by apply/dvdmxP/dvdmxP=> [] [X ->]; exists (- X); rewrite mulmxN mulNmx ?opprK. Qed. Definition ker_mod m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) := rsubmx (ker (col_mx M N)). Local Notation "M .-ker" := (ker_mod M) (at level 10, format "M .-ker") : mxpresentation_scope. Lemma dvd_ker k m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) (X : 'M_(k, m1)) : (M.-ker N %| X) = (M %| X *m N). Proof. apply/dvdmxP/dvdmxP. move=> [Y ->]; exists (- (Y *m lsubmx (ker (col_mx M N)))). apply/eqP; rewrite mulNmx -addr_eq0 addrC -!mulmxA -mulmxDr -mul_row_col. by rewrite hsubmxK kerK mulmx0. case=> [Y /eqP]; rewrite eq_sym -subr_eq0 -mulNmx -mul_row_col. move=> /kerP [Z /(congr1 rsubmx)]; rewrite row_mxKr -mulmx_rsub => HZ. by exists (-Z); rewrite mulNmx -HZ opprK. Qed. Lemma dvd_ker_mod_ker m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) : (M.-ker N %| ker N). Proof. by rewrite dvd_ker kerK dvdmx0. Qed. Lemma dvd_ker_mod_1 m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) : (M.-ker N %| 1%:M) = (M %| N). Proof. by rewrite dvd_ker mul1mx. Qed. Lemma ker_modK m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) : (M %| M.-ker N *m N). Proof. by rewrite -dvd_ker. Qed. Lemma ker_mod1 m0 m1 (M : 'M[R]_(m0,m1)) : M %| M.-ker 1%:M. Proof. rewrite -dvdNmx; apply/dvdmxP; exists (lsubmx (ker (col_mx M 1%:M))). apply/eqP; rewrite mulmxN -addr_eq0 addrC -[M.-ker _]mulmx1 -mul_row_col. by rewrite hsubmxK kerK. Qed. Lemma dvd_mx_col k m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) (X : 'M_(k, m2)) : (X %| col_mx M N) = (X %| M) && (X %| N). Proof. apply/dvdmxP/andP=> [[Y]|[/dvdmxP [M' ->] /dvdmxP [N' ->]]]; last first. by exists (col_mx M' N'); rewrite mul_col_mx. rewrite -[Y]vsubmxK mul_col_mx => HY. have := (congr1 usubmx HY, congr1 dsubmx HY). by rewrite !col_mxKu !col_mxKd => [[-> ->]]; rewrite !dvdmxMl. Qed. Lemma dvd_col_mxP k m0 m1 m2 (M : 'M[R]_(m0,m2)) (N : 'M[R]_(m1,m2)) (X : 'M_(k, m2)) : reflect (exists Y, M %| X - Y *m N) (col_mx M N %| X). Proof. apply: (iffP (dvdmxP _ _)) => [[Y ->]|[Y /dvdmxP [Z HZ]]]; last first. by exists (row_mx Z Y); rewrite mul_row_col -HZ addrNK. exists (rsubmx Y). by rewrite -[Y as Y' in Y' *m _]hsubmxK mul_row_col addrK dvdmxMl. Qed. Lemma dvd_col_mxl m0 m1 m2 (M : 'M[R]_(m0, m2)) (N : 'M_(m1, m2)) : col_mx M N %| N. Proof. by apply/dvd_col_mxP; exists 1%:M; rewrite mul1mx subrr. Qed. Lemma dvd_col_mxu m0 m1 m2 (M : 'M[R]_(m0, m2)) (N : 'M_(m1, m2)) : col_mx M N %| M. Proof. by apply/dvd_col_mxP; exists 0; rewrite mul0mx subr0. Qed. End CoherentRingTheory. Notation "M .-ker" := (ker_mod M) (at level 10, format "M .-ker") : mxpresentation_scope. Notation "M %| B" := (dvdmx M B) : mxpresentation_scope. #[export] Hint Resolve dvdmx_refl dvd1mx : core. #[export] Hint Extern 0 (is_true (_ %| 0)) => solve [apply: dvdmx0] : core. (* It suffices to show how to solve xM = 0 when M is a column for the ring to be coherent *) Section ker_col. Variable R : comRingType. Variable dim_ker_col : forall m, 'cV[R]_m -> nat. Variable ker_col : forall m (M : 'cV[R]_m), 'M[R]_(dim_ker_col M,m). Hypothesis ker_colP : forall m (M : 'cV_m) (X : 'rV_m), reflect (exists Y , X = Y *m ker_col M) (X *m M == 0). Fixpoint dim_ker_c m n : 'M[R]_(m,n) -> nat := if n is p.+1 then fun (M: 'M[R]_(m,1 + _)) => dim_ker_c (ker_col (lsubmx M) *m rsubmx M) else fun => m. Fixpoint ker_c m n : forall (M : 'M_(m,n)), 'M_(dim_ker_c M,m) := if n is p.+1 then fun (M : 'M_(m,1 + _)) => let G1 := ker_col (lsubmx M) in ker_c (G1 *m rsubmx M) *m G1 else fun => 1%:M. Lemma ker_cP : forall m n (M : 'M[R]_(m,n)) (X : 'rV_m), reflect (exists Y, X = Y *m ker_c M) (X *m M == 0). Proof. move=> m n; elim: n m=> [n m X | n ih m]. by rewrite ?thinmx0; apply: (iffP idP)=> //= _; exists X; rewrite mulmx1. rewrite [n.+1]/(1 + n)%nat => M /=; set G1 := ker_col (lsubmx M). move: (ih _ (G1 *m rsubmx M))=> {}ih X. apply: (iffP eqP)=> [|[Y hY]]; rewrite -{1}[M]hsubmxK (@mul_mx_row _ _ _ 1) -(@row_mx0 _ _ 1). case/(@eq_row_mx _ _ 1); case/eqP/ker_colP=> V ->; rewrite -mulmxA. by case/eqP/ih=> W ->; exists W; rewrite mulmxA. f_equal; apply/eqP. by apply/ker_colP; exists (Y *m ker_c (G1 *m rsubmx M)); rewrite -mulmxA. by rewrite hY mulmxA -[_ *m rsubmx M]mulmxA; apply/ih; exists Y. Qed. End ker_col. Lemma kerE (R : coherentRingType) m n (M : 'M[R]_(m, n)) : ker M = castmx (congr1 _ (col_0mx _), erefl) (0.-ker M). Proof. rewrite /(0.-ker) -(esymK (col_0mx _)). case: _ / (esym (col_0mx _)); rewrite castmx_id. by apply/matrixP => i j; rewrite mxE /=; congr (ker M _ _); apply: val_inj. Qed. (** This section proves that a ring is coherent is the intersection of two *) (* finitely generated ideals is again finitely generated. It requires that *) (* the underlying ring (in this case a strongly discrete ring) is an *) (* integral domain *) HB.factory Record StronglyDiscrete_isIntersectionCoherent R of StronglyDiscrete R := { (** The size of the intersection - 1, this is done to ensure that *) (* the intersection is nonempty *) dim_cap : forall m n, 'cV[R]_m -> 'cV[R]_n -> nat; (** Intersection of two ideals *) cap : forall n m (I : 'cV[R]_n) (J : 'cV[R]_m), 'cV[R]_(dim_cap _ _ I J).+1; cap_spec : forall n m (I : 'cV[R]_n) (J : 'cV[R]_m), int_spec (cap _ _ I J) }. HB.builders Context R of StronglyDiscrete_isIntersectionCoherent R. Fixpoint dim_int n : 'cV[R]_n -> nat := if n is p.+1 then fun (V : 'cV[R]_(1 + p)) => let v := usubmx V in let vs := dsubmx V : 'cV[R]_p in ((dim_cap v (-vs)).+1 + dim_int vs)%N else fun => 0%N. Definition cap_wl n m (I : 'cV_n) (J : 'cV_m) := divid (cap I J) I. Lemma wl n m (I : 'cV_n) (J : 'cV_m) : cap_wl I J *m I = cap I J. Proof. by apply: dividK; case: cap_spec. Qed. Definition cap_wr n m (I : 'cV_n) (J : 'cV_m) := divid (cap I J) J. Lemma wr n m (I : 'cV_n) (J : 'cV_m) : cap_wr I J *m J = cap I J. Proof. by apply: dividK; case: cap_spec. Qed. Fixpoint ker_c_int m : forall (V : 'cV_m),'M_(dim_int V,m) := if m is p.+1 return forall V : 'cV_m, 'M_(dim_int V,m) then fun (V' : 'cV_(1 + p)) => let v := usubmx V' in let vs := dsubmx V' in let m0 := ker_c_int vs in let wv := cap_wl v (-vs) in let wvs := cap_wr v (-vs) in block_mx (if v == 0 then delta_mx 0 0 else wv) (if v == 0 then 0 else wvs) 0 m0 else fun => 0. (* TODO: Move to ssrcomplements *) Lemma colE m n (i : 'I_n) (M : 'M[R]_(m, n)) : col i M = M *m delta_mx i 0. Proof. by apply/trmx_inj; rewrite trmx_mul trmx_delta -rowE tr_col. Qed. Lemma ker_c_intP : forall m (V : 'cV_m) (X : 'rV_m), reflect (exists Y, X = Y *m ker_c_int V) (X *m V == 0). Proof. elim => [V X | n IH] /=. rewrite thinmx0 flatmx0 /ker_c_int mulmx0 eqxx. by constructor; exists 0; rewrite mulmx0. rewrite [n.+1]/(1 + n)%nat => V X. set v := usubmx V. set vs := dsubmx V. set x := lsubmx X. set xs := rsubmx X. set m0 := ker_c_int vs. set wv := cap_wl v (-vs). set wvs := cap_wr v (-vs). move: (wl v (-vs)); rewrite -/wv => Hwv. move: (wr v (-vs)); rewrite -/wvs => Hwvs. rewrite -[V]vsubmxK -[X]hsubmxK. case: (eqVneq v 0) => v0. apply: (iffP idP) => /= [|[W ->]]. rewrite (@mul_row_col _ _ 1) -/v v0 mulmx0 add0r => vs0. case: (IH vs xs) => [[A HA]|[]]; last by apply/IH. exists (row_mx (const_mx (x 0 0)) A). rewrite (@mul_row_block _ _ _ _ 1) -/xs !mulmx0 add0r addr0 -colE col_const HA. by f_equal; apply/rowP => i; rewrite !mxE /= !ord1. rewrite -mulmxA (@mul_block_col _ _ _ 1) -/v !mul0mx addr0 add0r. rewrite -[W]hsubmxK mul_row_col {6}v0 !mulmx0 add0r mulmxA. by apply/IH; exists (rsubmx W). apply: (iffP idP) => /= [|[W ->]]. rewrite (@mul_row_col _ _ 1) => hwx. have vx00 : ((x * v) 0 0)%:M = x * v. by apply/matrixP=> i j; rewrite !ord1 !mxE eqxx. have : member ((x * v) 0 0) (cap v (- vs)). case: cap_spec => c /= _ _ in_int. apply: in_int; first by apply/memberP; exists x; rewrite vx00. apply/memberP; exists xs; apply/eqP. move: hwx; rewrite -/v -/vs -/x -/xs mulmxN addr_eq0 => /eqP <-. by rewrite vx00. case/memberP=> W hW. case: (IH vs (xs - (W *m wvs))) => [[A HA]|[]]. exists (row_mx W A). rewrite (@mul_row_block _ _ _ _ 1) mulmx0 addr0 -HA addrCA subrr addr0. f_equal; apply/(@scalemx_inj _ _ _ (v 0 0)). (* The proof breaks down here if strongly discrete rings are not idomains! *) apply: contra_neq v0 => v00. by apply/rowP => i; rewrite !ord1 /= v00 !mxE. by rewrite -!mul_mx_scalar -mx11_scalar -mulmxA Hwv -hW -/x vx00. by apply/IH; rewrite mulmxDl mulNmx addrC -mulmxN -mulmxA Hwvs -hW vx00. rewrite -[W]hsubmxK (@mul_row_block _ _ _ _ 1) mulmx0 addr0 (@mul_row_col _ _ 1). rewrite -!mulmxA Hwv addr_eq0 -mulmxN mulmxDl -!mulmxA Hwvs addrC -subr_eq. rewrite addrN -/vs !mulmxN eq_sym oppr_eq0 mulmxA. case: (IH vs _) => // [[]]. by exists (rsubmx W). Qed. HB.instance Definition _ := Ring_isCoherent.Build R (ker_cP ker_c_intP). HB.end. (* Using the above result one can prove that Bezout rings are coherent, however this is not what we want as we want to prove that constructive PIDs are coherent using smith *) Module BezoutCoherent. Section BezoutCoherent. Variable R : bezoutDomainType. Definition bdim_cap m n (I : 'cV[R]_m) (J : 'cV[R]_n) := 0%N. Definition bcap m n (I : 'cV_m) (J : 'cV_n) : 'cV[R]_1 := (lcmr (principal_gen I) (principal_gen J))%:M. Definition bcap_wl m n (I : 'cV_m) (J : 'cV_n) : 'rV[R]_m := let a := principal_gen I in let b := principal_gen J in (odflt 0 (b %/? gcdr a b))%:M *m principal_w1 I. Lemma bcap_wlP m n (I : 'cV_m) (J : 'cV_n) : bcap_wl I J *m I = bcap I J. Proof. rewrite /bcap_wl /bcap -mulmxA principal_w1_correct mul_scalar_mx. apply/rowP => i; rewrite !mxE !ord1 {i} /= !mulr1n. set a := principal_gen _; set b := principal_gen _. have [-> | b0] := eqVneq b 0; first by rewrite lcm0r mulr0. have [-> | a0] := eqVneq a 0. by rewrite lcmr0 odiv0r /= ?mul0r // gcdr_eq0 negb_and b0. case: odivrP => /= => [x Hx | H]. apply/(@mulIf _ (gcdr b a)); first by rewrite gcdr_eq0 negb_and b0. by rewrite mulr_lcm_gcd -mulrA mulrCA -Hx. case/dvdrP: (dvdr_gcdr b a) => x /eqP Hx. by move: (H x); rewrite Hx. Qed. Definition bcap_wr m n (I : 'cV_m) (J : 'cV_n) : 'rV[R]_n := let a := principal_gen I in let b := principal_gen J in (odflt 0 (a %/? (gcdr a b)))%:M *m principal_w1 J. Lemma bcap_wrP n m (I : 'cV_n) (J : 'cV_m) : bcap_wr I J *m J = bcap I J. Proof. rewrite /bcap_wl /bcap -mulmxA principal_w1_correct mul_scalar_mx. apply/rowP => i; rewrite !mxE !ord1 {i} /= !mulr1n. set b := principal_gen _; set a := principal_gen _. have [-> | a0] := eqVneq a 0; first by rewrite lcmr0 mulr0. have [-> | b0] := eqVneq b 0. by rewrite lcm0r odiv0r /= ?mul0r // gcdr_eq0 negb_and eqxx. case: odivrP => /= => [x Hx | H]. apply/(@mulIf _ (gcdr b a)); first by rewrite gcdr_eq0 negb_and b0. by rewrite -mulrA mulrCA -Hx mulr_lcm_gcd mulrC. case/dvdrP: (dvdr_gcdl b a) => x /eqP Hx. by move: (H x); rewrite Hx. Qed. Lemma bcap_int (x : 'M_1) (m n : nat) (I : 'cV_m) (J : 'cV_n) : (exists I' : 'rV_m, I' *m I = x) -> (exists J' : 'rV_n, J' *m J = x) -> exists W : 'M_1, W *m bcap I J = x. Proof. case => I' HI' [J' HJ']. move: (principal_w2_correct I). move: (principal_w2_correct J). rewrite /bcap /principal. set a := principal_gen I; set b := principal_gen J => Hb Ha. have div1 : (a %| x 0 0)%R. apply/dvdrP. exists ((I' *m principal_w2 I) 0 0). move: HI'. rewrite -{1}Ha => <-. by rewrite mulrC mul_mx_scalar -scalemxAr !mxE. have div2 : (b %| x 0 0)%R. apply/dvdrP. exists ((J' *m principal_w2 J) 0 0). move: HJ'. rewrite -{1}Hb => <-. by rewrite mulrC mul_mx_scalar -scalemxAr !mxE. move/dvdrP: (dvdr_lcm a b (x 0 0)). rewrite div1 div2 /= => [[y Hy]]. exists y%:M. by rewrite -scalar_mxM -Hy -mx11_scalar. Qed. (* This is a bit ugly... *) Lemma bcap_spec m n (I : 'cV[R]_m) (J : 'cV[R]_n) : @int_spec _ _ m n I J (bcap I J). Proof. split. - by apply/subidP; exists (bcap_wl I J); rewrite bcap_wlP. - by apply/subidP; exists (bcap_wr I J); rewrite bcap_wrP. move=> /= x. case/memberP => I' hI'. case/memberP => J' hJ'. apply/memberP. have h1 : exists I'0 : 'rV_m, I'0 *m I = x%:M by exists I'. have h2 : exists J'0 : 'rV_n, J'0 *m J = x%:M by exists J'. case: (bcap_int h1 h2) => D hD. by exists D. Qed. #[non_forgetful_inheritance] HB.instance Definition _ := StronglyDiscrete_isIntersectionCoherent.Build R bcap_spec. End BezoutCoherent. End BezoutCoherent. coqeal-2.1.0/theory/companion.v000066400000000000000000000142701475512565300164630ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect. From mathcomp Require Import all_algebra. From CoqEAL Require Import ssrcomplements mxstructure. (** This file defines companion matrices for any non-constant polynomial and prooves the properties of their characteristic and minimal polynomials companion_mx p == The companion matrix of the polynomial p. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section Companion. Local Open Scope ring_scope. Import GRing.Theory. Variable R : comRingType. Definition companion_mxn n (p : {poly R}) := \matrix_(i, j < n ) ((i == j.+1 :> nat)%:R - p`_i *+ ((size p).-2 == j)). Definition companion_mx (p : {poly R}) := companion_mxn (size p).-2.+1 p. Lemma comp_char_polyK : forall (p : {poly R}), p \is monic -> (1 < size p)%N -> char_poly (companion_mx p) = p. Proof. apply: poly_ind=> [|p c IHp]; first by move/monic_neq0/eqP. have [-> H | p0 Hm Hs] := eqVneq p 0. by rewrite mul0r add0r {1}size_polyC; case: eqP. have Hcst1 : (size (p * 'X + c%:P)).-1 = (size p).-1.+1. by rewrite size_MXaddC (negbTE p0) -polySpred. have Hmp : p \is monic. rewrite monicE -lead_coefMX -(@lead_coefDl _ _ (c%:P)) -?monicE //. by rewrite size_polyC size_mulX // polySpred //; case:(c != 0). case: (ltnP 1 (size p))=> Hpt; last first. have Hp1: p = 1%:P by rewrite -(monicP Hmp) [p]size1_polyC // lead_coefC. rewrite /companion_mx !Hcst1 Hp1 mul1r /char_poly size_polyC oner_eq0. set M := char_poly_mx _. rewrite [M]mx11_scalar det_scalar1 !mxE coefD coefC coefX. by rewrite !add0r polyCN opprK size_XaddC. rewrite /char_poly /companion_mx Hcst1. rewrite (expand_det_row _ ord0) big_ord_recl !mxE. rewrite mulr1n !mulr0n add0r /cofactor !addn0 expr0 mul1r. set d1 := \det _. case Hnp: (size p) (Hpt)=> [|n] //; case: n Hnp=> // n Hnp _. rewrite big_ord_recr big1; last first. move=> i _; rewrite !mxE !sub0r size_MXaddC (negbTE p0) andFb. have:= (neq_ltn n (widen_ord (leqnSn n) i)). rewrite Hnp (ltn_ord i) orbT lift0 eqSS. by move/negbTE ->; rewrite polyCN opprK mul0r. rewrite /= add0r; set M := row' _ _. have HM: upper_triangular_mx M. apply/upper_triangular_mxP=> i j Hij. rewrite !mxE -(inj_eq (@ord_inj _)) /= /bump !leq0n leqNgt (ltn_ord j). rewrite add1n eqn_leq leqNgt ltnS ltnW // sub0r eqSS eqn_leq leqNgt Hij. rewrite sub0r eqn_leq size_MXaddC (negbTE p0) andFb Hnp. by rewrite (leqNgt n.+1) (ltn_ord j) polyCN opprK. have->: \det M = (-1)^+n.+1. rewrite (det_triangular_mx HM) -{7}[n.+1]card_ord -prodr_const. apply: eq_bigr=> i _; rewrite !mxE -(inj_eq (@ord_inj _)) !lift0 !lift_max. rewrite eqxx !eqn_leq ltnn size_MXaddC (negbTE p0) andFb Hnp. by rewrite (leqNgt _ i) (ltn_ord i) sub0r subr0. rewrite !mxE -exprD -signr_odd addnn odd_double mulr1 polyCN opprK. rewrite size_MXaddC (negbTE p0) andFb Hnp addr0 !sub0r. rewrite -{1}cons_poly_def coef_cons polyCN opprK !eqxx -(IHp Hmp Hpt) mulrC. suff ->: d1 = char_poly (companion_mx p)=> //. rewrite /companion_mx. have ->: (size p).-2.+1 = (size p).-1.+1.-1.+1.-1 by rewrite Hnp. congr (\det _); rewrite row'_col'_char_poly_mx; congr char_poly_mx. apply/matrixP=> i j; rewrite !mxE !eqSS -cons_poly_def coef_cons size_cons_poly. rewrite nil_poly (negbTE p0). by rewrite !lift0 /= {4 9}Hnp. Qed. End Companion. Section CompanionMin. Variable F : fieldType. Local Open Scope ring_scope. Import GRing.Theory. Lemma comp_mxminpolyK : forall (p : {poly F}), p \is monic -> (1 < size p)%N -> mxminpoly (companion_mx p) = p. Proof. move=> p Hp Hs. set A := companion_mx p. suff Hn: forall q, horner_mx A q = 0 -> (q == 0) || ((size p).-2 < (size q).-1)%N. have Hm0: (mxminpoly A == 0) = false. by apply: negbTE; rewrite monic_neq0 // mxminpoly_monic. have:= Hn (mxminpoly A) (mx_root_minpoly A); rewrite Hm0 /= => Hmn. have Hsm : size (mxminpoly A) == size (char_poly A). rewrite eqn_leq dvdp_leq ?mxminpoly_dvd_char ?monic_neq0 ?char_poly_monic //. by rewrite size_char_poly -(addn1 _.-2) addnC -ltn_subRL subn1. apply/eqP; rewrite -eqp_monic // ?mxminpoly_monic //. by rewrite -{2}(comp_char_polyK Hp) // -dvdp_size_eqp // mxminpoly_dvd_char. move=> q; case: (ltnP (size p).-2 (size q).-1); first by rewrite orbT. have H (i : 'I_(size p).-2): A *m col (widen_ord (leqnSn (size p).-2) i) 1%:M = col (lift ord0 i) 1%:M. rewrite col_id_mulmx; apply/matrixP=> j k; rewrite !mxE. rewrite -(inj_eq (@ord_inj _)) lift0. by rewrite (eqn_leq _ i) (leqNgt _ i) (ltn_ord i) subr0. have H2: forall i : 'I_(size p).-2.+1, (A ^+ i) *m col ord0 1%:M = col i 1%:M. case; elim=> [Hi|i IH Hi] /=. by rewrite expr0 mul1mx; congr col; apply: ord_inj. rewrite exprS -mulmxA (IH (ltnW Hi)). have Ho: (i < (size p).-2)%N by rewrite -ltnS. have ->: (Ordinal (ltnW Hi)) = (widen_ord (leqnSn (size p).-2) (Ordinal Ho)). by apply: ord_inj. by rewrite H; congr col; apply: ord_inj; rewrite lift0. case Hq: (q == 0)=> //. have Hsq: (0 < size q)%N by rewrite size_poly_gt0 Hq. rewrite /horner_mx /horner_morph horner_coef. rewrite size_map_poly_id0 ?fmorph_eq0 ?lead_coef_eq0 ?Hq // => H1 Hb. have Hw: (size q <= (size p).-2.+1)%N by rewrite -(prednK Hsq). suff : q == 0 by rewrite Hq. have: \sum_(i < size q) q`_i *: (A ^+ i *m col ord0 1%:M) = 0. rewrite (eq_bigr (fun i : 'I_(size q) => ((map_poly scalar_mx q)`_i * A ^+ i) *m col ord0 1%:M)). by rewrite -mulmx_suml ?Hb ?mul0mx //. by move=> i _; rewrite coef_map scalemxAl -mul_scalar_mx. set b := \sum_(_ < _) _. have <-: \col_(i < (size p).-2.+1) q`_i = b. apply/matrixP=> i j; rewrite mxE summxE. case: (ltnP i (size q))=> Hi. rewrite (bigD1 (Ordinal Hi)) //= H2 !mxE eqxx mulr1 big1 ?addr0 //. move=> k Hk; rewrite (H2 (widen_ord Hw k)) !mxE. move/negbTE: Hk; rewrite -!(inj_eq (@ord_inj _)) /= eq_sym=> ->. by rewrite mulr0. rewrite nth_default // big1 // => k _. rewrite (H2 (widen_ord Hw k)) !mxE -(inj_eq (@ord_inj _)) /= eqn_leq. by rewrite leqNgt (leq_trans (ltn_ord k) Hi) andFb mulr0. move/matrixP=> Hc. apply/eqP/size_poly_leq0P/leq_sizeP=> j _. case: (ltnP j (size p).-2.+1)=> Hj. by move: (Hc (Ordinal Hj) ord0); rewrite !mxE. by rewrite nth_default //; apply: leq_trans Hj. Qed. End CompanionMin. coqeal-2.1.0/theory/dvdring.v000066400000000000000000001725601475512565300161440ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From Coq Require Import ssreflect ssrfun ssrbool Arith.Wf_nat. From mathcomp Require Import eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm tuple choice generic_quotient. From mathcomp Require Import matrix bigop zmodp mxalgebra poly. Require Import stronglydiscrete. (* Require Import generic_quotient. (* testing *) *) Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. (* tools for Acc induction *) Scheme acc_dep := Induction for Acc Sort Type. Lemma ssr_lt_wf : well_founded (fun x y => x < y). Proof. by apply: (well_founded_lt_compat _ id)=>x y /ltP. Defined. Section GUARD. Variable A: Type. Variable P : A -> A -> Prop. Fixpoint guarded (n: nat) (Wf: well_founded P) : well_founded P := if n is m.+1 then fun x => @Acc_intro _ _ x (fun y _ => guarded m (guarded m Wf) y) else Wf. End GUARD. (** Explicit divisibility ring *) (* Specification of division: div_spec a b == b | a *) Variant div_spec (R : ringType) (a b : R) : option R -> Type := | DivDvd x of a = x * b : div_spec a b (Some x) | DivNDvd of (forall x, a != x * b) : div_spec a b None. HB.mixin Record Ring_hasDiv R of GRing.Ring R := { div : R -> R -> option R; div_subdef : forall a b, div_spec a b (div a b) }. HB.structure Definition DvdRing := { R of Ring_hasDiv R & GRing.IntegralDomain R }. Bind Scope ring_scope with DvdRing.sort. Notation dvdRingType := DvdRing.type. Notation "[ 'dvdRingType' 'of' T 'for' cT ]" := (DvdRing.clone T cT) (at level 0, format "[ 'dvdRingType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'dvdRingType' 'of' T ]" := (DvdRing.clone T _) (at level 0, format "[ 'dvdRingType' 'of' T ]") : form_scope. Definition odivr R := @div R. Definition dvdr R a b := @odivr R b a : bool. Definition eqd (R : dvdRingType) (a b : R) := (dvdr a b) && (dvdr b a). Definition sdvdr (R : dvdRingType) (x y : R) := (dvdr x y) && ~~(dvdr y x). Module Notations. Notation "%=R" := (@eqd _) : ring_scope. Notation "a %= b" := (@eqd _ a b) (at level 70, no associativity): ring_scope. Notation "%|%R" := (@dvdr _) : ring_scope. Notation "a %| b" := (dvdr a b) : ring_scope. Notation "%/?%R" := (@odivr _) : ring_scope. Notation "a %/? b" := (odivr a b) (at level 70, no associativity): ring_scope. Notation "%<|R" := (@sdvdr _). Notation "x %<| y" := (sdvdr x y) (at level 70, no associativity). End Notations. Export Notations. Section DvdRingTheory. Variable R : dvdRingType. Implicit Types a b c : R. (** Properties of odivr *) Lemma odivrP : forall a b, div_spec a b (a %/? b). Proof. exact: div_subdef. Qed. Lemma odiv0r a : a != 0 -> 0 %/? a = Some 0. Proof. case: odivrP=> [x|H _]; last by move: (H 0); rewrite mul0r eqxx. by move/eqP; rewrite eq_sym mulf_eq0 orbC; case: eqP => //= _ /eqP->. Qed. Lemma odivr0 a : a != 0 -> a %/? 0 = None. Proof. by case: odivrP=> // x; rewrite mulr0=> ->; rewrite eqxx. Qed. Lemma odivr1 a : a %/? 1 = Some a. Proof. case: odivrP=> [x|H]; first by rewrite mulr1=> ->. by move: (H a); rewrite mulr1 eqxx. Qed. Lemma odivrr a : a != 0 -> a %/? a = Some 1. Proof. move=> a0; case: odivrP=> [x|H]. by rewrite -{1}[a]mul1r; move/(mulIf a0) <-. by move: (H 1); rewrite mul1r eqxx. Qed. Lemma odivr_mulrK a b : a != 0 -> b * a %/? a = Some b. Proof. move=> a0; case: odivrP=> [x|H]; first by move/(mulIf a0) ->. by move: (H b); rewrite eqxx. Qed. Lemma odivr_mulKr a b : a != 0 -> a * b %/? a = Some b. Proof. by move=> a0; rewrite mulrC odivr_mulrK. Qed. Lemma odivr_mul2l a b c : a != 0 -> b != 0 -> a * b %/? (a * c) = (b %/? c). Proof. move=> a0 b0. case c0: (c == 0); first by rewrite (eqP c0) mulr0 !odivr0 // mulf_neq0. case: odivrP=> [x|H]. rewrite mulrCA; move/(mulfI a0). case: (odivrP b c)=> [x' ->|H]; first by move/(mulIf (negbT c0)) ->. by move=> Hbxc; move: (H x); rewrite Hbxc eqxx. by case: odivrP=> //x Hbxc; move: (H x); rewrite mulrCA Hbxc eqxx. Qed. Lemma odivr_mul2r a b c : a != 0 -> b != 0 -> b * a %/? (c * a) = (b %/? c). Proof. by move=> a0 b0; rewrite mulrC [_ * a]mulrC odivr_mul2l. Qed. Lemma odivr_some a b c : a %/? b = Some c -> a = b * c. Proof. by case: odivrP=>// x -> [<-]; rewrite mulrC. Qed. (** Properties of dvdr *) Lemma dvdrP a b : reflect (exists x, b = x * a) (a %| b). Proof. rewrite /dvdr; case: odivrP=> //= [x|] hx; constructor; first by exists x. by case=> x /eqP; apply: negP. Qed. (****) Lemma eqdP a b : reflect (exists2 c12 : R, (c12 \is a GRing.unit) & c12 * a = b) (a %= b). Proof. apply: (iffP andP). case=> /dvdrP [x Hx] /dvdrP [y Hy]. case: (eqVneq b 0) => Hb. rewrite Hb mulr0 in Hy. by exists 1; rewrite ?unitr1 // Hy mulr0 Hb. exists x; last by rewrite Hx. apply/GRing.unitrPr; exists y. rewrite Hy mulrA in Hx. by apply: (mulIf Hb); rewrite -Hx mul1r. case=> c Hc H; split; apply/dvdrP. by exists c; rewrite H. exists (c^-1); apply: (@mulfI _ c). by apply/eqP=> Habs; rewrite Habs unitr0 in Hc. by rewrite mulrA mulrV // mul1r. Qed. (****) Lemma dvdrr a : a %| a. Proof. by apply/dvdrP; exists 1; rewrite mul1r. Qed. Hint Resolve dvdrr : core. Lemma dvdr_trans : transitive (@dvdr R). Proof. move=> b a c; case/dvdrP=> x ->; case/dvdrP=> y ->. by apply/dvdrP; exists (y * x); rewrite mulrA. Qed. Lemma dvdr0 a : a %| 0. Proof. by apply/dvdrP; exists 0; rewrite mul0r. Qed. Lemma dvd0r a : (0 %| a) = (a == 0) :> bool. Proof. apply/idP/idP; last by move/eqP->. by case/dvdrP=> x; rewrite mulr0=> ->. Qed. Lemma dvdr_add a b c : a %| b -> a %| c -> a %| b + c. Proof. case/dvdrP=>x bax; case/dvdrP=>y cay. by apply/dvdrP; exists (x + y); rewrite mulrDl bax cay. Qed. Lemma dvdrN a b : (a %| - b) = (a %| b). Proof. apply/dvdrP/dvdrP=> [] [x hx]; exists (-x); first by rewrite mulNr -hx opprK. by rewrite hx mulNr. Qed. Lemma dvdNr a b : (- a %| b) = (a %| b). Proof. apply/dvdrP/dvdrP=> [] [x ->]; exists (-x); rewrite ?mulrNN //. by rewrite mulNr mulrN. Qed. Lemma dvdrNN a b : (- a %| - b) = (a %| b). Proof. by rewrite dvdNr dvdrN. Qed. Lemma dvdr_sub a b c : a %| b -> a %| c -> a %| b - c. Proof. by move=> ab ac; rewrite dvdr_add // dvdrN. Qed. Lemma dvdr_addl a b c : b %| a -> (b %| c + a) = (b %| c). Proof. move=> ba; apply/idP/idP=> ha; last exact: dvdr_add. by rewrite -[c](addrK a) dvdr_sub. Qed. Lemma dvdr_addr a b c : b %| a -> (b %| a + c) = (b %| c). Proof. by move=> ba; rewrite addrC dvdr_addl. Qed. Lemma dvdr_add_eq a b c : a %| b + c -> (a %| b) = (a %| c). Proof. by move=> ha; rewrite -[b](addrK c) dvdr_addr // dvdrN. Qed. Lemma dvdr_mull c a b : a %| b -> a %| c * b. Proof. by case/dvdrP=> x ->; apply/dvdrP; exists (c * x); rewrite mulrA. Qed. Lemma dvdr_mulr b a c : a %| c -> a %| c * b. Proof. by move=> hac; rewrite mulrC dvdr_mull. Qed. Lemma dvdr_mul c d a b : a %| c -> b %| d -> a * b %| c * d. Proof. case/dvdrP=>x ->; case/dvdrP=> y ->. by rewrite -mulrCA; apply/dvdrP; exists (y * x); rewrite !mulrA. Qed. Lemma dvdr_mul2r c a b : c != 0 -> (a * c %| b * c) = (a %| b) :> bool. Proof. move=> c0; apply/idP/idP=> [|hab]; last exact: dvdr_mul. case/dvdrP=> x /eqP; rewrite mulrA (inj_eq (mulIf _)) // => /eqP ->. exact: dvdr_mull. Qed. Lemma dvdr_mul2l c a b : c != 0 -> (c * a %| c * b) = (a %| b) :> bool. Proof. by move=> c0; rewrite ![c * _]mulrC dvdr_mul2r. Qed. Lemma dvd1r a : 1 %| a. Proof. by apply/dvdrP; exists a; rewrite mulr1. Qed. Hint Resolve dvd1r : core. (* Sorted and dvdr *) Lemma sorted_dvd0r (s : seq R) : sorted %|%R (0 :: s) -> all (eq_op^~ 0) s. Proof. move/(order_path_min dvdr_trans)/(all_nthP 0)=> hi. by apply/(all_nthP 0) => i his; rewrite -dvd0r; apply: hi. Qed. Lemma sorted_cons (a : R) s : sorted %|%R s -> a %| s`_0 -> sorted %|%R (a :: s). Proof. by elim: s a=> //= a s ih a'; rewrite /nth => -> ->. Qed. Lemma sorted_nth0 (s : seq R) : sorted %|%R s -> forall i, s`_0 %| s`_i. Proof. case: s=> [_|a s hi] [|i] /=; do? by rewrite dvdrr. have [his|hsi] := ltnP i (size s); last by rewrite nth_default // dvdr0. by move/(order_path_min dvdr_trans)/(all_nthP 0): hi => ->. Qed. (** Properties of eqd *) Lemma eqd_def : forall a b, a %= b = (a %| b) && (b %| a). Proof. by []. Qed. Lemma eqdd a : a %= a. Proof. by rewrite eqd_def dvdrr. Qed. Hint Resolve eqdd : core. Lemma eqd_sym : symmetric (@eqd R). Proof. by move=> a b; rewrite eqd_def; apply/andP/andP; case. Qed. Hint Resolve eqd_sym : core. Lemma eqd_trans : transitive (@eqd R). Proof. move=> a b c; rewrite !eqd_def; case/andP=> ba ab; case/andP=> ac ca. by rewrite (dvdr_trans ba) // (dvdr_trans ca). Qed. (* Canonical Structure eqd_Equiv := EquivRel eqdd eqd_sym eqd_trans. *) (* uncomment it when the proof won't get stuck *) Lemma congr_eqd b d a c : a %= b -> c %= d -> (a %= c) = (b %= d). Proof. move=> ab cd; apply/idP/idP=> [ac|bd]. by rewrite eqd_sym in ab; rewrite (eqd_trans (eqd_trans ab ac) cd). by rewrite eqd_sym in cd; rewrite (eqd_trans ab (eqd_trans bd cd)). (* Not working: *) (* by move=> b d a c ab cd; rewrite !equivE (equivP ab) (equivP cd). *) Qed. (* Local Notation DR := {R %/ %=R}. *) Lemma eqdr0 a : (a %= 0) = (a == 0). Proof. by rewrite eqd_def dvdr0 dvd0r. Qed. Lemma eqd0r a : (0 %= a) = (a == 0). Proof. by rewrite eqd_def dvdr0 dvd0r andbT. Qed. Lemma eq_eqd a b : a = b -> a %= b. Proof. by move->. Qed. Lemma eqd_mul c d a b : a %= c -> b %= d -> a * b %= c * d. Proof. by rewrite /eqd; do 2!case/andP=> ? ?; rewrite !dvdr_mul. Qed. (* Print Canonical Projections. *) (* Lemma mulqr_pi : forall a a' b b', a = a' %{m DR} -> b = b' %{m DR} *) (* -> a * b = a' * b' %{m DR}. *) (* Proof. *) (* move=> a a' b b'. move/equivP; move/eqd_mul2rW. *) (* Proof. *) (* move=> a b /=; rewrite /mulqr. *) (* rewrite (equivP (@eqd_mul2rW a _ _ _)) ?equivE ?reprK //. *) (* by rewrite (equivP (@eqd_mul2lW b _ _ _)) ?equivE ?reprK. *) (* Qed. *) (* Definition mulqr (a b : DR) : DR := (\pi ((repr a) * (repr b))). *) (* Local Notation "x *d y" := (mulqr x y) *) (* (at level 40, left associativity, format "x *d y"). *) (* Lemma mulqr_pi : forall a b, (\pi a) *d (\pi b) = \pi (a * b). *) (* Proof. *) (* move=> a b /=; rewrite /mulqr. *) (* rewrite (equivP (@eqd_mul2rW a _ _ _)) ?equivE ?reprK //. *) (* by rewrite (equivP (@eqd_mul2lW b _ _ _)) ?equivE ?reprK. *) (* Qed. *) (* Lemma mulqr_pi : forall a b, (\pi a) *d (\pi b) = \pi (a * b). *) (* Proof. *) (* move=> a b /=; rewrite /mulqr. *) (* rewrite (equivP (@eqd_mul2rW a _ _ _)) ?equivE ?reprK //. *) (* by rewrite (equivP (@eqd_mul2lW b _ _ _)) ?equivE ?reprK. *) (* Qed. *) (* Lemma mulqr1 : forall x, x *d \pi_DR 1 = x. *) (* by elim/quotW=> x; rewrite mulqr_pi mulr1. Qed. *) (* Lemma mulq1r : forall x, \pi_DR 1 *d x = x. *) (* by elim/quotW=> x; rewrite mulqr_pi mul1r. Qed. *) (* Lemma eqd_mul : forall a b c d, a %= b -> c %= d -> a * c %= b * d. *) (* Proof. by move=> ????; rewrite !equivE -!mulqr_pi; move/eqP->; move/eqP->. Qed. *) Lemma eqd_mul2l c a b : c != 0 -> (c * a %= c * b) = (a %= b). Proof. by move=> c0; rewrite eqd_def !dvdr_mul2l. Qed. Lemma eqd_mul2r c a b : c != 0 -> (a * c %= b * c) = (a %= b). Proof. by move=> c0; rewrite eqd_def !dvdr_mul2r. Qed. Lemma eqd_dvd c d a b : a %= c -> b %= d -> (a %| b) = (c %| d). Proof. rewrite !eqd_def; case/andP=> ac ca; case/andP=> bd db. apply/idP/idP=> [ab|cd]; first exact: (dvdr_trans ca (dvdr_trans ab bd)). exact: (dvdr_trans ac (dvdr_trans cd db)). Qed. (****) Lemma eqd_dvdr b a c : a %= b -> (c %| a) = (c %| b). Proof. exact: eqd_dvd. Qed. Lemma eqd_dvdl b a c : a %= b -> (a %| c) = (b %| c). Proof. by move/eqd_dvd; apply. Qed. Lemma eqd_ltrans : left_transitive (@eqd R). Proof. exact: (left_trans eqd_sym eqd_trans). Qed. Lemma eqd_rtrans : right_transitive (@eqd R). Proof. exact: (right_trans eqd_sym eqd_trans). Qed. Lemma eqd_mulr b a c : a %= b -> a * c %= b * c. Proof. by move/eqd_mul; apply. Qed. Lemma eqd_mull b a c : a %= b -> c * a %= c * b. Proof. exact: eqd_mul. Qed. (****) (* dvdr + unit *) Lemma dvdr1 a : (a %| 1) = (a %= 1). Proof. by rewrite /eqd dvd1r andbT. Qed. Lemma unitd1 a : (a \is a GRing.unit) = (a %= 1). Proof. rewrite -dvdr1; apply/unitrP/dvdrP => [[x [Hxa1 _]]|[x H]]; exists x => //. by split=> //; rewrite mulrC. Qed. Lemma eqd1 a : a \in GRing.unit -> a %= 1. Proof. by rewrite unitd1. Qed. (* Lemma dvdr_mulUr_r : forall x a b, x \in GRing.unit *) (* -> (a %| x * b) = (a %| b) :> bool. *) (* Proof. *) (* move=> x a b ux; rewrite -!(dvdqr_pi, mulqr_pi) (equivP (unit_eqd1 ux)). *) (* by rewrite mulqr_pi !dvdqr_pi mul1r. *) (* Qed. *) (* Lemma dvdr_mulrU_r : forall x a b, x \in GRing.unit *) (* -> (a %| b * x) = (a %| b) :> bool. *) (* Proof. by move=> x a b; rewrite mulrC; apply: dvdr_mulUr_r. Qed. *) (* Lemma dvdr_mulUr_l : forall x a b, x \in GRing.unit -> *) (* (x * b %| a) = (b %| a) :> bool. *) (* Proof. *) (* move=> x a b; rewrite -eqd1. *) (* by move/(eqd_mul2rW b); move/eqd_dvdr->; rewrite mul1r. *) (* Qed. *) (* Lemma dvdr_mulrU_l : forall x a b, x \in GRing.unit *) (* -> (b * x %| a) = (b %| a) :> bool. *) (* Proof. by move=> x a b; rewrite mulrC; apply: dvdr_mulUr_l. Qed. *) Lemma dvdUr a b : a %= 1 -> a %| b. Proof. by move=> a1; rewrite (eqd_dvd a1 (eqdd _)) dvd1r. Qed. Lemma dvdrU b a : b %= 1 -> a %| b = (a %= 1). Proof. by move=> b1; rewrite (eqd_dvd (eqdd _) b1) dvdr1. Qed. Lemma dvdr_mulr_l b a : b != 0 -> (a * b %| b) = (a %= 1). Proof. by move=> b0; rewrite -{2}[b]mul1r dvdr_mul2r ?dvdr1. Qed. Lemma dvdr_mull_l b a : b != 0 -> (b * a %| b) = (a %= 1). Proof. by move=> b0; rewrite mulrC dvdr_mulr_l. Qed. (* Lemma dvdr_expl : forall a b, ~(a %| b) \/ (exists x, b = a*x). Proof. move=> a b; case H: (a %| b); last by constructor. by constructor 2; move: H; case/dvdrP=>x bax; exists x. Qed. *) (* eqd + unit *) (* Lemma eqd_mulUr : forall a b x, a %= b * x -> x \in GRing.unit -> a %= b. Proof. move=> a b x; rewrite /eqd; case/andP=>abx bxa xU. apply/andP; split; first exact: dvdr_mulUr xU abx. by case/dvdrP: bxa=> x' H; apply/dvdrP; exists (x*x'); rewrite mulrA. Qed. Lemma eqd_mulUl : forall a b x, a %= x * b -> x \in GRing.unit -> a %= b. Proof. by move=> a b x; rewrite mulrC; apply: eqd_mulUr. Qed. Lemma eqdU1 : forall a, (a \in GRing.unit) = (a %= 1). Proof. by move=> a; apply/idP/idP; rewrite /eqd dvdr1 dvd1r; [move=> ->|case/andP]. Qed. *) (** Properties of sdvdr *) Lemma sdvdr_def : forall a b, a %<| b = (a %| b) && ~~(b %| a). Proof. by []. Qed. Lemma sdvdrW a b : a %<| b -> a %| b. Proof. by case/andP. Qed. Lemma sdvdrNW a b : a %<| b -> ~~(b %| a). Proof. by case/andP. Qed. Lemma sdvdr0 a : a %<| 0 = (a != 0). Proof. by rewrite sdvdr_def dvdr0 dvd0r. Qed. Lemma sdvd0r a : 0 %<| a = false. Proof. by rewrite sdvdr_def dvdr0 andbF. Qed. (****) (** bigop **) Lemma big_dvdr (I : finType) (d : R) (F : I -> R) (P : pred I) : (forall i, d %| F i) -> d %| \sum_(i : I | P i) (F i). Proof. move=> H; elim: (index_enum I)=> [|a l IHl]. by rewrite big_nil dvdr0. rewrite big_cons; case: (P a). by rewrite dvdr_addl; [apply: H | apply: IHl]. exact: IHl. Qed. Lemma eqd_big_mul n (P : pred 'I_n) (F1 F2 : 'I_n -> R) : (forall i, P i -> F1 i %= F2 i) -> \prod_(i | P i) F1 i %= \prod_(i | P i) F2 i. Proof. apply: (big_ind2 (@eqd R))=> // a b c d. exact: eqd_mul. Qed. Lemma eqd_big_mul1 n (P : pred 'I_n) (F : 'I_n -> R) : \prod_(i < n | P i) F i %= 1 -> (forall i, P i -> F i %= 1). Proof. case: n P F=> [ ? ? ? []|n P F Hb i Hi] //. rewrite (bigD1 i) //= -unitd1 unitrM unitd1 in Hb. by case/andP: Hb. Qed. (****) (*** Matrix *) Lemma dvdr_mulmxr m n p x (M : 'M[R]_(m,n)) (N : 'M[R]_(n,p)) : (forall i j, x %| M i j) -> forall i j, x %| (M *m N) i j. Proof. by move=> hM i j; rewrite !mxE; apply: big_dvdr=> k; rewrite dvdr_mulr ?hM. Qed. Lemma dvdr_mulmxl m n p x (M : 'M[R]_(m,n)) (N : 'M[R]_(p,m)) : (forall i j, x %| M i j) -> forall i j, x %| (N *m M) i j. Proof. by move=> hM i j; rewrite !mxE; apply: big_dvdr=> k; rewrite dvdr_mull ?hM. Qed. Lemma dvdr_usubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (usubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_dsubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (dsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_rsubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (rsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_lsubmx m0 n0 n1 x (M : 'M[R]_(m0,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (lsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_ulsubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (ulsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_ursubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (ursubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_dlsubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (dlsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. Lemma dvdr_drsubmx m0 m1 n0 n1 x (M : 'M[R]_(m0 + m1,n0 + n1)) : (forall i j, x %| M i j) -> forall i j, x %| (drsubmx M) i j. Proof. by move=> hM i j; rewrite !mxE. Qed. (* TODO: Prove other direction *) Lemma dvdr_col_mx m n p x (M : 'M[R]_(m,n)) (N : 'M[R]_(p,n)) : (forall i j, x %| M i j) /\ (forall i j, x %| N i j) -> forall i j, x %| (col_mx M N) i j. Proof. case=> h1 h2 i j; rewrite !mxE; case: splitP=> k {i}_. exact: (h1 k j). exact: (h2 k j). Qed. (* TODO: Prove other direction *) Lemma dvdr_row_mx m n p x (M : 'M[R]_(m,n)) (N : 'M[R]_(m,p)) : (forall i j, x %| M i j) /\ (forall i j, x %| N i j) -> forall i j, x %| (row_mx M N) i j. Proof. case=> h1 h2 i j; rewrite !mxE; case: splitP=> k {j}_. exact: (h1 i k). exact: (h2 i k). Qed. End DvdRingTheory. #[export] Hint Resolve dvdrr dvd1r eqdd : core. (* Notation "x *d y" := (mulqr x y) *) (* (at level 40, left associativity, format "x *d y"). *) (* Notation "x %|d y" := (dvdqr x y) *) (* (at level 40, left associativity, format "x %|d y"). *) HB.mixin Record DvdRing_hasGcd R of DvdRing R := { gcdr : R -> R -> R; gcdr_subdef : forall d a b, d %| gcdr a b = (d %| a) && (d %| b) }. HB.structure Definition GcdDomain := { R of DvdRing_hasGcd R & DvdRing R }. Bind Scope ring_scope with GcdDomain.sort. Notation gcdDomainType := GcdDomain.type. Notation "[ 'gcdDomainType' 'of' T 'for' cT ]" := (GcdDomain.clone T cT) (at level 0, format "[ 'gcdDomainType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'gcdDomainType' 'of' T ]" := (GcdDomain.clone T _) (at level 0, format "[ 'gcdDomainType' 'of' T ]") : form_scope. Definition lcmr R a b := nosimpl (if (a == 0) || (b == 0) then 0 else odflt 0 ((a * b) %/? (@gcdr R a b))). Definition gcdsr R := foldr (@gcdr R) 0. Definition lcmsr R := foldr (@lcmr R) 1. (* Definition gcdqr (R : gcdDomainType) (a b : {R %/ %=R}) : {R %/ %=R} := *) (* (\pi (gcdr (repr a) (repr b))). *) Section GCDDomainTheory. Variable R : gcdDomainType. Implicit Types a b : R. Lemma dvdr_gcd : forall d a b, d %| gcdr a b = (d %| a) && (d %| b) :> bool. Proof. exact: gcdr_subdef. Qed. Lemma dvdr_gcdl a b : gcdr a b %| a. Proof. by move: (dvdrr (gcdr a b)); rewrite dvdr_gcd; case/andP. Qed. Lemma dvdr_gcdr a b : gcdr a b %| b. Proof. by move: (dvdrr (gcdr a b)); rewrite dvdr_gcd; case/andP. Qed. Lemma gcdr_eq0 a b : (gcdr a b == 0) = (a == 0) && (b == 0). Proof. by rewrite -!dvd0r dvdr_gcd. Qed. Hint Resolve dvdr_gcdr dvdr_gcdl : core. Lemma gcdr_def : forall x a b, x %| a -> x %| b -> (forall x', x' %| a -> x' %| b -> (x' %| x)) -> gcdr a b %= x. Proof. by move=> x a b xa xb hx; rewrite eqd_def dvdr_gcd xa xb hx. Qed. Lemma gcdrC a b : gcdr a b %= gcdr b a. Proof. by rewrite /eqd ?dvdr_gcd ?dvdr_gcdr ?dvdr_gcdl. Qed. Hint Resolve gcdrC : core. Lemma eqd_gcd c d a b : a %= c -> b %= d -> gcdr a b %= gcdr c d. Proof. move=> ac bd; rewrite eqd_def !dvdr_gcd -(eqd_dvd (eqdd _) ac) dvdr_gcdl. rewrite -(eqd_dvd (eqdd _) bd) dvdr_gcdr (eqd_dvd (eqdd _) ac) dvdr_gcdl. by rewrite (eqd_dvd (eqdd _) bd) dvdr_gcdr. Qed. (* Lemma gcdq0r : forall x : DR, gcdqr (\pi 0) x = x. *) (* Proof. by elim/quotW=> x; rewrite gcdqr_pi (equivP (gcd0r _)). Qed. *) (* Local Notation DR := {R %/ %=R}. *) (* Lemma gcdqr_pi : forall a b, gcdqr (\pi a) (\pi b) = \pi (gcdr a b). *) (* Proof. *) (* move=> a b /=; rewrite /gcdqr. *) (* rewrite (equivP (@eqd_gcdr a _ _ _)) ?equivE ?reprK //. *) (* by rewrite (equivP (@eqd_gcdl b _ _ _)) ?equivE ?reprK. *) (* Qed. *) Lemma gcd0r a : gcdr 0 a %= a. Proof. by rewrite /eqd dvdr_gcd dvdr0 dvdrr !andbT. Qed. (* Lemma gcdq0r : forall x : DR, gcdqr (\pi 0) x = x. *) (* Proof. by elim/quotW=> x; rewrite gcdqr_pi (equivP (gcd0r _)). Qed. *) Lemma gcdr0 a : gcdr a 0 %= a. Proof. by rewrite /eqd dvdr_gcd dvdr0 dvdrr !andbT. Qed. (* Lemma gcdqr0 : forall x : DR, gcdqr x (\pi 0) = x. *) (* Proof. by elim/quotW=> x; rewrite gcdqr_pi (equivP (gcdr0 _)). Qed. *) Lemma gcd1r a : gcdr 1 a %= 1. Proof. by rewrite /eqd dvdr_gcd dvdrr dvd1r !andbT. Qed. (* Lemma gcdq1r : forall x : DR, gcdqr (\pi 1) x = \pi 1. *) (* Proof. by elim/quotW=> x; rewrite gcdqr_pi (equivP (gcd1r _)). Qed. *) Lemma gcdr1 a : gcdr a 1 %= 1. Proof. by rewrite /eqd dvdr_gcd dvdrr dvd1r !andbT. Qed. (* Lemma gcdqr1 : forall x : DR, gcdqr x (\pi 1) = \pi 1. *) (* Proof. by elim/quotW=> x; rewrite gcdqr_pi (equivP (gcdr1 _)). Qed. *) Lemma gcdrA a b c : gcdr a (gcdr b c) %= gcdr (gcdr a b) c. Proof. rewrite /eqd !dvdr_gcd !dvdr_gcdl !dvdr_gcdr. do 2!rewrite (dvdr_trans (dvdr_gcdr _ _)) //. by do 2!rewrite (dvdr_trans (dvdr_gcdl _ _)) //. Qed. (* Lemma gcdqrA : forall x y z : DR, gcdqr x (gcdqr y z) = gcdqr (gcdqr x y) z. *) (* Proof. *) (* elim/quotW=> x; elim/quotW=> y; elim/quotW=> z. *) (* by rewrite !gcdqr_pi (equivP (gcdrA _ _ _)) -!gcdqr_pi !reprK. *) (* Qed. *) (* Lemma gcdqrC : forall x y : DR, gcdqr x y = gcdqr y x. *) (* Proof. *) (* by elim/quotW=> x; elim/quotW=> y; rewrite /gcdqr (equivP (gcdrC _ _)). *) (* Qed. *) (* Lemma gcdqrCA : forall x y z : DR, gcdqr x (gcdqr y z) = gcdqr y (gcdqr x z). *) (* Proof. by move=> x y z; rewrite !gcdqrA [gcdqr x _]gcdqrC. Qed. *) Lemma gcdrCA a b c : gcdr a (gcdr b c) %= gcdr b (gcdr a c). Proof. rewrite (eqd_trans (gcdrA _ _ _)) // eqd_sym (eqd_trans (gcdrA _ _ _)) //. by rewrite (eqd_gcd (gcdrC _ _)) //. Qed. (* Proof. move=> a b c; apply/equivP; rewrite !(equivP (gcdrA _ _ _)); apply/equivP=> /=. by rewrite (eqd_gcd (gcdrC _ _) (eqdd _)). Qed. *) (* Lemma gcdqrAC : forall x y z : DR, gcdqr (gcdqr x y) z = gcdqr (gcdqr x z) y. *) (* Proof. by move=> x y z; rewrite -!gcdqrA [gcdqr y _]gcdqrC. Qed. *) Lemma gcdrAC a b c : gcdr (gcdr a b) c %= gcdr (gcdr a c) b. Proof. rewrite (eqd_trans _ (gcdrA _ _ _)) // eqd_sym (eqd_trans _ (gcdrA _ _ _)) //. by rewrite (eqd_gcd _ (gcdrC _ _)) //. Qed. (* Proof. move=> a b c; apply/equivP; rewrite -!(equivP (gcdrA _ _ _)); apply/equivP=> /=. by rewrite (eqd_gcd (eqdd _) (gcdrC _ _)). Qed. *) Lemma gcdr_mul2r a b c : gcdr (a * c) (b * c) %= gcdr a b * c. Proof. rewrite /eqd !dvdr_gcd !dvdr_mul // !andbT. case c0: (c == 0); first by rewrite (eqP c0) !mulr0 dvdr0. have Hc: c %| gcdr (a * c) (b * c) by rewrite dvdr_gcd !dvdr_mull //. case/dvdrP: Hc=> g Hg. rewrite Hg dvdr_mul // dvdr_gcd -![g %| _](@dvdr_mul2r _ c) ?c0 //. by rewrite -Hg dvdr_gcdl dvdr_gcdr. Qed. (* Lemma gcdqr_mul2r : forall x y z : DR, gcdqr (x *d z) (y *d z) = gcdqr x y *d z. *) (* Proof. *) (* elim/quotW=> x; elim/quotW=> y; elim/quotW=> z. *) (* by rewrite 2!mulqr_pi 2!gcdqr_pi mulqr_pi (equivP (gcdr_mul2r _ _ _)). *) (* Qed. *) Lemma gcdr_mul2l a b c : gcdr (c * a) (c * b) %= c * gcdr a b. Proof. by rewrite ![c * _]mulrC gcdr_mul2r. Qed. (* Lemma gcdqr_mul2l : forall x y z : DR, gcdqr (z *d x) (z *d y) = z *d gcdqr x y. *) (* Proof. *) (* elim/quotW=> x; elim/quotW=> y; elim/quotW=> z. *) (* by rewrite 2!mulqr_pi 2!gcdqr_pi mulqr_pi (equivP (gcdr_mul2l _ _ _)). *) (* Qed. *) Lemma mulr_gcdr a b c : a * gcdr b c %= gcdr (a * b) (a * c). Proof. by rewrite eqd_sym gcdr_mul2l. Qed. Lemma mulr_gcdl a b c : gcdr a b * c %= gcdr (a * c) (b * c). Proof. by rewrite eqd_sym gcdr_mul2r. Qed. (* Lemma mulqr_gcdr : forall x y z : DR, gcdqr x y *d z = gcdqr (x *d z) (y *d z). *) (* Proof. by move=> x y z; rewrite gcdqr_mul2r. Qed. *) (* Lemma mulqr_gcdl : forall x y z : DR, z *d gcdqr x y = gcdqr (z *d x) (z *d y). *) (* Proof. by move=> x y z; rewrite gcdqr_mul2l. Qed. *) (* *) (* Lemma gcdr_mul : forall a b c g, gcdr a b %= g -> gcdr (c * a) (c * b) %= c * g. *) (* Proof. *) (* move=> a b c g. *) (* rewrite /eqd !dvdr_gcd; case/and3P=> hg ha hb. *) (* rewrite !dvdr_mul2lW //. *) (* case Hc: (c == 0); first by move: (eqP Hc)-> => _; rewrite !mul0r gcdr0. *) (* case Hg: (g == 0). *) (* move: (eqP Hg)->. *) (* case/gcdrP=> a0 [b0] _; move: (dvd0r a0)->; move: (dvd0r b0)->. *) (* by rewrite mulr0 gcdr0. *) (* case/gcdrP=> ga [gb] H. *) (* have Hcg: c*g %| gcdr (c*a) (c*b) by rewrite dvdr_gcd ?dvdr_mul. *) (* case/dvdrP: Hcg=> x Hcgx. *) (* have Ha: g*x %| a. *) (* by rewrite (@dvdr_cancel (g*x) a c) //; first exact: (negbT Hc); *) (* rewrite mulrA -Hcgx dvdr_gcdl. *) (* have Hb: g*x %| b *) (* by rewrite (@dvdr_cancel (g*x) b c) //; first exact: (negbT Hc); *) (* rewrite mulrA -Hcgx dvdr_gcdr. *) (* exact: (eqd_mulUr (eq_eqd Hcgx) (dvdr_mulrU (negbT Hg) (H _ _ _))). *) (* Qed. *) (* *) Lemma gcdr_addr_r c a b : a %| b -> gcdr a (c + b) %= gcdr a c. Proof. move=> hab. rewrite /eqd !dvdr_gcd !dvdr_gcdl dvdr_add ?(dvdr_trans _ hab) //. by rewrite -{2}[c](@addrK _ b) dvdr_sub // (dvdr_trans _ hab). Qed. Lemma gcdr_addl_r c a b : a %| b -> gcdr a (b + c) %= gcdr a c. Proof. by move=> hab; rewrite addrC gcdr_addr_r. Qed. Lemma gcdr_addr_l a b c : b %| c -> gcdr (a + c) b %= gcdr a b. Proof. move=> Hbc. by rewrite (eqd_trans (gcdrC _ _)) ?(eqd_trans (gcdr_addr_r _ _)). Qed. Lemma gcdr_addl_l a b c : b %| c -> gcdr (c + a) b %= gcdr a b. Proof. move=> Hbc. by rewrite (eqd_trans (gcdrC _ _)) ?(eqd_trans (gcdr_addl_r _ _)). Qed. Lemma gcdr_addl_mul a b m : gcdr a (a * m + b) %= gcdr a b. Proof. by rewrite gcdr_addl_r // dvdr_mulr. Qed. (* lcm *) Lemma dvdr_gcd_mul a b : gcdr a b %| a * b. Proof. by rewrite dvdr_mull. Qed. Lemma mulr_lcm_gcd a b : lcmr a b * gcdr a b = a * b. Proof. rewrite /lcmr /=; move: (dvdr_gcd_mul a b). have [-> | a0] := eqVneq a 0; first by rewrite !mul0r. have [-> | b0] := eqVneq b 0; first by rewrite !(mulr0, mul0r). by rewrite /dvdr; case: odivrP => // x. Qed. Lemma lcmr0 a : lcmr a 0 = 0. Proof. by rewrite /lcmr /= eqxx orbT. Qed. Lemma lcm0r a : lcmr 0 a = 0. Proof. by rewrite /lcmr eqxx. Qed. Lemma dvdr_lcm a b c : (lcmr a b %| c) = (a %| c) && (b %| c) :> bool. Proof. have [-> | a0] := eqVneq a 0. rewrite lcm0r dvd0r. by case: eqP => //= ->; rewrite dvdr0. have [-> | b0] := eqVneq b 0. rewrite lcmr0 dvd0r andbC. by case: eqP => //= ->; rewrite dvdr0. rewrite -(@dvdr_mul2r _ (gcdr a b)); last by rewrite gcdr_eq0 negb_and a0. rewrite mulr_lcm_gcd (eqd_dvd (eqdd _) (mulr_gcdr _ _ _)) dvdr_gcd {1}mulrC. by rewrite !dvdr_mul2r // andbC. Qed. Lemma dvdr_lcml a b : a %| lcmr a b. Proof. by move: (dvdrr (lcmr a b)); rewrite dvdr_lcm; case/andP. Qed. Hint Resolve dvdr_lcml : core. Lemma dvdr_lcmr a b : b %| lcmr a b. Proof. by move: (dvdrr (lcmr a b)); rewrite dvdr_lcm; case/andP. Qed. Hint Resolve dvdr_lcmr : core. Lemma dvdr_gcdr_lcmr a b : gcdr a b %| lcmr a b. Proof. exact: (dvdr_trans (dvdr_gcdl a b) (dvdr_lcml a b)). Qed. Lemma lcm1r a : lcmr 1 a %= a. Proof. by rewrite /eqd dvdr_lcm dvdr_lcmr dvdrr dvd1r !andbT. Qed. Lemma lcmr1 a : lcmr a 1 %= a. Proof. by rewrite /eqd dvdr_lcm dvdr_lcml dvdrr dvd1r !andbT. Qed. Lemma lcmrC a b : lcmr a b %= lcmr b a. Proof. case/boolP: (gcdr b a == 0) => [|H0]. by rewrite gcdr_eq0; case/andP => /eqP-> _; rewrite lcmr0 lcm0r. rewrite -(@eqd_mul2r _ (gcdr b a)) //. by rewrite (eqd_trans (eqd_mul (eqdd _) (gcdrC b a))) // !mulr_lcm_gcd mulrC. Qed. Lemma lcmrA a b c : lcmr a (lcmr b c) %= lcmr (lcmr a b) c. Proof. rewrite /eqd !dvdr_lcm !dvdr_lcml !dvdr_lcmr. rewrite 2!(dvdr_trans _ (dvdr_lcml _ _)) //. by do 2!rewrite (dvdr_trans _ (dvdr_lcmr _ _)) //. Qed. Lemma eqd_lcmr a b c : a %= b -> lcmr a c %= lcmr b c. Proof. move=> Hab. rewrite /eqd !dvdr_lcm !dvdr_lcmr (eqd_dvd Hab (eqdd _)). by rewrite dvdr_lcml -(eqd_dvd Hab (eqdd _)) dvdr_lcml. Qed. Lemma eqd_lcml a b c : a %= b -> lcmr c a %= lcmr c b. Proof. move=> Hab. rewrite (eqd_trans (lcmrC _ _)) // (eqd_trans _ (lcmrC _ _)) //. by rewrite eqd_lcmr // eqd_sym. Qed. Lemma lcmrCA a b c : lcmr a (lcmr b c) %= lcmr b (lcmr a c). Proof. rewrite (eqd_trans (lcmrA _ _ _)) //. by rewrite (eqd_trans (eqd_lcmr _ (lcmrC _ _))) // eqd_sym lcmrA. Qed. Lemma lcmrAC a b c : lcmr (lcmr a b) c %= lcmr (lcmr a c) b. Proof. rewrite (eqd_trans _ (lcmrA _ _ _)) //. by rewrite (eqd_trans _ (eqd_lcml _ (lcmrC _ _))) // eqd_sym lcmrA. Qed. Lemma mulr_lcmr a b c : a * lcmr b c %= lcmr (a * b) (a * c). Proof. case/boolP: ((a * b == 0) && (a * c == 0)) => [/andP[] | H0]. rewrite mulf_eq0; case/orP => /eqP->. by rewrite !mul0r lcm0r. by rewrite mulr0 !lcm0r mulr0. rewrite -(@eqd_mul2r _ (gcdr (a * b) (a * c))) ?gcdr_eq0 // mulr_lcm_gcd. rewrite eqd_sym (eqd_trans _ (eqd_mul (eqdd _) (mulr_gcdr a b c))) //. by rewrite -!mulrA [lcmr b c * _]mulrCA mulr_lcm_gcd [b * _]mulrCA. Qed. Lemma mulr_lcml a b c : lcmr a b * c %= lcmr (a * c) (b * c). Proof. by rewrite ![_ * c]mulrC mulr_lcmr. Qed. Lemma lcmr_mul2r a b c : lcmr (a * c) (b * c) %= lcmr a b * c. Proof. by rewrite eqd_sym mulr_lcml. Qed. Lemma lcmr_mul2l a b c : lcmr (c * a) (c * b) %= c * lcmr a b. Proof. by rewrite ![c * _]mulrC lcmr_mul2r. Qed. Lemma lcmr_mull a b : lcmr a (a * b) %= a * b. Proof. have [-> | a0] := eqVneq a 0; first by rewrite mul0r /eqd !lcm0r dvdr0. rewrite -{1}[a]mulr1 (eqd_trans (lcmr_mul2l 1 b a)) // eqd_mul2l //. exact: (lcm1r b). Qed. Lemma lcmr_mulr a b : lcmr b (a * b) %= a * b. Proof. by rewrite mulrC lcmr_mull. Qed. Lemma dvdr_lcm_idr a b : a %| b -> lcmr a b %= b. Proof. by case/dvdrP=>x ->; rewrite lcmr_mulr. Qed. Lemma dvdr_lcm_idl a b : b %| a -> lcmr a b %= a. Proof. by case/dvdrP=> x ->; rewrite (eqd_trans (lcmrC _ _)) // lcmr_mulr. Qed. (** gcdsr and lcmsr *) Lemma gcdsr0 : (@gcdsr R) [::] = 0. Proof. by []. Qed. Lemma gcdsr_cons : forall a s, gcdsr (a :: s) = gcdr a (gcdsr s). Proof. by []. Qed. Lemma dvdr_gcds : forall (l : seq R) (g : R), g %| gcdsr l = all (%|%R g) l. Proof. by elim=> [|a l ihl] g; rewrite /= ?dvdr0 // dvdr_gcd ihl. Qed. Lemma dvdr_mem_gcds (l : seq R) x : x \in l -> gcdsr l %| x. Proof. by move=> hx; move: (dvdrr (gcdsr l)); rewrite dvdr_gcds; move/allP; apply. Qed. Lemma lcmsr0 : (@lcmsr R) [::] = 1. Proof. by []. Qed. Lemma lcmsr_cons : forall a s, lcmsr (a :: s) = lcmr a (lcmsr s). Proof. by []. Qed. Lemma dvdr_lcms : forall (l : seq R) (m : R), lcmsr l %| m = all (%|%R^~ m) l. Proof. by elim=> [|a l ihl] m; rewrite /= ?dvd1r // dvdr_lcm ihl. Qed. Lemma dvdr_mem_lcms (l : seq R) x : x \in l -> x %| lcmsr l. Proof. by move=> hx; move: (dvdrr (lcmsr l)); rewrite dvdr_lcms; move/allP; apply. Qed. (* Coprimality *) Definition coprimer a b := gcdr a b %= 1. Lemma coprimer_sym a b : coprimer a b = coprimer b a. Proof. by rewrite /coprimer; apply: congr_eqd. Qed. Lemma euclid_inv a b c : coprimer a b -> (a * b %| c) = (a %| c) && (b %| c). Proof. move=> cab. by rewrite -mulr_lcm_gcd (eqd_dvd (eqd_mul (eqdd _) cab) (eqdd _)) mulr1 dvdr_lcm. Qed. Lemma euclid b a c : coprimer a b -> (a %| c * b) = (a %| c) :> bool. Proof. move=> cab; symmetry. rewrite -{1}[c]mulr1 -(eqd_dvd (eqdd _) (eqd_mul (eqdd c) cab)). by rewrite (eqd_dvd (eqdd _) (mulr_gcdr _ _ _)) dvdr_gcd dvdr_mull. Qed. Lemma euclid_gcdr a b c : coprimer a b -> gcdr a (c * b) %= gcdr a c. Proof. move=> cab. rewrite eqd_def !dvdr_gcd !dvdr_gcdl /= andbC dvdr_mulr //= -(@euclid b) //. rewrite /coprimer (eqd_trans (gcdrAC _ _ _)) //. by rewrite (eqd_trans (eqd_gcd cab (eqdd _))) ?gcd1r. Qed. Lemma euclid_gcdl a b c : coprimer a b -> gcdr a (b * c) %= gcdr a c. Proof. by move=> cab; rewrite mulrC euclid_gcdr. Qed. Lemma coprimer_mulr a b c : coprimer a (b * c) = coprimer a b && coprimer a c. Proof. case/boolP: (coprimer a b) => co_pm /=. by rewrite /coprimer; apply: congr_eqd; rewrite // euclid_gcdl. apply: contraNF co_pm=> cabc. apply: gcdr_def; rewrite ?dvd1r // => x xa xb. by rewrite -(eqd_dvd (eqdd _) cabc) dvdr_gcd xa dvdr_mulr. Qed. Lemma coprimer_mull a b c : coprimer (b * c) a = coprimer b a && coprimer c a. Proof. by rewrite !(coprimer_sym _ a) coprimer_mulr. Qed. Lemma coprimer_dvdl a b c : a %| b -> coprimer b c -> coprimer a c. Proof. move=> dvd_ab cbc; apply: gcdr_def; rewrite ?dvd1r //= => d da dc. by rewrite -(eqd_dvdr _ cbc) dvdr_gcd (dvdr_trans da). Qed. Lemma coprimer_dvdr a b c : a %| b -> coprimer c b -> coprimer c a. Proof. move=> dvd_ab cbc; apply: gcdr_def; rewrite ?dvd1r //= => d dc da. by rewrite -(eqd_dvdr _ cbc) dvdr_gcd andbC (dvdr_trans da). Qed. Lemma coprimer_expl k a b : coprimer a b -> coprimer (a ^+ k) b. Proof. move=> cab; elim: k=> [|k ihk]; first by rewrite /coprimer gcd1r. by rewrite exprSr coprimer_mull ihk cab. Qed. Lemma coprimer_expr k a b : coprimer a b -> coprimer a (b ^+ k). Proof. move=> cab; elim: k=> [|k ihk]; first by rewrite /coprimer gcdr1. by rewrite exprSr coprimer_mulr ihk cab. Qed. Lemma coprimer_pexpl k a b : 0 < k -> coprimer (a ^+ k) b = coprimer a b. Proof. case: k => [|k] // _; apply/idP/idP; last by apply: coprimer_expl. by apply: coprimer_dvdl; rewrite exprS dvdr_mulr. Qed. Lemma coprimer_pexpr k a b : 0 < k -> coprimer a (b ^+ k) = coprimer a b. Proof. case: k => [|k] // _; apply/idP/idP; last by apply: coprimer_expr. by apply: coprimer_dvdr; rewrite exprS dvdr_mulr. Qed. Lemma dvdr_coprime a b : a %| b -> coprimer a b -> a %= 1. Proof. move=> ab cab; rewrite -(eqd_rtrans cab) eqd_def dvdr_gcdl andbT. by rewrite dvdr_gcd dvdrr. Qed. (** Irreducible and prime elements *) Definition primer a := ((a == 0 = false) * (a %= 1 = false) * (forall b c, a %| (b * c) = (a %| b) || (a %| c) :> bool)%R)%type. Definition irredr a := ((a == 0 = false) * (a %= 1 = false) * (forall b c, a %= b * c -> (b %= 1) || (c %= 1))%R)%type. Lemma irredrP : forall a, irredr a -> forall b c, a %= b * c -> b %= 1 \/ c %= 1. Proof. by move=> ? [ha ia] *; apply/orP; rewrite ia. Qed. Lemma irredr_dvd : forall a b, irredr a -> a %| b = ~~(coprimer a b) :> bool. Proof. rewrite /coprimer=> a b ia; case g1: (_ %= 1)=> /=. apply/negP=> hab; suff: a %= 1 by rewrite ia. by rewrite -dvdr1 (@dvdr_trans _ (gcdr a b)) ?dvdr_gcd ?dvdrr // dvdr1. case: (dvdrP _ _ (dvdr_gcdl a b))=> x hx; rewrite hx. move/eq_eqd: hx; case/irredrP => //; last by rewrite g1. move=> hx; rewrite (eqd_dvd (eqd_mul hx (eqdd _)) (eqdd _)). by rewrite mul1r dvdr_gcdr. Qed. Lemma irredr_coprimer : forall a b, irredr a -> coprimer a b = ~~(a %| b). Proof. by move=> a b ia; rewrite irredr_dvd // negbK. Qed. Lemma irredr_primer : forall a, irredr a <-> primer a. Proof. move=> a; split=> ia; rewrite /primer /irredr !ia; do ![split]=> b c. apply/idP/idP; last by case/orP=> ha; [rewrite dvdr_mulr|rewrite dvdr_mull]. rewrite [_ %| b]irredr_dvd //; case cab: (coprimer _ _)=> //=. by rewrite mulrC euclid. have [-> | b0] := eqVneq b 0; first by rewrite mul0r eqdr0 ia. have [-> | c0] := eqVneq c 0; first by rewrite mulr0 eqdr0 ia. rewrite eqd_def ia andb_orl. case/orP; case/andP; move/(dvdr_trans _)=> h; move/h. by rewrite dvdr_mull_l // => ->; rewrite orbT. by rewrite dvdr_mulr_l // => ->. Qed. (** bigop **) Lemma big_dvdr_gcdr (I : finType) (F : I -> R) : forall i, \big[(@gcdr R)/0]_i F i %| F i. Proof. move=> i; elim: (index_enum I) (mem_index_enum i)=> // a l IHl. rewrite in_cons big_cons =>/orP [/eqP ->|H]. by rewrite dvdr_gcdl. exact: (dvdr_trans (dvdr_gcdr _ _) (IHl H)). Qed. Lemma big_gcdrP (I : finType) (F : I -> R) d : (forall i, d %| F i) -> d %| \big[(@gcdr R)/0]_(i : I) F i. Proof. move=> Hd ; elim: (index_enum I)=> [|a l IHl]. by rewrite big_nil dvdr0. rewrite big_cons dvdr_gcd. by apply/andP; split; [apply: Hd | apply: IHl]. Qed. Lemma big_gcdr_def (I : finType) (F : I -> R) d : (exists k, F k %| d) -> \big[(@gcdr R)/0]_(i : I) F i %| d. Proof. by case=> k; apply: dvdr_trans; apply: big_dvdr_gcdr. Qed. (****) End GCDDomainTheory. Variant bezout_spec (R : gcdDomainType) (a b : R) : R * R -> Type:= BezoutSpec x y of gcdr a b %= x * a + y * b : bezout_spec a b (x, y). HB.mixin Record GcdDomain_hasPreBezout R of GcdDomain R := { bezout : R -> R -> (R * R); bezout_subdef : forall a b, bezout_spec a b (bezout a b) }. HB.structure Definition PreBezoutDomain := { R of GcdDomain_hasPreBezout R & GcdDomain R }. HB.structure Definition BezoutDomain := { R of PreBezoutDomain R & StronglyDiscrete R }. Bind Scope ring_scope with BezoutDomain.sort. Notation bezoutDomainType := BezoutDomain.type. Notation "[ 'bezoutDomainType' 'of' T 'for' cT ]" := (BezoutDomain.clone T cT) (at level 0, format "[ 'bezoutDomainType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'bezoutDomainType' 'of' T ]" := (BezoutDomain.clone T _) (at level 0, format "[ 'bezoutDomainType' 'of' T ]") : form_scope. Section BezoutDomainTheory. Variable R : PreBezoutDomain.type. Implicit Types a b : R. (* Lemma bezout_gcdPlr : forall a b, GCDDomain.gcdP a b (bezout a b).1. *) (* Proof. by case: R => [? [? []]]. Qed. *) Lemma bezoutP : forall a b, bezout_spec a b (bezout a b). Proof. exact: bezout_subdef. Qed. Definition egcdr a b := let: (u, v) := bezout a b in let g := u * a + v * b in if g == 0 then (0,1,0,1,0) else let a1 := odflt 0 (a %/? g) in let b1 := odflt 0 (b %/? g) in (g, u, v, a1, b1). Variant egcdr_spec a b : R * R * R * R * R -> Type := EgcdrSpec g u v a1 b1 of u * a1 + v * b1 = 1 & g %= gcdr a b & a = a1 * g & b = b1 * g : egcdr_spec a b (g, u, v, a1, b1). Lemma egcdrP a b : egcdr_spec a b (egcdr a b). Proof. rewrite /egcdr; case: bezoutP=> x y hg /=. move: (dvdr_gcdr a b) (dvdr_gcdl a b); rewrite !(eqd_dvd hg (eqdd _))=> ha hb. have [g_eq0 | g_neq0] := boolP (_ == 0). rewrite (eqP g_eq0) eqdr0 in hg. move: (hg); rewrite gcdr_eq0=> /andP[/eqP-> /eqP->]. constructor; do ?by rewrite mulr0. by rewrite mulr0 addr0 mulr1. by rewrite eqd_sym gcdr0. constructor. move: hb ha. rewrite /dvdr. case: odivrP=> //= a1 Ha _. case: odivrP=> //= b1 Hb _. - apply/(mulIf g_neq0). by rewrite mulrDl mul1r -!mulrA -Ha -Hb. - by rewrite eqd_sym. - by move: hb; rewrite /dvdr; case: odivrP. by move: ha; rewrite /dvdr; case: odivrP. Qed. (* Proof that any finitely generated ideal is principal *) (* This could use gcdsr if it would be expressed using bigops... *) Fixpoint principal_gen n : 'cV[R]_n -> R := if n is p.+1 then fun I : 'cV[R]_(1 + p) => let x := I 0 0 in let y := principal_gen (dsubmx I) in let: (g,_,_,_,_) := egcdr x y in g else fun => 0. (* Fixpoint principal_gen n (r : 'rV[R]_n) : R := \big[(fun x y => (egcdr x y).1.1.1.1) /0]_(i < n) (r 0 i). *) Lemma principal_gen_dvd : forall n (I : 'cV[R]_n) i, principal_gen I %| I i 0. Proof. elim => [I i| n ih]; first by rewrite flatmx0 /= !mxE dvdrr. rewrite [n.+1]/(1 + n)%nat => I i. rewrite -[I]vsubmxK !mxE. case: splitP => j hj /=. rewrite !ord1 !mxE /=. case: splitP => // j' _. rewrite ord1 mxE lshift0. case: egcdrP => g u v a b _. rewrite eqd_def; case/andP => h _ _ _. exact: (dvdr_trans h (dvdr_gcdl _ _)). case: egcdrP => g u v a b _. rewrite eqd_def col_mxKd; case/andP => h _ _ _. apply/(dvdr_trans (dvdr_trans h (dvdr_gcdr _ _))). by rewrite ih. Qed. Definition principal n (I : 'cV[R]_n) : 'M[R]_1 := (principal_gen I)%:M. (* (x) \subset (x1...xn) iff exists (v1...vn) such that (x1...xn)(v1...vn)^T = (x) *) Fixpoint principal_w1 n : 'cV[R]_n -> 'rV[R]_n := if n is p.+1 then fun (I : 'cV[R]_(1 + p)) => let g := principal_gen (dsubmx I) in let us := principal_w1 (dsubmx I) in let: (g',u,v,a1,b1) := egcdr (I 0 0) g in row_mx u%:M (v *: us) else fun => 0. Lemma principal_w1_correct : forall n (I : 'cV[R]_n), principal_w1 I *m I = principal I. Proof. elim => [I | n ih]; first by rewrite flatmx0 mulmx0 /principal rmorph0. rewrite [n.+1]/(1 + n)%nat => I. rewrite -[I]vsubmxK /principal /= col_mxKd {-2}vsubmxK. case: egcdrP => g u v a1 b1 hbezout _ h1 h2 /=. rewrite [row_mx u%:M _ *m _]mul_row_col -scalemxAl ih /principal h2. have -> : usubmx I = (I 0 0)%:M. apply/matrixP => i j. by rewrite !mxE !ord1 eqxx /= mulr1n lshift0. rewrite h1 !scalar_mxM -mul_scalar_mx !mulmxA -mulmxDl -!scalar_mxM -rmorphD. by rewrite hbezout mul1mx. Qed. (* (x1...xn) \subset (x) iff exists (w1...wn) such that (x)(w1...wn) = (x1...xn) *) Definition principal_w2 n (I : 'cV[R]_n) : 'cV[R]_n := let g := principal_gen I in map_mx (fun x => odflt 0 (x %/? g)) I. Lemma principal_w2_correct : forall n (I : 'cV[R]_n), principal_w2 I *m principal I = I. Proof. move=> n I. rewrite mul_mx_scalar. apply/matrixP => i j; rewrite !mxE !ord1 /= {j}. case: n I i => [|n] I i; first by rewrite !flatmx0 /= mul0r !mxE. case: odivrP => [x -> | H]; first by rewrite mulrC. case/dvdrP: (principal_gen_dvd I i)=> x Hx. move: (H x). by rewrite Hx eqxx. Qed. (* Bezout matrices *) Section Bezout_mx. (***************** if the following Bezout identity holds: u * a1 + v * b1 = 1, Bezout_mx a b n k represents the following matrix (dots are zeros): (kth column) / u .... v ..... \ | . 1 .......... | | ....1......... | | -b1 .. a1 .... | (kth row) | ..........1... | \ .............1 / (determinant is +/-1) ******************) Definition combine_mx (a b c d : R) (m : nat) (k : 'I_m) := let k' := lift 0 k in let d := \row_j (a *+ (j == 0) + d *+ (j == k') + ((j != 0) && (j != k'))%:R) in diag_mx d + c *: delta_mx k' 0 + b *: delta_mx 0 k'. Definition combine_step (a b c d : R) (m n : nat) (M : 'M_(1 + m,1 + n)) (k : 'I_m) := let k' := lift 0 k in let r0 := a *: row 0 M + b *: row k' M in let rk := c *: row 0 M + d *: row k' M in \matrix_i (r0 *+ (i == 0) + rk *+ (i == k') + row i M *+ ((i != 0) && (i != k'))). Definition Bezout_mx (a b : R) (m : nat) (k : 'I_m) := let:(_,u,v,a1,b1) := egcdr a b in combine_mx u v (-b1) a1 k. Definition Bezout_step (a b : R) (m n : nat) (M : 'M_(1 + m,1 + n)) (k : 'I_m) := let:(_,u,v,a1,b1) := egcdr a b in combine_step u v (-b1) a1 M k. Lemma combine_stepE (a b c d : R) (m n : nat) (M : 'M_(1 + m,1 + n)) (k : 'I_m) : combine_step a b c d M k = combine_mx a b c d k *m M. Proof. apply/matrixP=> i j; have [g u v a' b' _ _ _ _] := egcdrP a b. rewrite !mxE (bigD1 ord0) // !mxE (bigD1 (lift 0 k)) // !mxE /=. case H: (i == 0). rewrite big1=> [|l /andP [/negbTE H1 /negbTE H2]]. by rewrite (eqP H) !eqxx !mulr1n !mxE !mulr0 !addr0 mulr0n add0r mulr1. by rewrite !mxE (eqP H) (eq_sym 0 l) H1 H2 mulr0n !mulr0 !add0r mul0r. case H': (i == lift 0 k). rewrite big1=> [|l /andP [/negbTE H1 /negbTE H2]]. by rewrite (eqP H') !(eqxx,mulr1n,mxE,mulr0,addr0,mulr1,mulr0n,add0r). by rewrite !mxE (eqP H') !(eq_sym _ l) eqxx H1 H2 mulr0n !mulr0 !add0r mul0r. rewrite (bigD1 i); last by rewrite H H'. rewrite !mxE big1=> [/=|l /andP [/andP [/negbTE H1 /negbTE H2] /negbTE H3]]. by rewrite H H' eqxx !(mulr0n,mulr0,mulr1n,addr0,mul0r,add0r,mul1r). by rewrite !mxE H H' H1 H2 (eq_sym i l) H3 mulr0n !mulr0 !addr0 mul0r. Qed. Lemma combine_mx_inv (a b c d : R) m (k : 'I_m) : a * d - b * c = 1 -> combine_mx a b c d k *m combine_mx d (-b) (-c) a k = 1%:M. Proof. move=> H; rewrite -combine_stepE; apply/matrixP=> i j; rewrite !mxE. case Hi: (i == 0). rewrite !mxE (eqP Hi) !eqxx !mulr0 mxE !addr0 (eq_sym 0 j). case Hj: (j == 0); first by rewrite (eqP Hj) mulr1 !mulr0 addr0 sub0r mulrN. rewrite !mulr0 !add0r addr0 (eq_sym _ j). case: (j == lift 0 k); last by rewrite !mulr0 add0r. by rewrite mulr1 mulr1n mulrN mulrC addNr. case Hj: (j == 0). rewrite !mxE (eqP Hj) Hi add0r. case Hk: (i == _); last by rewrite !mxE Hi Hk eqxx !add0r !mulr0 addr0. by rewrite !mxE !eqxx !mulr0 mulr1 !addr0 !add0r mulrN addrC mulrC addNr. case Hk: (i == _); last by rewrite !mxE Hi Hj Hk !mulr0 !add0r !addr0. rewrite !mxE (eq_sym 0 j) Hj (eqP Hk) !(eqxx,mulr0,addr0,add0r) (eq_sym _ j). case: (j == lift 0 k); last by rewrite !mulr0 addr0. by rewrite !mulr1 addrC mulrN (mulrC c) (mulrC d). Qed. Lemma Bezout_stepE a b (m n : nat) (M : 'M_(1 + m,1 + n)) (k : 'I_m) : Bezout_step a b M k = Bezout_mx a b k *m M. Proof. rewrite /Bezout_step /Bezout_mx; have [g u v a' b' _ _ _ _] := egcdrP. by rewrite combine_stepE. Qed. Lemma Bezout_step_mx00 m n (M : 'M_(1 + m,1 + n)) {k : 'I_m} : (Bezout_step (M 0 0) (M (lift 0 k) 0) M k) 0 0 %= gcdr (M 0 0) (M (lift 0 k) 0). rewrite /Bezout_step; have [g u v a' b' Bezout_a'b' gcd_g H1 H2] := egcdrP. by rewrite !mxE !addr0 {1}H1 {1}H2 !mulrA -mulrDl Bezout_a'b' mul1r. Qed. Lemma sdvd_Bezout_step (m n : nat) (M : 'M_(1 + m,1 + n)) (k : 'I_m) : ~~ (M 0 0 %| M (lift 0 k) 0) -> (Bezout_step (M 0 0) (M (lift 0 k) 0) M k) 0 0 %<| M 0 0. Proof. move=> H; rewrite /sdvdr (eqd_dvd (Bezout_step_mx00 _) (eqdd _)) dvdr_gcdl /=. rewrite (eqd_dvd (eqdd _ ) (Bezout_step_mx00 _)); apply: contra H => H'. exact: (dvdr_trans H' (dvdr_gcdr _ _)). Qed. Lemma unit_Bezout_mx m a b (k : 'I_m) : Bezout_mx a b k \in unitmx. Proof. rewrite /Bezout_mx; case:egcdrP=> g a1 b1 u v Huv Hg Ha1 Hb1. have H: a1 * u - b1 * -v = 1; first by rewrite mulrN opprK. by case: (mulmx1_unit (combine_mx_inv k H)). Qed. End Bezout_mx. End BezoutDomainTheory. HB.factory Record GcdDomain_hasBezout R of GcdDomain R := { bezout : R -> R -> (R * R); bezout_subdef : forall a b, bezout_spec a b (bezout a b) }. HB.builders Context R of GcdDomain_hasBezout R. HB.instance Definition _ := GcdDomain_hasPreBezout.Build R bezout_subdef. Definition bmember n (x : R) (I : 'cV[R]_n) := match x %/? principal_gen I with | Some a => Some (a %:M *m principal_w1 I) | None => None end. Lemma bmember_correct : forall n (x : R) (I : 'cV[R]_n), member_spec x I (bmember x I). Proof. rewrite /bmember => n x I. case: odivrP => [a | ] Ha /=; constructor. by rewrite -mulmxA principal_w1_correct Ha scalar_mxM. move => J. rewrite -(principal_w2_correct I) /principal mulmxA scalar_mxC. move: (Ha ((J *m principal_w2 I) 0 0)). apply/contra. rewrite {1}[J *m principal_w2 I]mx11_scalar -scalar_mxM. move/eqP/matrixP => /(_ 0 0). rewrite !mxE /= !mulr1n => ->. by rewrite mulrC. Qed. HB.instance Definition _ := Ring_isStronglyDiscrete.Build R bmember_correct. HB.end. (* Section Mixins. *) (* Variable R : GRing.IntegralDomain.type. *) (* Variable bezout : R -> R -> (R * ((R * R)) * (R * R)). *) (* Hypothesis bezout_axiom1 : forall a b, GCDDomain.gcdP a b (bezout a b).1. *) (* Hypothesis bezout_axiom2 : forall a b, bezoutP a b (bezout a b). *) (* Definition gcd a b := (bezout a b).1. *) (* (* ((bezout a b).1,((bezout a b).2.1.1,(bezout a b).2.1.2)). *) *) (* Lemma bezoutGcdP : forall a b, GCDDomain.gcdP a b (gcd a b). *) (* Proof. exact: bezout_axiom1. Qed. *) (* Lemma bezoutGcdMax : forall a b g' x y, GCDDomain.gcdP a b (g',(x,y)) -> *) (* exists z, g' * z = (gcd a b).1. *) (* Proof. *) (* rewrite /GCDDomain.gcdP /gcd=> a b g' x' y' /= g'P. *) (* case hbez: (bezout _ _)=> [[g [x y]] [u v]] /=. *) (* exists (x' * u + y' * v). *) (* move: (bezout_axiom1 a b) (bezout_axiom2 a b). *) (* rewrite hbez /GCDDomain.gcdP /bezoutP /= -!g'P => hgxy. *) (* rewrite mulr_addr !mulrA -!hgxy -!mulrA -mulr_addr. *) (* by move->; rewrite mulr1. *) (* Qed. *) (* Definition GcdMixin := GcdDomainMixin bezoutGcdP bezoutGcdMax. *) (* End Mixins. *) HB.mixin Record DvdRing_isWellFounded R of DvdRing R := { sdvdr_wf : well_founded (@sdvdr [the dvdRingType of R]) }. HB.structure Definition PID := { R of DvdRing_isWellFounded R & BezoutDomain R }. Bind Scope ring_scope with PID.sort. Notation pidType := PID.type. Notation "[ 'pidType' 'of' T 'for' cT ]" := (PID.clone T cT) (at level 0, format "[ 'pidType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'pidType' 'of' T ]" := (PID.clone T _) (at level 0, format "[ 'pidType' 'of' T ]") : form_scope. Section PIDTheory. Variable R : pidType. Implicit Types a b : R. Definition sdvdr_rect := (well_founded_induction_type (@sdvdr_wf R)). Definition sdvdr_rec := (well_founded_induction (@sdvdr_wf R)). Definition sdvdr_ind := (well_founded_ind (@sdvdr_wf R)). End PIDTheory. Variant edivr_spec (R : ringType) (norm : R -> nat) (a b : R) : R * R -> Type := EdivrSpec q r of a = q * b + r & (b != 0) ==> (norm r < norm b) : edivr_spec norm a b (q,r). HB.mixin Record Ring_isEuclidean R of GRing.Ring R := { enorm : R -> nat; ediv : R -> R -> (R * R); norm_mul : forall a b, a != 0 -> enorm b <= enorm (a * b); (* _ : enorm 0 = 0%N; *) edivP : forall a b, edivr_spec enorm a b (ediv a b) }. HB.structure Definition EuclideanDomain := { R of Ring_isEuclidean R & PID R }. Bind Scope ring_scope with EuclideanDomain.sort. Notation euclidDomainType := EuclideanDomain.type. Notation "[ 'euclidDomainType' 'of' T 'for' cT ]" := (EuclideanDomain.clone T cT) (at level 0, format "[ 'euclidDomainType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'euclidDomainType' 'of' T ]" := (EuclideanDomain.clone T _) (at level 0, format "[ 'euclidDomainType' 'of' T ]") : form_scope. Module IDomain. Section IDomain. Variable R : idomainType. Implicit Type a b : R. Variable norm : (R : Type) -> nat. Variable ediv : (R : Type) -> (R : Type) -> ((R : Type) * (R : Type)). Hypothesis norm_mul : forall a b, a != 0 -> norm b <= norm (a * b). Hypothesis edivP : forall a b, edivr_spec norm a b (ediv a b). Definition div a b := if b == 0 then 0 else (ediv a b).1. Local Notation "a %/ b" := (div a b) : ring_scope. Local Notation "a %% b" := (ediv a b).2 : ring_scope. Lemma norm0_lt : forall a, a != 0 -> norm 0 < norm a. Proof. move=> a a0; case: (edivP a a)=> q r ha; rewrite a0 /= => hr. apply: leq_trans (hr); rewrite ltnS; apply: contraLR hr. move/eqP: ha; rewrite addrC -(can2_eq (@addrNK _ _) (@addrK _ _)). rewrite -{1}[a]mul1r -mulrBl eq_sym -leqNgt. have [-> | q1] := eqVneq (1 - q) 0; rewrite ?mul0r => /eqP->; rewrite ?leqnn //. by move=> _; rewrite norm_mul. Qed. End IDomain. End IDomain. Module Dvd. Section Dvd. Variable R : dvdRingType. Implicit Type a b : R. Variable norm : (R : Type) -> nat. Variable ediv : (R : Type) -> (R : Type) -> ((R : Type) * (R : Type)). Hypothesis norm_mul : forall a b, a != 0 -> norm b <= norm (a * b). Hypothesis edivP : forall a b, edivr_spec norm a b (ediv a b). Definition div a b := if b == 0 then 0 else (ediv a b).1. Local Notation "a %/ b" := (div a b) : ring_scope. Local Notation "a %% b" := (ediv a b).2 : ring_scope. Lemma norm0_lt : forall a, a != 0 -> norm 0 < norm a. Proof. exact: IDomain.norm0_lt norm_mul edivP. Qed. Lemma leq_norm : forall a b, b != 0 -> a %| b -> norm a <= norm b. Proof. move=> a b b0; move/dvdrP => [x hx]; rewrite hx norm_mul //. by apply: contra b0; rewrite hx; move/eqP->; rewrite mul0r. Qed. Lemma ltn_norm : forall a b, b != 0 -> a %<| b -> norm a < norm b. Proof. move=> a b b0; case/andP=> ab. case: (edivP a b)=> q r; rewrite b0 /= => ha nrb; rewrite {1}ha. have [-> | r0] := eqVneq r 0; first by rewrite addr0 dvdr_mull. rewrite dvdr_addr ?dvdr_mull // (leq_trans _ nrb) // ltnS leq_norm ?r0 //. by move: (dvdrr a); rewrite {2}ha dvdr_addr ?dvdr_mull. Qed. Lemma mod_eq0 a b : (a %% b == 0) = (b %| a). Proof. case: (edivP a b)=> q r -> /=. have [-> | /= b0] := eqVneq b 0; first by rewrite mulr0 dvd0r add0r. move=> nrb; apply/eqP/idP=> [->|]. by apply/dvdrP; exists q; rewrite addr0. rewrite dvdr_addr ?dvdr_mull //. have [-> // | r0] := eqVneq r 0. by move/leq_norm; rewrite leqNgt r0 nrb => /(_ isT). Qed. Lemma norm_eq0 a : norm a = 0%N -> a = 0. Proof. apply: contra_eq; rewrite -lt0n => a0. exact/leq_trans/(norm0_lt a0). Qed. Lemma mod_spec: forall a b, b != 0 -> norm (a %% b) < (norm b). Proof. by move=> a b b0; case: edivP=> q r; rewrite b0. Qed. Lemma modr0 a : a %% 0 = a. Proof. by case: edivP=> q r; rewrite mulr0 add0r=> ->. Qed. Lemma mod0r a : 0 %% a = 0. Proof. have [-> | a0] := eqVneq a 0; first by rewrite modr0. case: edivP=> q r; rewrite a0 /= => /eqP. rewrite eq_sym (can2_eq (@addKr _ _) (@addNKr _ _)) addr0 => /eqP->. rewrite -mulNr; apply: contraTeq; rewrite -leqNgt. by move/leq_norm; apply; exact: dvdr_mull. Qed. Lemma dvd_mod a b g : (g %| a) && (g %| b) = (g %| b) && (g %| a %% b). Proof. case: edivP=> q r /= -> _. by case gb: (g %| b); rewrite (andbT, andbF) // dvdr_addr ?dvdr_mull. Qed. End Dvd. End Dvd. HB.factory Record IntegralDomain_isEuclidean R of GRing.IntegralDomain R := { enorm : R -> nat; ediv : R -> R -> (R * R); norm_mul : forall a b, a != 0 -> enorm b <= enorm (a * b); edivP : forall a b, edivr_spec enorm a b (ediv a b) }. HB.builders Context R of IntegralDomain_isEuclidean R. Implicit Type a b : [the idomainType of R]. Local Notation norm := enorm. Definition div a b := if b == 0 then 0 else (ediv a b).1. Local Notation "a %/ b" := (div a b) : ring_scope. Local Notation "a %% b" := (ediv a b).2 : ring_scope. Lemma norm0_lt : forall a, a != 0 -> norm 0 < norm a. Proof. exact: IDomain.norm0_lt norm_mul edivP. Qed. Definition odiv a b := let (q, r) := ediv a b in if r == 0 then Some (if b == 0 then 0 else q) else None. Lemma odivP a b : div_spec a b (odiv a b). Proof. rewrite /odiv; case: edivP=> q r -> hr. case r0: (r == 0)=> //=; constructor. by rewrite (eqP r0) addr0; case: ifP=> //; move/eqP->; rewrite !mulr0. move=> x; case b0: (b == 0) hr=> /= hr. by rewrite (eqP b0) !mulr0 add0r r0. rewrite addrC (can2_eq (@addrK _ _) (@addrNK _ _)) -mulrBl. case xq : (x - q == 0); first by rewrite (eqP xq) mul0r r0. by apply: contraL hr; rewrite -leqNgt; move/eqP->; rewrite norm_mul ?xq. Qed. Lemma odiv_def a b : odiv a b = if a %% b == 0 then Some (a %/ b) else None. Proof. by rewrite /odiv /div; case: ediv. Qed. HB.instance Definition _ := Ring_hasDiv.Build R odivP. Lemma leq_norm : forall a b, b != 0 -> a %| b -> norm a <= norm b. Proof. exact: Dvd.leq_norm norm_mul. Qed. Lemma ltn_norm : forall a b, b != 0 -> a %<| b -> norm a < norm b. Proof. exact: Dvd.ltn_norm norm_mul edivP. Qed. Lemma sdvdr_wf : well_founded (@sdvdr [dvdRingType of R]). Proof. move=> a; wlog: a / a != 0=> [ha|]. case a0: (a == 0); last by apply: ha; rewrite a0. rewrite (eqP a0); constructor=> b; rewrite sdvdr0; apply: ha. elim: (norm a) {-2}a (leqnn (norm a))=> [|n ihn] {}a ha a0. by constructor=> x; move/(ltn_norm a0); rewrite ltnNge (leq_trans ha) ?leq0n. constructor=> x hx; move/(ltn_norm a0):(hx)=> hn; apply ihn. by rewrite -ltnS (leq_trans hn). by apply: contra a0; move/eqP=> x0; move/sdvdrW:hx; rewrite x0 dvd0r. Qed. HB.instance Definition _ := DvdRing_isWellFounded.Build R sdvdr_wf. Lemma mod_eq0 a b : (a %% b == 0) = (b %| a). Proof. exact: (Dvd.mod_eq0 norm_mul edivP). Qed. Lemma norm_eq0 a : norm a = 0%N -> a = 0. Proof. exact: (Dvd.norm_eq0 norm_mul edivP). Qed. Lemma mod_spec: forall a b, b != 0 -> norm (a %% b) < (norm b). Proof. exact: Dvd.mod_spec edivP. Qed. Lemma modr0 a : a %% 0 = a. Proof. exact: (Dvd.modr0 edivP). Qed. Lemma mod0r a : 0 %% a = 0. Proof. exact: (Dvd.mod0r norm_mul edivP). Qed. Lemma dvd_mod a b g : (g %| a) && (g %| b) = (g %| b) && (g %| a %% b). Proof. exact: (Dvd.dvd_mod edivP). Qed. (* Acc experiment: *) Lemma tool : forall (a b: R), (b != 0) ==> (norm (a %% b) < norm b). Proof. move => a b. apply/implyP => h. case: (edivP a b) => q r h1 /=. by move/implyP; apply. Qed. Definition acc_gcd (n:nat) (hn: Acc (fun x y => x < y) n) : forall (a b:R), n = norm b -> R. elim hn using acc_dep. clear n hn. move => n hn hi a b heq. move : (@tool a b). case :(b == 0). - move => _; exact a. set r := (a %% b). case : (r == 0). - move => _; exact b. move/implyP => h. apply: (hi (norm r) _ b r (refl_equal (norm r))). rewrite heq. by apply: h. Defined. Lemma acc_gcdP : forall (n:nat) (hn: Acc (fun x y => x < y) n) (a b: R) (hb: n = norm b) (g :R), g %| (acc_gcd hn a hb) = (g %| a) && (g %| b). Proof. move=> n hn; elim/acc_dep: hn => {}n {}hn hi a b heq g /=. move: (@tool a b). case b0 : (b == 0). - move => _. by rewrite (eqP b0) (dvdr0) andbT. case r0 : ( a %% b == 0). - move => _. by rewrite dvd_mod (eqP r0) dvdr0 andbT. move => h2. rewrite (hi (norm (a %% b)) _ b (a %% b) (refl_equal (norm (a %% b))) g). by rewrite -{1}dvd_mod. Qed. Definition GCD (a b:R) : R := acc_gcd (guarded 100 ssr_lt_wf (norm b)) a (refl_equal (norm b)). Lemma GCDP : forall d a b, d %| GCD a b = (d %| a) && (d %| b). Proof. by rewrite /GCD => d a b; apply: acc_gcdP. Qed. (* HB.instance Definition _ := DvdRing_hasGcd.Build R GCDP. *) Definition gcd a b := let: (a1, b1) := if norm a < norm b then (b, a) else (a, b) in if a1 == 0 then b1 else let fix loop (n : nat) (aa bb : R) {struct n} := let rr := aa %% bb in if rr == 0 then bb else if n is n1.+1 then loop n1 bb rr else rr in loop (norm a1) a1 b1. Lemma gcdP : forall d a b, d %| gcd a b = (d %| a) && (d %| b). Proof. move=> d a b; rewrite /gcd. wlog nba: a b / norm b <= norm a=>[hwlog|]. case: ltnP=> nab. by move/hwlog:(ltnW nab); rewrite ltnNge (ltnW nab) /= andbC. by move/hwlog:(nab); rewrite ltnNge nab. rewrite ltnNge nba /=. have [-> | a0] := eqVneq a 0; first by rewrite dvdr0. move: (norm a) {-1 3}a nba a0=> n {}a hn a0. elim: n {-2}n (leqnn n) a b hn a0 => [|k ihk] n hk a b hn a0. move: hk hn; rewrite leqn0; move/eqP->; rewrite leqn0. by move/eqP/norm_eq0->; rewrite modr0 (negbTE a0) dvdr0 andbT. move: hk hn; rewrite leq_eqVlt; case/orP; last first. by rewrite ltnS=> hnk nb; rewrite ihk. move/eqP->; rewrite dvd_mod. case: eqP => [->|_]; first by rewrite dvdr0 andbT. have [-> | b0] := eqVneq b 0. rewrite !modr0 dvdr0 /=. by case: k {ihk}=> [|k]; rewrite mod0r eqxx. by move=> nb; rewrite ihk // -ltnS (leq_trans (mod_spec _ _)). Qed. HB.instance Definition _ := DvdRing_hasGcd.Build R gcdP. Fixpoint egcd_rec (a b : R) n {struct n} : R * R := if n is n'.+1 then if b == 0 then (1, 0) else let: (u, v) := egcd_rec b (a %% b) n' in (v, (u - v * (a %/ b))) else (1, 0). Definition egcd p q := egcd_rec p q (norm q). Lemma gcdrE : forall a b, gcdr a b %= gcdr b (a %% b). Proof. move=> a b; rewrite /eqd dvdr_gcd dvdr_gcdr /=. case: edivP=> q r /= G _. move/eqP: (G); rewrite addrC -subr_eq; move/eqP=> H. rewrite -{1}H dvdr_sub ?dvdr_gcdl //; last by rewrite dvdr_mull ?dvdr_gcdr. by rewrite dvdr_gcd dvdr_gcdl G dvdr_add ?dvdr_gcdr // dvdr_mull ?dvdr_gcdl. Qed. Lemma egcd_recP : forall n a b, norm b <= n -> let e := (egcd_rec a b n) in gcdr a b %= e.1 * a + e.2 * b. Proof. elim=> [|n ihn] a b /=. by rewrite leqn0 => /eqP/norm_eq0->; rewrite mul1r mul0r addr0 gcdr0. move=> nbSn. case b0: (b == 0)=> /=; first by rewrite (eqP b0) mul1r mulr0 addr0 gcdr0. have := (ihn b (a %% b) _). case: (egcd_rec _ _)=> u v=> /= ihn' /=. rewrite (eqd_trans (gcdrE _ _)) ?(eqd_trans (ihn' _ _)) //; do ?by rewrite -ltnS (leq_trans (mod_spec _ _)) ?b0 //. rewrite mulrBl addrA [v * a + _]addrC -mulrA -addrA -mulrBr /div b0. case: edivP ihn'=> /= q r /eqP. rewrite [_ + r]addrC -subr_eq; move/eqP=>->. by rewrite b0 /= => nrb; apply; rewrite -ltnS (leq_trans nrb). Qed. Lemma egcdP : forall a b, bezout_spec a b (egcd a b). Proof. rewrite /egcd=> a b. case H: egcd_rec=> [x y]; constructor. by move: (@egcd_recP _ a b (leqnn _)); rewrite H. Qed. HB.instance Definition _ := GcdDomain_hasBezout.Build R egcdP. HB.instance Definition _ := Ring_isEuclidean.Build R norm_mul edivP. HB.end. Definition edivr (R : euclidDomainType) := @ediv R. Definition divr (R : euclidDomainType) (m d : R) := (edivr m d).1. Notation "m %/ d" := (divr m d) : ring_scope. Definition modr (R : euclidDomainType) (m d : R) := (edivr m d).2. Notation "m %% d" := (modr m d) : ring_scope. Notation "m = n %[mod d ]" := (m %% d = n %% d) : ring_scope. Notation "m == n %[mod d ]" := (m %% d == n %% d) : ring_scope. Notation "m <> n %[mod d ]" := (m %% d <> n %% d) : ring_scope. Notation "m != n %[mod d ]" := (m %% d != n %% d) : ring_scope. Section EuclideanDomainTheory. Variable R : euclidDomainType. Implicit Types a b : R. Lemma enorm_mul : forall a b, a != 0 -> enorm b <= enorm (a * b). Proof. exact: norm_mul. Qed. (* Lemma enorm0 : enorm (0 : R) = 0%N. Proof. by case: R=> [? [? []]]. Qed. *) Lemma edivrP : forall a b, edivr_spec (@enorm _) a b (edivr a b). Proof. exact: edivP. Qed. Lemma norm0_lt : forall a, a != 0 -> enorm (0 : R) < enorm a. Proof. exact: Dvd.norm0_lt norm_mul edivP. Qed. Lemma leq_enorm : forall a b, b != 0 -> a %| b -> enorm a <= enorm b. Proof. exact: Dvd.leq_norm norm_mul. Qed. Lemma ltn_enorm : forall a b, b != 0 -> a %<| b -> enorm a < enorm b. Proof. exact: Dvd.ltn_norm norm_mul edivP. Qed. Lemma modr_eq0 a b : (a %% b == 0) = (b %| a). Proof. exact: (Dvd.mod_eq0 norm_mul edivP). Qed. Lemma enorm_eq0 : forall a, enorm a = 0%N -> a = 0. Proof. exact: (Dvd.norm_eq0 norm_mul edivP). Qed. Lemma modr_spec: forall a b, b != 0 -> enorm (a %% b) < (enorm b). Proof. exact: Dvd.mod_spec edivP. Qed. Lemma modr0 : forall a, a %% 0 = a. Proof. exact: (Dvd.modr0 edivP). Qed. Lemma mod0r : forall a, 0 %% a = 0. Proof. exact: (Dvd.mod0r norm_mul edivP). Qed. Lemma dvdr_mod : forall a b d, (d %| a) && (d %| b) = (d %| b) && (d %| a %% b). Proof. exact: (Dvd.dvd_mod edivP). Qed. Lemma divr_mulKr a b : b != 0 -> (b * a) %/ b = a. Proof. move=> H. have: (b * a) %% b = 0. by apply/eqP; rewrite modr_eq0 dvdr_mulr // dvdrr. rewrite /divr /modr. case: edivrP=> c r He Hb /= Hr. rewrite Hr addr0 mulrC in He. by apply: (mulIf H). Qed. Lemma divr_mulKl a b : b != 0 -> (a * b) %/ b = a. Proof. by rewrite mulrC; apply: divr_mulKr. Qed. End EuclideanDomainTheory. coqeal-2.1.0/theory/edr.v000066400000000000000000000462621475512565300152600ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path tuple. From mathcomp Require Import perm fingroup choice ssralg fintype finfun poly polydiv. From mathcomp Require Import bigop matrix zmodp mxalgebra. Require Import ssrcomplements dvdring mxstructure similar minor binetcauchy. Require Import stronglydiscrete. Require Import coherent. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. (** Elementary divisor rings *) Variant smith_spec (R : dvdRingType) m n M : 'M[R]_m * seq R * 'M[R]_n -> Type := SmithSpec P d Q of P *m M *m Q = diag_mx_seq m n d & sorted %|%R d & P \in unitmx & Q \in unitmx : smith_spec M (P,d,Q). HB.mixin Record Bezout_Coherent_isEDR R of DvdRing R := { smith : forall m n, 'M[R]_(m,n) -> 'M[R]_m * seq R * 'M[R]_n; smithP : forall m n (M : 'M[R]_(m,n)), smith_spec M (smith _ _ M) }. HB.structure Definition EDR := { R of Bezout_Coherent_isEDR R & BezoutDomain R & CoherentRing R }. Bind Scope ring_scope with EDR.sort. Notation edrType := EDR.type. Notation "[ 'edrType' 'of' T 'for' cT ]" := (EDR.clone T cT) (at level 0, format "[ 'edrType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'edrType' 'of' T ]" := (EDR.clone T _) (at level 0, format "[ 'edrType' 'of' T ]") : form_scope. Arguments smith {_} [_ _]. Arguments smithP {_} [_ _]. HB.factory Record DvdRing_isEDR R of DvdRing R := { smith : forall m n, 'M[R]_(m,n) -> 'M[R]_m * seq R * 'M[R]_n; smithP : forall m n (M : 'M[R]_(m,n)), smith_spec M (smith _ _ M) }. HB.builders Context R of DvdRing_isEDR R. Definition smith_seq m n (M : 'M[R]_(m,n)) := (smith M).1.2. (* EDRs are gcd domains *) Definition gcd_edr a b : R := (smith_seq (row_mx a%:M b%:M : 'rV_2))`_0. Arguments nth : simpl never. Lemma gcd_edrP d a b : (d %| gcd_edr a b)%R = (d %| a)%R && (d %| b)%R. Proof. rewrite /gcd_edr /smith_seq; case: smithP => /= P ds Q heq _ Punitmx Qunitmx. apply/idP/andP => [gd0|[gdvda gdvdb]]. suff Hij : forall i j, d %| (row_mx a%:M b%:M : 'rV_2) i j. move: (Hij 0 (@lshift 1 1 0)) (Hij 0 (rshift 1 0)). by rewrite (row_mxEl a%:M) (row_mxEr a%:M) !mxE !mulr1n. move/(canRL (mulmxK Qunitmx))/(canRL (mulKmx Punitmx)): heq ->. apply/dvdr_mulmxl/dvdr_mulmxr=> i j. by rewrite ord1 {i} mxE; case: j => [[]] //= _ _; rewrite mulr0n dvdr0. move/matrixP: heq => /(_ 0 0). rewrite [P]mx11_scalar mul_scalar_mx !mxE big_ord_recl big_ord1 -rshift1 mulr1n. have -> : ord0 = 0 by []. rewrite -(lshift0 1 0) mxE (row_mxEl a%:M) 2!mxE (row_mxEr a%:M) => <-. by rewrite -!mulrA -mulrDr dvdr_mull // dvdr_add ?dvdr_mulr ?mxE. Qed. HB.instance Definition _ := DvdRing_hasGcd.Build R gcd_edrP. (** The existence of an algorithm computing Smith normal form implies the the ring is a Bézout domain *) Definition bezout_edr a b : R * R := let: (P,d,Q) := smith (row_mx a%:M b%:M : 'rV_2) in (P 0 0 * Q 0 0, P 0 0 * Q (rshift 1 0) 0). Lemma bezout_edrP a b : bezout_spec a b (bezout_edr a b). Proof. have := erefl (gcd_edr a b); rewrite {-1}/gcd_edr /smith_seq. rewrite /bezout_edr; case: smithP => /= P d Q heq hsorted Punitmx Qunitmx hg. constructor; rewrite /gcdr /= hg. move/matrixP: (heq) => /(_ 0 0). rewrite [P]mx11_scalar mul_scalar_mx !mxE big_ord_recl big_ord1 -rshift1 mulr1n. have -> : ord0 = 0 by []. rewrite -{1}(lshift0 1 0) mxE (row_mxEl a%:M) 2!mxE (row_mxEr a%:M) !mxE !mulr1n. by rewrite mulrAC [_ * b * _]mulrAC=> ->. Qed. HB.instance Definition _ := GcdDomain_hasBezout.Build R bezout_edrP. (* As we have a Smith normal form algorithm we can compute ker and coker *) Section snf_coherent. Section defs. Variable m n : nat. Variable M : 'M[R]_(m,n). Definition col_ebase := invmx (smith M).1.1. Definition row_ebase := invmx (smith M).2. (* Filter out all trailing zeroes *) Definition diag := [seq x <- take (minn m n) (smith_seq M) | x != 0 ]. Definition diag_mx := diag_mx_seq m n diag. (* Note: The matrix rank is NOT the module rank! *) Definition mxrank := size diag. Definition kermx : 'M_m := copid_mx mxrank *m invmx col_ebase. Definition cokermx : 'M_n := invmx row_ebase *m copid_mx mxrank. End defs. Lemma mulmx_ebase m n (M : 'M_(m, n)) : col_ebase M *m diag_mx M *m row_ebase M = M. Proof. rewrite /col_ebase /diag_mx /row_ebase /diag /smith_seq. case: smithP => /= L0 d R0 h1 h2 L0unit R0unit. rewrite diag_mx_seq_filter0 ?(sorted_take (@dvdr_trans [the dvdRingType of R])) // diag_mx_seq_take_min. by rewrite -h1 !mulmxA mulVmx // mul1mx -mulmxA mulmxV ?mulmx1. Qed. Lemma diag_neq0 m n (M : 'M[R]_(m,n)) i (his : i < size (diag M)) : (diag M)`_i != 0. Proof. exact: (all_nthP 0 (filter_all (fun x => x != 0) (take _ (smith M).1.2))). Qed. Lemma row_ebase_unit m n (M : 'M_(m, n)) : row_ebase M \in unitmx. Proof. by rewrite unitmx_inv; case: smithP. Qed. Lemma col_ebase_unit m n (M : 'M_(m, n)) : col_ebase M \in unitmx. Proof. by rewrite /col_ebase unitmx_inv; case: smithP. Qed. Lemma mulmx_diag_mx m n (M : 'M_(m, n)) : diag_mx M = invmx (col_ebase M) *m M *m invmx (row_ebase M). Proof. rewrite /col_ebase /diag_mx /row_ebase /diag /smith_seq !invmxK. case: smithP=> L0 d R0 h1 h2 _ _. rewrite diag_mx_seq_filter0. by rewrite diag_mx_seq_take_min. exact: (sorted_take (@dvdr_trans [the dvdRingType of R])). Qed. Lemma mul_kermx m n (M : 'M_(m, n)) : kermx M *m M = 0. Proof. rewrite -{2}[M]mulmx_ebase !mulmxA mulmxKV ?col_ebase_unit //. by rewrite mul_copid_mx_diag ?mul0mx // geq_min /mxrank leqnn orbT. Qed. Lemma diag0 m n : diag (0 : 'M[R]_(m,n)) = [::]. Proof. rewrite /diag /smith_seq; case: smithP=> /= P d Q. rewrite mulmx0 mul0mx => /esym h0 _ _ _. have H : all (eq_op^~ 0) (take (minn m n) d). apply: (@diag_mx_seq_eq0 _ m n); first by rewrite size_take; case: leqP. by rewrite diag_mx_seq_take_min. by elim: (take (minn m n) d) H => //= a l h /andP [->] /=. Qed. Lemma mxrank0 m n : mxrank (0 : 'M[R]_(m,n)) = 0%N. Proof. by rewrite /mxrank diag0. Qed. Lemma mxrank_leq_col_row : forall m n (M : 'M_(m, n)), mxrank M <= minn m n. Proof. case => [|m] [|n] //= M; rewrite ?(thinmx0,flatmx0,mxrank0,leq0n) //. rewrite /mxrank size_filter /smith_seq /=; case: smithP => /= P d Q _ _ _ _. by apply/(leq_trans (count_size _ _)); rewrite size_take; case: leqP. Qed. Lemma mxrank_leq_row m n (M : 'M_(m, n)) : mxrank M <= m. Proof. by move: (mxrank_leq_col_row M); rewrite leq_min; case/andP. Qed. Lemma mxrank_leq_col m n (M : 'M_(m, n)) : mxrank M <= n. Proof. by move: (mxrank_leq_col_row M); rewrite leq_min; case/andP. Qed. Lemma mulmx_coker m n (M : 'M_(m, n)) : M *m cokermx M = 0. Proof. rewrite -{1}[M]mulmx_ebase -!mulmxA mulKVmx ?row_ebase_unit //. by rewrite mul_diag_mx_copid ?mulmx0 // geq_min leqnn orbT. Qed. Lemma mulmxKV_kermx m n p (M : 'M_(n, p)) (N : 'M_(m, n)) : N *m M = 0 -> N *m col_ebase M *m kermx M = N. Proof. rewrite mulmxA mulmxBr mulmx1 mulmxBl mulmxK ?col_ebase_unit //. rewrite -{1}[M]mulmx_ebase !mulmxA. move/(canRL (mulmxK (row_ebase_unit M))); rewrite mul0mx // => BA0. apply: (canLR (addrK _)); rewrite -(pid_mx_id _ _ n (mxrank_leq_col M)) mulmxA. move/eqP: BA0; rewrite /diag_mx /mxrank. by move/(mul_diag_mx_seq_eq0 (@diag_neq0 _ _ M))/eqP ->; rewrite !mul0mx addr0. Qed. Lemma kermxP m n (M : 'M[R]_(m,n)) (X : 'rV_m) : reflect (exists Y : 'rV_m, X = Y *m kermx M) (X *m M == 0). Proof. apply: (iffP eqP)=> [|[Y ->]]; last by rewrite -mulmxA mul_kermx mulmx0. by move/mulmxKV_kermx=> hX; exists (X *m col_ebase M). Qed. End snf_coherent. HB.instance Definition _ := Ring_isCoherent.Build R kermxP. HB.instance Definition _ := Bezout_Coherent_isEDR.Build R smithP. HB.end. Section EDR_Theory. Variable R : edrType. Section snf_coherent. Section defs. Variable m n : nat. Variable M : 'M[R]_(m,n). Definition smith_seq := (smith M).1.2. Definition col_ebase := invmx (smith M).1.1. Definition row_ebase := invmx (smith M).2. (* Filter out all trailing zeroes *) Definition diag := [seq x <- take (minn m n) smith_seq | x != 0 ]. Definition diag_mx := diag_mx_seq m n diag. End defs. Lemma row_ebase_unit m n (M : 'M_(m, n)) : row_ebase M \in unitmx. Proof. by rewrite unitmx_inv; case: smithP. Qed. Lemma col_ebase_unit m n (M : 'M_(m, n)) : col_ebase M \in unitmx. Proof. by rewrite /col_ebase unitmx_inv; case: smithP. Qed. Lemma mulmx_diag_mx m n (M : 'M_(m, n)) : diag_mx M = invmx (col_ebase M) *m M *m invmx (row_ebase M). Proof. rewrite /col_ebase /diag_mx /row_ebase /diag /smith_seq !invmxK. case: smithP=> L0 d R0 h1 h2 _ _. rewrite diag_mx_seq_filter0. by rewrite diag_mx_seq_take_min. exact: (sorted_take (@dvdr_trans [dvdRingType of R])). Qed. End snf_coherent. (** Beginning of unicity *) Section Preunicity. Variables (s : seq R) (m n k : nat) (A : 'M[R]_(m,n)). Hypothesis (Hk : k <= minn m n) (Hs: sorted %|%R s). Hypothesis (HAs : equivalent A (diag_mx_seq m n s)). Let widen_minl i := widen_ord (geq_minl m n) i. Let widen_minr i := widen_ord (geq_minr m n) i. Lemma minor_diag_mx_seq : forall (f g : 'I_k -> 'I_(minn m n)), injective f -> injective g -> {subset codom f <= codom g} -> minor (widen_minl \o f) (widen_minr \o g) (diag_mx_seq m n s) %= \prod_i s`_(f i). Proof. elim: k=>[f g|j IHj f g Hf Hg Hfg]; first by rewrite /minor det_mx00 big_ord0. have: perm_eq [seq f x | x in 'I_j.+1] [seq g x | x in 'I_j.+1]. have [||_ e] := uniq_min_size _ Hfg; first by rewrite map_inj_uniq ?enum_uniq. by rewrite !size_map. by rewrite uniq_perm // map_inj_uniq // enum_uniq. have Ht : size (codom g) == j.+1 by rewrite size_codom card_ord. have -> : image g 'I_j.+1 = Tuple Ht by []. case/tuple_permP=> p Hp . have Hfg0 i : g (p i) = f i. have He : i < #|'I_j.+1| by rewrite card_ord. have {2}-> : i = enum_val (Ordinal He) by rewrite enum_val_ord; apply: ord_inj. rewrite -(nth_image (f ord0)) Hp -tnth_nth tnth_mktuple (tnth_nth (f ord0)). by rewrite /= codomE (nth_map ord0) ?nth_ord_enum // size_enum_ord. rewrite /minor (expand_det_row _ ((p^-1)%g ord0)) big_ord_recl big1=>[|i _]; last first. rewrite !mxE /= (inj_eq (@ord_inj _)) -Hfg0 (inj_eq Hg) permKV. by rewrite (negbTE (neq_lift _ _)) mul0r. rewrite /cofactor !mxE /=; set B := diag_mx_seq _ _ _; set M := row' _ _. set p0 := ((p^-1)%g ord0). pose f2 x := f (lift p0 x); pose g2 x := g (lift ord0 x). have Hf2 : injective f2 by apply/(inj_comp Hf)/lift_inj. have Hg2 : injective g2 by apply/(inj_comp Hg)/lift_inj. pose f' i := widen_ord (geq_minl m n) (f2 i). pose g' i := widen_ord (geq_minr m n) (g2 i). have -> : M = submatrix f' g' B by apply/matrixP=> r t; rewrite !mxE. have Hfg2 : {subset codom f2 <= codom g2}. move=> x /codomP [y ->]. rewrite codomE /f2 /g2 -Hfg0 map_comp (mem_map Hg). have: p (lift p0 y) \in enum 'I_j.+1 by rewrite mem_enum. rewrite enum_ordSl in_cons -(permKV p ord0). by rewrite (inj_eq (@perm_inj _ _)) eq_sym (negbTE (neq_lift _ _)). rewrite addr0 (bigD1 ((p^-1)%g ord0)) //= -Hfg0 permKV eqxx eqd_mull //. rewrite -[X in _ %= X]mul1r eqd_mul ?eqd1 ?unitrX ?unitrN ?unitr1 //. rewrite (eq_bigl (fun i => p0 != i)); last by move=> i /=; rewrite eq_sym. apply: (eqd_trans (IHj _ _ Hf2 Hg2 Hfg2)); apply: eq_eqd; rewrite /f2. case: (pickP 'I_j) => [k0 _ | n0]; last first. by rewrite !big1 // => [k' /unlift_some[i] | i _]; have:= n0 i. rewrite (reindex (lift p0)); first by apply: eq_bigl=> k'; rewrite neq_lift. exists (fun k => odflt k0 (unlift p0 k)) => k'; first by rewrite liftK. by case/unlift_some=> k'' -> ->. Qed. Lemma prod_minor_seq : \prod_(i < k) s`_i = minor [ffun x : 'I_k => widen_minl (widen_ord Hk x)] [ffun x : 'I_k => widen_minr (widen_ord Hk x)] (diag_mx_seq m n s). Proof. rewrite /minor /submatrix. elim: k Hk=>[H|j /= IHj Hj]; first by rewrite det_mx00 big_ord0. have IH : j <= (minn m n) by apply: ltnW. apply: esym; rewrite (expand_det_row _ ord_max) big_ord_recr /=. rewrite big1 ?add0r /cofactor=> [|i _]; last first. by rewrite !mxE !ffunE eqn_leq leqNgt (ltn_ord i) andFb mul0r. rewrite !mxE !ffunE eqxx exprD -expr2 sqrr_sign mul1r. rewrite /row' /col'; set M := matrix_of_fun _ _. rewrite big_ord_recr /= (IHj IH) mulr1n mulrC; do 2!f_equal. apply/matrixP=> i l; rewrite !mxE !ffunE /= /bump. by do 2!rewrite leqNgt (ltn_ord _) add0n. Qed. Lemma minor_eq0l (R' : comRingType) k1 m1 n1 (s1 : seq R') x : forall (f : 'I_k1 -> 'I_m1) g, n1 <= f x -> minor f g (diag_mx_seq m1 n1 s1) = 0. Proof. move=> f g H; rewrite /minor (expand_det_row _ x) big1 // => i _. by rewrite !mxE gtn_eqF ?mul0r // (leq_trans _ H). Qed. Lemma minor_eq0r (R' : comRingType) k1 m1 n1 (s1 : seq R') x : forall f (g : 'I_k1 -> 'I_n1) , m1 <= g x -> minor f g (diag_mx_seq m1 n1 s1) = 0. Proof. move=> f g H; rewrite /minor (expand_det_col _ x) big1 // => i _. by rewrite !mxE ltn_eqF ?mul0r // (leq_trans _ H). Qed. Lemma eqd_seq_gcdr : \prod_(i < k) s`_i %= \big[(@gcdr [the gcdDomainType of R : Type])/0]_(f : {ffun 'I_k -> 'I_m}) (\big[(@gcdr [the gcdDomainType of R : Type])/0]_(g : {ffun 'I_k -> 'I_n}) minor f g (diag_mx_seq m n s)). Proof. apply/andP; split; last first. rewrite prod_minor_seq; set j := [ffun _ => _]. by apply/(dvdr_trans (big_dvdr_gcdr _ j))/big_dvdr_gcdr. apply: big_gcdrP=> f; apply: big_gcdrP=> g. case: (injectiveb f) /injectiveP=> Hinjf; last first. by rewrite (minor_f_not_injective _ _ Hinjf) dvdr0. case: (injectiveb g) /injectiveP=> Hinjg; last first. by rewrite (minor_g_not_injective _ _ Hinjg) dvdr0. have Hmin k1 i m1 n1 (h : 'I_k1 -> 'I_m1) : minn m1 n1 <= h i -> n1 <= h i. move=> Hhi; have := (leq_ltn_trans Hhi (ltn_ord (h i))). by rewrite gtn_min ltnn=> /ltnW/minn_idPr <-. case/altP: (@forallP _ (fun i => f i < minn m n)) => [Hwf|]; last first. rewrite negb_forall=> /existsP [x]; rewrite -leqNgt=> /Hmin Hx. by rewrite (minor_eq0l _ _ Hx) dvdr0. case/altP: (@forallP _ (fun i => g i < minn m n)) => [Hwg|]; last first. rewrite negb_forall=> /existsP [x]; rewrite -leqNgt minnC=> /Hmin Hx. by rewrite (minor_eq0r _ _ Hx) dvdr0. pose f1 i := Ordinal (Hwf i). pose g1 i := Ordinal (Hwg i). have Hinjf1 : injective f1. by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjf. have Hinjg1 : injective g1. by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjg. case Hcfg: (codom f1 \subset codom g1); last first. move/negbT: Hcfg=> /subsetPn [x] /codomP [y Hy] /negP Habs. rewrite /minor (expand_det_row _ y). rewrite [\sum_(_ <_) _](big1 _ xpredT) ?dvdr0 //. move=> j _; rewrite !mxE. have ->: (g j = g1 j :> nat) by []. have ->: (f y = f1 y :> nat) by []. have ->: (f1 y == g1 j :> nat) = false. by apply/negbTE/eqP=> /ord_inj=> H; apply: Habs; rewrite Hy H codom_f. by rewrite mul0r. move/subsetP: Hcfg=> Hcfg. pose f' i := widen_minl (f1 i). pose g' i := widen_minr (g1 i). have ->: minor f g (diag_mx_seq m n s) = minor f' g' (diag_mx_seq m n s). by apply: minor_eq=> i; apply: ord_inj. rewrite (eqd_dvdr _ (minor_diag_mx_seq Hinjf1 Hinjg1 Hcfg)) //. move: Hinjf1; clear -Hs; move: f1; clear -Hs. elim: k =>[?|j /= IHj g Hg]. by rewrite big_ord0 dvd1r. rewrite big_ord_recr /=. pose max:= \max_i (g i). have [l Hl]: {j | max = g j} by apply: eq_bigmax; rewrite card_ord. pose p := tperm l ord_max. set B := \prod_(_ < _) _. rewrite (reindex_inj (@perm_inj _ p)) /= big_ord_recr /= dvdr_mul //. pose f := (g \o p \o (widen_ord (leqnSn j))). have Hf: injective f. apply: inj_comp=> [|x y /eqP]. by apply: inj_comp=> //; exact: perm_inj. by rewrite -(inj_eq (@ord_inj _)) /= => H; apply/ord_inj/eqP. have Hi: injective (finfun f). by move=> x e; rewrite !ffunE; exact: Hf. set C := \prod_(_ < _) _. have:= (IHj _ Hi). have ->: C = \prod_i s`_(finfun f i). by apply: eq_bigr=> i _; rewrite ffunE. by apply. move: (sorted_nth0 (sorted_drop j Hs) (g (p ord_max) - j)). rewrite !nth_drop addn0 subnKC //= tpermR; case/orP: (leq_total j (g l))=> //. rewrite leq_eqVlt => /orP [|Hgm]; first by move/eqP=> ->; rewrite leqnn. have Habs: forall i, g i < j. move=> i; apply: (leq_ltn_trans _ Hgm). by rewrite -Hl /k; exact: (leq_bigmax i). pose f := fun x => Ordinal (Habs x). have Hf: injective f. move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP Hxy. by apply/Hg/ord_inj. have: #|'I_j.+1| <= #|'I_j|. by rewrite -(card_codom Hf); exact: max_card. by rewrite !card_ord ltnn. Qed. Lemma Smith_gcdr_spec : \prod_(i < k) s`_i %= \big[(@gcdr [the gcdDomainType of R : Type])/0]_(f : {ffun 'I_k -> 'I_m}) (\big[(@gcdr [the gcdDomainType of R : Type])/0]_(g : {ffun 'I_k -> 'I_n}) minor f g A). Proof. rewrite (eqd_ltrans eqd_seq_gcdr). have [ _ _ [M [N [_ _ Heqs]]]] := HAs. have [ _ _ [P [Q [_ _ Hseq]]]] := equiv_sym HAs. rewrite conform_mx_id in Heqs. rewrite conform_mx_id in Hseq. have HdivmA p q k1 (B C : 'M[R]_(p,q)) (M1 : 'M_p) (N1 : 'M_q) : forall (H : M1 *m C *m N1 = B), forall (f : 'I_k1 -> 'I_p) (g : 'I_k1 -> 'I_q), \big[(@gcdr [the gcdDomainType of R : Type])/0]_(f0 : {ffun 'I_k1 -> 'I_p}) \big[(@gcdr [the gcdDomainType of R : Type])/0]_(g0 : {ffun 'I_k1 -> 'I_q}) minor f0 g0 C %| minor f g B. move=> H f g. have HBC: minor f g B = \sum_(f0 : {ffun 'I__ -> 'I__ } | strictf f0) ((\sum_(g0 : {ffun 'I__ -> 'I__ } | strictf g0) (minor id g0 (submatrix f id M1) * minor g0 f0 C)) * minor f0 id (submatrix id g N1)). rewrite -H /minor submatrix_mul BinetCauchy. apply: eq_bigr=> i _; congr GRing.mul; rewrite /minor. rewrite sub_submatrix submatrix_mul BinetCauchy. by apply: eq_bigr=> j _; rewrite /minor !sub_submatrix. rewrite HBC; apply: big_dvdr=> h; rewrite dvdr_mulr //. apply: big_dvdr=> j; rewrite dvdr_mull //. by apply: (dvdr_trans (big_dvdr_gcdr _ j)); apply: big_dvdr_gcdr. apply/andP; split; apply: big_gcdrP=> f; apply: big_gcdrP=> g. exact: (HdivmA _ _ _ _ _ _ _ Hseq). exact: (HdivmA _ _ _ _ _ _ _ Heqs). Qed. End Preunicity. Section Unicity. Lemma Smith_unicity m n (M : 'M[R]_(m,n)) (d : seq R) : sorted %|%R d -> equivalent M (diag_mx_seq m n d) -> forall i, i < minn m n -> d`_i %= (smith_seq M)`_i. Proof. rewrite /smith_seq=> Hd HMd i. case: smithP=> P s Q heq Hsorted Punitmx Qunitmx /=. have HMdmt : equivalent M (diag_mx_seq m n s). by split=> //; exists P; exists Q; split=> //; rewrite conform_mx_id. elim: i {-2}i (leqnn i)=>[i|i IHi j Hji Hj]. rewrite leqn0=> /eqP -> Hi. move: (Smith_gcdr_spec Hi Hd HMd); rewrite eqd_sym. move/(eqd_trans (Smith_gcdr_spec Hi Hsorted HMdmt)). by rewrite !big_ord1 eqd_sym. move: (Smith_gcdr_spec Hj Hd HMd); rewrite eqd_sym. move/(eqd_trans (Smith_gcdr_spec Hj Hsorted HMdmt)). rewrite !big_ord_recr /= => H3. have H1: \prod_(i < j) d`_i %= \prod_(i < j) s`_i. apply: eqd_big_mul=> k _. by rewrite (IHi k _ (ltn_trans _ Hj)) // -ltnS (leq_trans (ltn_ord k) Hji). have [H0|H0] := boolP (\prod_(i < j) d`_i == 0). have/prodf_eq0 [k _ /eqP Hk] : (\prod_(i < j) s`_i == 0). by rewrite (eqP H0) eqd0r in H1. case/prodf_eq0: H0 => l _ /eqP Hl. move: (sorted_nth0 (sorted_drop k Hsorted) (j - k)). move: (sorted_nth0 (sorted_drop l Hd) (j - l)). rewrite !nth_drop !addn0 Hk Hl !dvd0r (subnKC (ltnW (ltn_ord k))). by rewrite (subnKC (ltnW (ltn_ord l)))=> /eqP -> /eqP ->. by rewrite -(eqd_mul2l _ _ H0) (eqd_rtrans (eqd_mulr _ H1)) eqd_sym. Qed. End Unicity. End EDR_Theory. coqeal-2.1.0/theory/fpmod.v000066400000000000000000000730061475512565300156070ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm choice matrix bigop zmodp mxalgebra poly. Require Import ssrcomplements stronglydiscrete coherent edr. Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. Local Open Scope ring_scope. Local Open Scope mxpresentation_scope. Reserved Notation "{ 'fpmod' T }" (at level 0, format "{ 'fpmod' T }"). Reserved Notation "''Mor' ( M , N )" (at level 8, format "''Mor' ( M , N )"). Reserved Notation "''Mono' ( M , N )" (at level 8, format "''Mono' ( M , N )"). Reserved Notation "''Epi' ( M , N )" (at level 8, format "''Epi' ( M , N )"). Reserved Notation "''Iso' ( M , N )" (at level 8, format "''Iso' ( M , N )"). Reserved Notation "''End' ( M )" (at level 8, format "''End' ( M )"). Reserved Notation "''Aut' ( M )" (at level 8, format "''Aut' ( M )"). Reserved Notation "M %= N" (at level 70, no associativity). Reserved Notation "A ** B" (at level 40, left associativity, format "A ** B"). Reserved Notation "x ^^-1" (at level 3, left associativity, format "x ^^-1"). Section morphismDef. Variable R : coherentRingType. (** Module *) Record fpmod := FPmod { nbrel : nat; nbgen : nat; pres : 'M[R]_(nbrel, nbgen) }. Definition fpmod_of of phant R := fpmod. (* Identity Coercion type_fpmod_of : fpmod_of >-> fpmod. *) (* Is this necessary? *) (* We want morphism_of_rect so temporarily add this: *) Set Nonrecursive Elimination Schemes. (** Morphisms *) Record morphism_of (M N : fpmod) := Morphism { matrix_of_morphism : 'M[R]_(nbgen M,nbgen N); _ : (pres N %| pres M *m matrix_of_morphism)%MP }. Unset Nonrecursive Elimination Schemes. End morphismDef. Notation "{ 'fpmod' T }" := (fpmod_of (Phant T)). Coercion matrix_of_morphism : morphism_of >-> matrix. Notation "M %:m" := (M : 'M__) (at level 2, format "M %:m"). Notation "''Mor' ( M , N )" := (morphism_of M N) : type_scope. Notation "M %:mor" := (M : 'Mor(_,_)) (at level 2, format "M %:mor"). Notation "''End' ( M )" := (morphism_of M M) : type_scope. Definition source (R : coherentRingType) (M N : {fpmod R}) (phi : 'Mor(M, N)) := M. Definition target (R : coherentRingType) (M N : {fpmod R}) (phi : 'Mor(M, N)) := N. Section morphismTheory. Variable R : coherentRingType. Local Open Scope mxpresentation_scope. Section equality. Variables (M N : {fpmod R}). Definition eqmor (phi psi : 'Mor(M,N)) := pres N %| phi%:m - psi%:m. Lemma eqmor_refl : reflexive eqmor. Proof. by move=> phi; rewrite /eqmor subrr. Qed. Hint Resolve eqmor_refl : core. Lemma eqmorxx x : eqmor x x. Proof. exact. Qed. Lemma eqmor_sym : symmetric eqmor. Proof. by move=> phi1 phi2; rewrite /eqmor -dvdmxN opprB. Qed. Hint Resolve eqmor_sym : core. Lemma eqmor_trans : transitive eqmor. Proof. rewrite /eqmor => phi2 phi1 phi3 phi12 phi23. by rewrite -[phi1%:m](addrNK phi2%:m) -[X in _ %| X]addrA dvdmxD. Qed. Hint Resolve eqmor_trans : core. Lemma eqmor_ltrans : left_transitive eqmor. Proof. exact: sym_left_transitive. Qed. Lemma eqmor_rtrans : right_transitive eqmor. Proof. exact: sym_right_transitive. Qed. End equality. Section general. Variables (M N K : {fpmod R}). (* reexporting dvdmx_morphism *) Lemma dvdmx_morphism (phi : 'Mor(M, N)) : (pres N %| pres M *m phi). Proof. by case: phi. Qed. (* Constructor for 1 morphism *) Lemma morphism1_subproof x (X : 'M_(x, _)) : X %| pres N -> X %| pres N *m 1%:M. Proof. by rewrite mulmx1. Qed. Definition Morphism1 x (X : 'M_(x, nbgen N)) (dvdXN : X %| pres N) : 'Mor(N, FPmod X) := @Morphism _ _ (FPmod X) _ (@morphism1_subproof x X dvdXN). Variables (n : nat) (X : 'M[R]_(n, nbgen M)). Definition source_of_mx := FPmod ((pres M).-ker X). Lemma mor_of_mx_proof : pres M %| pres source_of_mx *m X. Proof. by rewrite -dvd_ker. Qed. Definition mor_of_mx := Morphism mor_of_mx_proof. End general. Section zmodType. Variables (M N : {fpmod R}). HB.instance Definition _ := [isSub for (@matrix_of_morphism _ _ _) by (@morphism_of_rect _ M N)]. HB.instance Definition _ := [Choice of 'Mor(M, N) by <:]. Implicit Types (phi : 'Mor(M, N)). (** Zero *) (* The zero morphism between two object *) Fact zeromor_proof : pres N %| pres M *m 0. Proof. by rewrite mulmx0 dvdmx0. Qed. Definition zeromor : 'Mor(M,N) := Morphism zeromor_proof. (** Addition *) Fact addmor_proof phi1 phi2 : pres N %| pres M *m (phi1%:m + phi2%:m). Proof. by rewrite mulmxDr dvdmxD // dvdmx_morphism. Qed. Definition addmor phi1 phi2 : 'Mor(M, N) := Morphism (addmor_proof phi1 phi2). (** Subtraction *) Fact oppmor_proof phi : pres N %| pres M *m (- phi%:m). Proof. by rewrite mulmxN dvdmxN dvdmx_morphism. Qed. Definition oppmor phi : 'Mor(M, N) := Morphism (oppmor_proof phi). Fact addmA_subproof : associative addmor. Proof. by move=> x y z; apply: val_inj; apply: addrA. Qed. Fact addmC_subproof : commutative addmor. Proof. by move=> x y; apply: val_inj; apply: addrC. Qed. Fact add0m_subproof : left_id zeromor addmor. Proof. by move=> x; apply: val_inj; apply: add0r. Qed. Fact addNm_subproof : left_inverse zeromor oppmor addmor. Proof. by move=> x; apply: val_inj; apply: addNr. Qed. HB.instance Definition _ := GRing.isZmodule.Build 'Mor(M, N) addmA_subproof addmC_subproof add0m_subproof addNm_subproof. End zmodType. Section category. Section defs. Variables (M N K : {fpmod R}). (** Identity endomorphism *) Definition idm : 'End(M) := Morphism (morphism1_subproof (dvdmx_refl _)). Implicit Types (phi : 'Mor(M, N)) (psi : 'Mor(N, K)). (** Composition *) Fact mulmor_proof phi psi : pres K %| pres M *m (phi *m psi). Proof. rewrite mulmxA (dvdmx_trans (dvdmx_morphism psi)) //. by rewrite dvdmxMr // dvdmx_morphism. Qed. Definition mulmor phi psi : 'Mor(M, K) := Morphism (mulmor_proof phi psi). End defs. Arguments idm {_}. Infix "**" := mulmor : mxpresentation_scope. Infix "%=" := eqmor : mxpresentation_scope. Section theory. Variables (M N P Q : {fpmod R}). Lemma mul1mor (phi : 'Mor(M,P)) : idm ** phi = phi. Proof. by apply: val_inj; rewrite /= mul1mx. Qed. Lemma mulmor1 (phi : 'Mor(M,P)) : phi ** idm = phi. Proof. by apply: val_inj; rewrite /= mulmx1. Qed. Lemma mul0mor (phi : 'Mor(M,P)) : 0 ** phi = 0 :> 'Mor(N,P). Proof. by apply: val_inj; rewrite /= mul0mx. Qed. Lemma mulmor0 (phi : 'Mor(M,P)) : phi ** 0 = 0 :> 'Mor(M, Q). Proof. by apply: val_inj; rewrite /= mulmx0. Qed. Lemma mulmorA (psi : 'Mor(M,N)) (phi : 'Mor(N,P)) (kapa : 'Mor(P,Q)) : psi ** (phi ** kapa) = (psi ** phi) ** kapa. Proof. by apply: val_inj; rewrite /= mulmxA. Qed. Lemma mulmorDl (phi1 phi2 : 'Mor(M, N)) (psi : 'Mor(N, P)) : (phi1 + phi2) ** psi = phi1 ** psi + phi2 ** psi. Proof. by apply: val_inj => /=; rewrite mulmxDl. Qed. Lemma mulmorDr (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) : psi ** (phi1 + phi2)= psi ** phi1 + psi ** phi2. Proof. by apply: val_inj => /=; rewrite mulmxDr. Qed. Lemma mulmorN (phi : 'Mor(M, N)) (psi : 'Mor(N, P)) : phi ** (- psi) = - (phi ** psi). Proof. by apply: val_inj => /=; rewrite mulmxN. Qed. Lemma mulNmor (phi : 'Mor(M, N)) (psi : 'Mor(N, P)) : (- phi) ** psi = - (phi ** psi). Proof. by apply: val_inj => /=; rewrite mulNmx. Qed. Lemma mulmorBl (phi1 phi2 : 'Mor(M, N)) (psi : 'Mor(N, P)) : (phi1 - phi2) ** psi = phi1 ** psi - phi2 ** psi. Proof. by rewrite mulmorDl mulNmor. Qed. Lemma mulmorBr (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) : psi ** (phi1 - phi2) = psi ** phi1 - psi ** phi2. Proof. by rewrite mulmorDr mulmorN. Qed. Lemma eqmorMl (psi : 'Mor(M, N)) (phi1 phi2 : 'Mor(N, P)) : phi1 %= phi2 -> psi ** phi1 %= psi ** phi2. Proof. by move=> phi12; rewrite /eqmor -mulmxBr dvdmxMl. Qed. Lemma eqmorMr (psi : 'Mor(N, P)) (phi1 phi2 : 'Mor(M, N)) : phi1 %= phi2 -> phi1 ** psi %= phi2 ** psi. Proof. rewrite /eqmor=> phi12. by rewrite -mulmxBl (dvdmx_trans (dvdmx_morphism psi)) ?dvdmxMr. Qed. End theory. End category. End morphismTheory. Arguments idm {_ _}. Infix "**" := mulmor. Infix "%=" := eqmor. #[export] Hint Resolve eqmorxx : core. Section KernelAndCo. Variable R : coherentRingType. Variables (M N : {fpmod R}) (phi : 'Mor(M,N)). (** Kernel The kernel is the submodule defined by the monomorphism induced by N.-ker: pres kermod R ---------> "kermod" | | | | kernel := N.-ker phi v M v R ---------> R | | | | phi v N v R ---------> R *) Definition kermod := source_of_mx (((pres N).-ker) phi). Definition kernel : 'Mor(kermod,_) := mor_of_mx ((pres N).-ker phi). Definition injm := kernel %= 0. (** Quotienting is just matrix stacking *) Definition quot_by : {fpmod R} := FPmod (col_mx (pres N) phi). Lemma dvd_quot_mx x (X : 'M_(x, _)) : pres N %| X -> pres quot_by %| X. Proof. by move=> dvdNX; apply/dvd_col_mxP; exists 0; rewrite mul0mx subr0. Qed. (** Cokernel We have a commutative diagram: M R--------> R | | | | phi v N v R--------> R | | | ( N ) | 1 v (phi) v R--------->R The cokernel morphism is the 1 morphism of N onto pcoker *) Definition coker : 'Mor(N, quot_by) := Morphism1 (dvd_quot_mx (dvdmx_refl _)). Definition surjm := coker %= 0. Definition isom := injm && surjm. Lemma mulkmor : kernel ** phi %= 0. Proof. by rewrite /eqmor subr0 ker_modK. Qed. Lemma mulmorc : phi ** coker %= 0. Proof. by rewrite /eqmor subr0 /= mulmx1 dvd_col_mxl. Qed. End KernelAndCo. (* Warning: kernel and coker are not compatible with %=, if we quotiented 'Mor by %=, we should always pick the kernel/coker wrt the canonical representative of the equivalence class *) Section morphismProperties. Variable R : coherentRingType. Variables (M N : {fpmod R}) (phi : 'Mor(M, N)). Definition is_mono := forall (P : {fpmod R}) (psi : 'Mor(P, M)), psi ** phi %= 0 -> psi %= 0. Definition is_epi := forall (P : {fpmod R}) (psi : 'Mor(N, P)), phi ** psi %= 0 -> psi %= 0. (* A morphism is an isomorphism if it is both injective and surjective *) Lemma monoP : reflect is_mono (kernel phi %= 0). Proof. apply: (iffP idP); last by apply; rewrite mulkmor. rewrite /is_mono /eqmor subr0 => /= dvdMK P psi. rewrite subr0 => dvd_phi_psi. by rewrite (dvdmx_trans dvdMK) //= subr0 dvd_ker. Qed. Lemma epiP : reflect is_epi (coker phi %= 0). Proof. apply: (iffP idP); last by apply; rewrite mulmorc. rewrite /is_epi /eqmor subr0. (* should be shortened *) move=> /dvd_col_mxP [X /dvdmxP [Z Z_def]] P psi. rewrite !subr0 => /= /dvdmxP [Y] /(congr1 (mulmx X)). rewrite !mulmxA -[X *m phi](addrNK 1%:M) mulmxDl mul1mx. move/(canRL (addKr _)) ->. rewrite -mulNmx opprB Z_def -mulmxA dvdmxD //; last first. by rewrite mulmxA dvdmxMl. by rewrite -mulmxA dvdmxMl // dvdmx_morphism. Qed. Lemma rinv_inj (psi : 'Mor(N, M)) : phi ** psi %= idm -> kernel phi %= 0. Proof. move/(eqmorMl (kernel phi)); rewrite mulmorA mulmor1. by rewrite (eqmor_ltrans (eqmorMr _ (mulkmor _))) mul0mor eqmor_sym. Qed. Lemma linv_surj (psi : 'Mor(N, M)) : psi ** phi %= idm -> coker phi %= 0. Proof. move/(eqmorMr (coker phi)); rewrite -mulmorA mul1mor. by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0 eqmor_sym. Qed. Definition isomorphisms (psi : 'Mor(N, M)) := (phi ** psi %= idm) && (psi ** phi %= idm). Lemma isoP : reflect (exists psi, isomorphisms psi) (isom phi). Proof. rewrite /isom /injm /surjm; apply: (iffP andP) => [[]|[psi]]; last first. by move=> /andP [/rinv_inj -> /linv_surj ->]. rewrite /eqmor !subr0. move=> phi_inj /dvd_col_mxP /sig_eqW [X /= hX]. have Xmor : pres M %| pres N *m X. rewrite (dvdmx_trans phi_inj) // dvd_ker -mulmxA -[X *m _](subrK 1%:M). by rewrite mulmxDr dvdmxDl ?mulmx1 ?dvdmxMl // -dvdmxN opprB. exists (Morphism Xmor); rewrite /isomorphisms andbC /eqmor -dvdmxN opprB hX. rewrite /eqmor (dvdmx_trans phi_inj) // dvd_ker mulmxBl mul1mx. by rewrite -mulmxA -[X in _ - X]mulmx1 -mulmxBr dvdmxMl // -dvdmxN opprB. Qed. End morphismProperties. Section MonoEpi. Variable R : coherentRingType. Variables (M N : {fpmod R}). Record monomorphism_of := Monomorphism { morphism_of_mono :> 'Mor(M, N); _ : injm morphism_of_mono }. Record epimorphism_of := Epimorphism { morphism_of_epi :> 'Mor(M, N); _ : surjm morphism_of_epi }. Record isomorphism_of := Isomorphism { morphism_of_iso :> 'Mor(M, N); _ : isom morphism_of_iso }. Fact split_andb (a b : bool) : a -> b -> a && b. Proof. by move=> pa pb; apply/andP. Qed. Definition mono_of phi (phi_mono : is_mono phi) := @Monomorphism phi (@introTF _ _ true (monoP phi) phi_mono). Definition epi_of phi (phi_epi : is_epi phi) := @Epimorphism phi (@introTF _ _ true (epiP phi) phi_epi). Definition iso_of_kc phi (k : kernel phi %= 0) (c : coker phi %= 0) : isomorphism_of := @Isomorphism phi (split_andb k c). Definition iso_of_me phi (phi_mono : is_mono phi) (phi_epi : is_epi phi) := @iso_of_kc phi (@introTF _ _ true (monoP phi) phi_mono) (@introTF _ _ true (epiP phi) phi_epi). Definition iso_of_isom phi psi (isom : @isomorphisms R M N phi psi) := Isomorphism (@introTF _ _ true (isoP phi) (ex_intro _ psi isom)). (** Helper for morphism reconstruction, à la tuple.v *) Definition monomorphism phi MkMono : monomorphism_of := MkMono (let: Monomorphism _ phi_inj := phi return injm phi in phi_inj). Definition epimorphism phi MkEpi : epimorphism_of := MkEpi (let: Epimorphism _ phi_epi := phi return surjm phi in phi_epi). Definition isomorphism phi MkIso : isomorphism_of := MkIso (let: Isomorphism _ phi_iso := phi return isom phi in phi_iso). Lemma eqmor_epi (phi psi : 'Mor(M, N)) : phi %= psi -> is_epi phi -> is_epi psi. Proof. move=> eqp phi_epi P kapa. by rewrite -(eqmor_ltrans (eqmorMr _ eqp)) => /phi_epi. Qed. Lemma eqmor_mono (phi psi : 'Mor(M, N)) : phi %= psi -> is_mono phi -> is_mono psi. Proof. move=> eqp phi_mono P kapa. by rewrite -(eqmor_ltrans (eqmorMl _ eqp)) => /phi_mono. Qed. End MonoEpi. Notation "''Mono' ( M , N )" := (monomorphism_of M N) : type_scope. Notation "''Epi' ( M , N )" := (epimorphism_of M N) : type_scope. Notation "''Iso' ( M , N )" := (isomorphism_of M N) : type_scope. Notation "''Aut' ( M )" := (isomorphism_of M M) : type_scope. Notation "[Mono 'of' phi ]" := (monomorphism (fun phi_mono => @Monomorphism _ _ _ phi phi_mono)) (at level 0, format "[Mono 'of' phi ]"). Notation "[Epi 'of' phi ]" := (epimorphism (fun phi_epi => @Epimorphism _ _ _ phi phi_epi)) (at level 0, format "[Epi 'of' phi ]"). Notation "[Iso 'of' phi ]" := (isomorphism (fun phi_iso => @Isomorphism _ _ _ phi phi_iso)) (at level 0, format "[Iso 'of' phi ]"). Arguments eqmor_mono {R M N phi psi} _ _ _ _ _. Arguments eqmor_epi {R M N phi psi} _ _ _ _ _. Section MonoTheory. Variable (R : coherentRingType). Section Mono1. Variables (M N : {fpmod R}). Lemma kernel_eq0 (phi : 'Mono(M,N)) : kernel phi %= 0. Proof. by case: phi. Qed. Hint Resolve kernel_eq0 : core. Lemma mono (phi : 'Mono(M,N)) : is_mono phi. Proof. exact/monoP. Qed. Hint Resolve mono : core. Lemma mulmono_eq0 (L : {fpmod R}) (phi : 'Mono(M,N)) (Y : 'Mor(L, M)) : (Y ** phi %= 0) = (Y %= 0). Proof. apply/idP/idP; first by move/mono. by move=> /eqmorMr /eqmor_ltrans ->; rewrite mul0mor. Qed. Variables (n : nat) (X : 'M[R]_(n, nbgen M)). Fact mor_of_mx_inj : kernel (mor_of_mx X) %= 0. Proof. by apply/monoP=> P psi; rewrite /= /eqmor !subr0 -dvd_ker. Qed. Canonical mono_of_mx := Monomorphism mor_of_mx_inj. End Mono1. Lemma left_mono (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : is_mono (phi ** psi) -> is_mono phi. Proof. by move=> mmono K kapa /(eqmorMr psi); rewrite mul0mor -mulmorA => /mmono. Qed. End MonoTheory. #[export] Hint Resolve kernel_eq0 : core. #[export] Hint Resolve mono : core. Section EpiTheory. Variable (R : coherentRingType). Section Epi1. Variables (M N : {fpmod R}). Lemma coker_eq0 (phi : 'Epi(M,N)) : coker phi %= 0. Proof. by case: phi. Qed. Hint Resolve coker_eq0 : core. Lemma epi (phi : 'Epi(M,N)) : is_epi phi. Proof. exact/epiP. Qed. Lemma mulepi_eq0 (L : {fpmod R}) (phi : 'Epi(M,N)) (Y : 'Mor(N, L)) : (phi ** Y %= 0) = (Y %= 0). Proof. apply/idP/idP; first by move/epi. by move/eqmorMl/eqmor_ltrans ->; rewrite mulmor0. Qed. End Epi1. Lemma right_epi (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : is_epi (phi ** psi) -> is_epi psi. Proof. by move=> mepi K kapa /(eqmorMl phi); rewrite mulmor0 mulmorA => /mepi. Qed. End EpiTheory. #[export] Hint Resolve coker_eq0 : core. #[export] Hint Resolve epi : core. Section IsoTheory. Variable (R : coherentRingType) (M N : {fpmod R}). Fact iso_kernel_eq0 (phi : 'Iso(M,N)) : kernel phi %= 0. Proof. by case: phi => /= ? /andP[]. Qed. Hint Resolve iso_kernel_eq0 : core. Fact iso_coker_eq0 (phi : 'Iso(M,N)) : coker phi %= 0. Proof. by case: phi => /= ? /andP[]. Qed. Hint Resolve iso_coker_eq0 : core. Canonical mono_of_iso phi := Monomorphism (iso_kernel_eq0 phi). Canonical epi_of_iso phi := Epimorphism (iso_coker_eq0 phi). Definition invmor (phi : 'Iso(M,N)) := projT1 (sigW (isoP phi (split_andb (kernel_eq0 [Mono of phi]) (coker_eq0 [Epi of phi])))). Notation "phi ^^-1" := (invmor phi). Lemma mulVmor (phi : 'Iso(M,N)) : phi^^-1 ** phi %= idm. Proof. by rewrite /invmor; case: sigW => /= psi /andP []. Qed. Lemma mulmorV (phi : 'Iso(M,N)) : phi ** phi^^-1 %= idm. Proof. by rewrite /invmor; case: sigW => /= psi /andP []. Qed. End IsoTheory. Notation "phi ^^-1" := (invmor phi) : mxpresentation_scope. Section theory. Local Open Scope mxpresentation_scope. Variable R : coherentRingType. (* Kernel is mono *) Fact kernelK (M N : {fpmod R}) (phi : 'Mor(M,N)) : kernel (kernel phi) %= 0. Proof. by rewrite kernel_eq0. Qed. Canonical mono_of_kernel (M N : {fpmod R}) (phi : 'Mor(M,N)) := Monomorphism (kernelK phi). (* cokernel is epi *) Lemma cokerK (M N : {fpmod R}) (phi : 'Mor(M,N)) : coker (coker phi) %= 0. Proof. by rewrite /eqmor subr0 dvd_col_mxl. Qed. Canonical epi_of_coker (M N : {fpmod R}) (phi : 'Mor(M,N)) := Epimorphism (cokerK phi). (* The identity morphism is an isomorphism *) Lemma isomorphisms_idm (M : {fpmod R}) : isomorphisms (@idm _ M) idm. Proof. by apply/andP; split; rewrite mulmor1. Qed. Lemma mulmor11 (M : {fpmod R}) : (@idm _ M) ** idm %= idm. Proof. by rewrite mul1mor. Qed. Canonical idm_iso (M : {fpmod R}) := iso_of_kc (rinv_inj (mulmor11 M)) (linv_surj (mulmor11 M)). (** Kernel universal property *) Definition is_kernel (M N K : {fpmod R}) (phi : 'Mor(M,N)) (k : 'Mor(K,M)) := ((k ** phi %= 0) * forall L (psi : 'Mor(L,M)), reflect (exists Y, Y ** k %= psi) (psi ** phi %= 0))%type. (** Our kernel construction has the universal property *) Lemma kernelP (M N : {fpmod R}) (phi : 'Mor(M,N)) : is_kernel phi (kernel phi). Proof. split; first by rewrite mulkmor. move=> L X; apply: (iffP idP) => [|[Y]]; last first. move/eqmorMr/eqmor_ltrans <-; rewrite -mulmorA. by rewrite (eqmor_ltrans (eqmorMl _ (mulkmor _))) mulmor0. rewrite /eqmor; rewrite subr0 -dvd_ker => /dvdmxP [Y Yeq]. have Ymor : pres (source (kernel phi)) %| pres L *m Y. by rewrite /= dvd_ker -mulmxA -Yeq dvdmx_morphism. by exists (Morphism Ymor); rewrite Yeq subrr. Qed. (** Any monomorphism is a kernel of its cokernel *) Lemma mono_ker (M N : {fpmod R}) (phi : 'Mono(M,N)) : is_kernel (coker phi) phi. Proof. split; first by rewrite mulmorc. move=> L X; apply: (iffP idP); last first. move=> [Y /eqmorMr /eqmor_ltrans <-]; rewrite -mulmorA. by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0. rewrite /eqmor subr0 /= mulmx1 => /dvd_col_mxP [Y Ydef]. suff Ymor : pres M %| pres L *m Y. by exists (Morphism Ymor); rewrite /= -dvdmxN opprB. have := kernel_eq0 phi; rewrite /eqmor subr0 /=. move=> /dvdmx_trans -> //; rewrite dvd_ker. rewrite -mulmxA -[Y *m phi](addrNK X%:m) mulmxDr dvdmxD ?dvdmx_morphism //. by rewrite dvdmxMl // -dvdmxN opprB. Qed. (* Quotienting by a morphism may allow you to factor it out *) Lemma lift_subproof (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : phi ** psi %= 0 -> pres L %| pres (quot_by phi) *m psi. Proof. by rewrite /eqmor subr0 /= mul_col_mx dvd_mx_col dvdmx_morphism. Qed. (* Lifting a morphism psi wrt a quotient by phi *) Definition lift (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : 'Mor(quot_by phi,L) := if (phi ** psi %= 0) =P true is ReflectT P then Morphism (lift_subproof P) else 0. (* We can factor a morphism psi by its lifting *) Lemma mul_lift (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Mor(N,L)) : phi ** psi %= 0 -> coker phi ** lift phi psi %= psi. Proof. rewrite /lift; case: eqP => //= p _. by rewrite /eqmor /= mul1mx subrr. Qed. (* The lifting of an epi is an epi *) Lemma lift_epi (M N L : {fpmod R}) (phi : 'Mor(M,N)) (psi : 'Epi(N,L)) : phi ** psi %= 0 -> is_epi (lift phi psi). Proof. move=> /mul_lift psiP K kapa; rewrite eqmor_sym in psiP. suff lepi : is_epi (lift phi psi) by move/lepi. apply: right_epi (coker phi) _ _. exact: (@eqmor_epi _ _ _ psi). Qed. Lemma mul_klift (M N : {fpmod R}) (psi : 'Mor(M,N)) : coker (kernel psi) ** lift (kernel psi) psi %= psi. Proof. by rewrite mul_lift // mulkmor. Qed. (* The lifting of phi to the quotient of its kernel is a monomorphism *) Lemma lift_mono (M N : {fpmod R}) (psi : 'Mor(M,N)) : is_mono (lift (kernel psi) psi). Proof. apply/monoP; rewrite /eqmor subr0 /=. rewrite (dvdmx_trans (dvd_col_mxl _ _)) // /lift. by case: eqP (mulkmor psi). Qed. (** Universal property of the cokernel *) Definition is_coker (M N C : {fpmod R}) (phi : 'Mor(M,N)) (c : 'Mor(N,C)) := ((phi ** c %= 0) * forall L (psi : 'Mor(N,L)), reflect (exists Y, c ** Y %= psi) (phi ** psi %= 0))%type. (** Our coker construction satisfies the universal property of cokernels *) Lemma cokerP (M N : {fpmod R}) (phi : 'Mor(M,N)) : is_coker phi (coker phi). Proof. split; first by rewrite mulmorc. move=> L X; apply: (iffP idP) => [phiX|[Y]]; last first. move/eqmorMl/eqmor_ltrans <-; rewrite mulmorA. by rewrite (eqmor_ltrans (eqmorMr _ (mulmorc _))) mul0mor. by exists (lift phi X); rewrite mul_lift. Qed. (* Factorisation lemma *) Lemma factor_proof (M N P : {fpmod R}) (phi : 'Mono(N,P)) (psi : 'Mor(M,P)) : reflect (exists kapa, kapa ** phi %= psi) (psi ** coker phi %= 0). Proof. apply: (iffP idP) => [|[c]]; last first. move/eqmorMr/eqmor_ltrans <-; rewrite -mulmorA. by rewrite (eqmor_ltrans (eqmorMl _ (mulmorc _))) mulmor0. rewrite /eqmor /= subr0 mulmx1 => /dvd_col_mxP [X Xdef]. suff Xmor : pres N %| pres M *m X. by exists (Morphism Xmor); rewrite -dvdmxN opprB. have /monoP := @mono _ _ _ phi. rewrite /eqmor /= subr0 => /dvdmx_trans -> //. rewrite dvd_ker -mulmxA -[X *m _](addrNK psi%:m). by rewrite mulmxDr dvdmxD ?dvdmx_morphism // dvdmxMl // -dvdmxN opprB. Qed. (* extraction of the factor *) Definition factor (M N P : {fpmod R}) (phi : 'Mor(N,P)) (psi : 'Mor(M,P)) : 'Mor(M,N) := if (kernel phi %= 0) =P true is ReflectT phi_inj then if factor_proof (Monomorphism phi_inj) psi is ReflectT P then projT1 (sig_eqW P) else 0 else 0. (* property of the factor *) Lemma factorP (M N P : {fpmod R}) (phi : 'Mono(N,P)) (psi : 'Mor(M,P)) : psi ** coker phi %= 0 -> factor phi psi ** phi %= psi. Proof. have := kernel_eq0 phi; rewrite /factor. case: eqP => // phi_inj _; case: factor_proof => //= p _. by case: sig_eqW. Qed. Notation "phi %/ psi" := (quot_by (factor phi psi)). (** Every epimorphism is a cokernel of its kernel *) Lemma epi_coker (M N : {fpmod R}) (phi : 'Epi(M,N)) : is_coker (kernel phi) phi. Proof. split; first by rewrite mulkmor. move=> L psi; apply: (iffP idP); last first. move=> [Y /eqmorMl /eqmor_ltrans <-]; rewrite mulmorA. by rewrite (eqmor_ltrans (eqmorMr _ (mulkmor _))) mul0mor. move/mul_lift; have /mul_lift := mulkmor phi. set phi' := lift _ phi; set psi' := lift _ psi. move=> phi'E psi'E. have phi'_mono : is_mono phi' by apply: lift_mono. have phi'_epi : is_epi phi' by apply: lift_epi; rewrite mulkmor. set phi'' := @iso_of_me _ _ _ phi' phi'_mono phi'_epi. exists (phi''^^-1 ** psi'). rewrite -(eqmor_ltrans (eqmorMr _ phi'E)) -(eqmor_rtrans psi'E). rewrite -mulmorA eqmorMl // mulmorA. by rewrite (eqmor_ltrans (eqmorMr _ (mulmorV phi''))) mul1mor. Qed. (** Introduction of direct sum, which play the role of the kernel *) (* and the cokernel *) Section dsum. Variables (M N : {fpmod R}). Definition dsum := FPmod (block_mx (pres M) 0 0 (pres N)). Fact proj1_proof : pres M %| pres dsum *m (col_mx 1%:M 0). Proof. by rewrite mul_block_col !mulmx0 !addr0 mul0mx mulmx1 dvd_mx_col dvdmx0 andbT. Qed. Definition proj1 : 'Mor(dsum, M) := Morphism proj1_proof. Lemma proj1_is_epi : is_epi proj1. Proof. move=> P phi; rewrite /eqmor !subr0 /=. by rewrite mul_col_mx mul0mx mul1mx dvd_mx_col => /andP[]. Qed. Canonical proj1_epi := epi_of proj1_is_epi. Definition proj2_proof : pres N %| pres dsum *m (col_mx 0 1%:M). Proof. by rewrite mul_block_col !mulmx0 !add0r mul0mx mulmx1 dvd_mx_col dvdmx0 /=. Qed. Definition proj2 : 'Mor(dsum, N) := Morphism proj2_proof. Lemma proj2_is_epi : is_epi proj2. Proof. move=> P phi; rewrite /eqmor !subr0 /=. by rewrite mul_col_mx mul0mx mul1mx dvd_mx_col => /andP[]. Qed. Canonical proj2_epi := epi_of proj2_is_epi. Lemma inj1_proof : pres dsum %| pres M *m (row_mx 1%:M 0). Proof. apply/dvdmxP; exists (row_mx 1%:M 0). by rewrite mul_mx_row mul_row_block !(mulmx0, mul0mx) !addr0 mul1mx mulmx1. Qed. Definition inj1 : 'Mor(M,dsum) := Morphism inj1_proof. Lemma inj1_is_mono : is_mono inj1. Proof. move=> P phi; rewrite /eqmor !subr0 /= mul_mx_row mulmx1 mulmx0. move=> /dvdmxP [X]; rewrite -[X]hsubmxK mul_row_block. by rewrite !mulmx0 addr0 add0r => /eq_row_mx[-> _]; rewrite dvdmxMl. Qed. Canonical inj1_mono := mono_of inj1_is_mono. Lemma inj2_proof : pres dsum %| pres N *m (row_mx 0 1%:M). Proof. apply/dvdmxP; exists (row_mx 0 1%:M). by rewrite mul_mx_row mul_row_block !(mulmx0, mul0mx) !add0r mul1mx mulmx1. Qed. Definition inj2 : 'Mor(N,dsum) := Morphism inj2_proof. Lemma inj2_is_mono : is_mono inj2. Proof. move=> P phi; rewrite /eqmor !subr0 /= mul_mx_row mulmx1 mulmx0. move=> /dvdmxP [X]; rewrite -[X]hsubmxK mul_row_block. by rewrite !mulmx0 addr0 add0r => /eq_row_mx[_ ->]; rewrite dvdmxMl. Qed. Canonical inj2_mono := mono_of inj2_is_mono. Lemma inj1_proj2 : inj1 ** proj2 = 0. Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul0mx addr0. Qed. Lemma inj2_proj1 : inj2 ** proj1 = 0. Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul0mx addr0. Qed. Lemma inj1_proj1 : inj1 ** proj1 = idm. Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul1mx addr0. Qed. Lemma inj2_proj2 : inj2 ** proj2 = idm. Proof. by apply: val_inj; rewrite /= mul_row_col mulmx0 mul1mx add0r. Qed. Lemma dsum_is_product (P : {fpmod R}) (p1 : 'Mor(P,M)) (p2 : 'Mor(P,N)) : exists phi : 'Mor(P,dsum), p1 = phi ** proj1 /\ p2 = phi ** proj2. Proof. exists (p1 ** inj1 + p2 ** inj2). rewrite !mulmorDl -!mulmorA inj1_proj1 inj1_proj2 inj2_proj1 inj2_proj2. by rewrite !mulmor1 !mulmor0 addr0 add0r. Qed. Lemma dsum_is_coproduct (P : {fpmod R}) (i1 : 'Mor(M,P)) (i2 : 'Mor(N,P)) : exists phi : 'Mor(dsum,P), i1 = inj1 ** phi /\ i2 = inj2 ** phi. Proof. exists (proj1 ** i1 + proj2 ** i2). rewrite !mulmorDr !mulmorA inj1_proj1 inj1_proj2 inj2_proj1 inj2_proj2. by rewrite !mul1mor !mul0mor addr0 add0r. Qed. End dsum. Section homology. Variables (M N P : {fpmod R}). Variables (phi : 'Mor(M, N)) (psi : 'Mor(N, P)). Hypothesis mul_phi_psi : phi ** psi %= 0. Definition homology := kernel psi %/ phi. (* Alternative definition of homology used in singular and homalg: *) (* http://link.springer.com/chapter/10.1007/3-540-28993-3_7 *) (* The connection between the two definition is not worked out yet *) Definition homology_alt_pres := (pres (quot_by phi)).-ker (kernel psi). Lemma homology_dvd : homology_alt_pres %| pres homology. Proof. rewrite /homology /homology_alt_pres. rewrite dvd_mx_col /= !dvd_ker dvd_quot_mx ?ker_modK //=. rewrite -[X in _ %| X](subrK phi%:m) dvdmxDl ?dvd_col_mxl //=. rewrite (dvdmx_trans (dvd_col_mxu _ _)) //. have := @factorP _ _ _ [Mono of kernel psi] phi. rewrite /eqmor /= subr0 mulmx1; apply. rewrite (dvdmx_trans (dvd_col_mxl _ _)) // dvd_ker. by move: mul_phi_psi; rewrite /eqmor subr0. Qed. (* Lemma homology_alt_dvd : pres homology %| homology_alt_pres. *) (* Proof. *) (* rewrite /homology /homology_alt_pres /=. *) (* have factor_phi := @factorP _ _ _ [Mono of kernel psi] phi. *) (* rewrite /eqmor /= subr0 mulmx1 in factor_phi. *) (* apply/dvd_col_mxP => /=. *) (* eexists. *) (* (* rewrite (dvdmx_trans (dvd_col_mxu _ _)) //. *) *) (* rewrite dvdmxB // !dvd_ker /=. *) (* Abort. *) End homology. End theory. Notation "phi %/ psi" := (quot_by (factor phi psi)). Section smith_fpmod. Local Open Scope mxpresentation_scope. Variable R : edrType. Variable M : {fpmod R}. Let D := FPmod (diag_mx (pres M)). Let P := (smith (pres M)).1.1. Let Q := (smith (pres M)).2. (* M *) (* -----> *) (* | | *) (* P^-1 | | Q *) (* v D v *) (* -----> *) Fact smith_subproof : pres D %| pres M *m Q. Proof. apply/dvdmxP; exists (invmx P). by rewrite /D mulmx_diag_mx mulmxA mulKVmx ?col_ebase_unit // /row_ebase invmxK. Qed. Definition smithm : 'Mor(M, D) := Morphism smith_subproof. Fact smith_inv_subproof : pres M %| pres D *m invmx Q. Proof. apply/dvdmxP; exists P. by rewrite /D mulmx_diag_mx mulmxKV ?row_ebase_unit // /col_ebase invmxK. Qed. Definition smithm_inv : 'Mor(D, M) := Morphism smith_inv_subproof. Lemma iso_smithm : isomorphisms smithm smithm_inv. Proof. have hQ_unit : Q \in unitmx by rewrite /Q; case: smithP. by rewrite /isomorphisms /eqmor /= ?(mulmxV,mulVmx,subrr,dvdmx0). Qed. Canonical smith_iso : 'Iso(M, D) := iso_of_isom iso_smithm. End smith_fpmod. coqeal-2.1.0/theory/frobenius_form.v000066400000000000000000000713661475512565300175300ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect. From mathcomp Require Import all_algebra. From mathcomp Require Import all_fingroup. From mathcomp Require Import all_real_closed. From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor. From CoqEAL Require Import smith dvdring polydvd. From CoqEAL Require Import similar perm_eq_image companion closed_poly smith_complements. (** This file provides a theory of invariant factors. The main result proved here is the similarity between a matrix and its Frobenius normal form. Frobenius_seq M == The same as the sequence Smith_seq (XI - M) where each polynomial has been divded by their lead coefficient (Hence each polynomial is monic). invariant_factors M == The sequence of non-constant polynomials of Frobenius_seq M. Frobenius_form M == The block diagonal matrix formed by the companion matrices of the invariant factors of M. Frobenius_form_CF M == The block diagonal matrix defined over a closed field formed by the companion matrices of the linear factors of the invariant factors of M. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section Frobenius. Variable F : fieldType. Local Notation E := {poly F}. Import GRing.Theory. Import PolyPriField. Local Open Scope ring_scope. Definition Frobenius_seq n (A : 'M[F]_n) := [seq (lead_coef p)^-1 *: p | p : E <- take n (Smith_seq (char_poly_mx A))]. Lemma sorted_Frobenius_seq n (A : 'M[F]_n) : sorted (@dvdp _) (Frobenius_seq A). Proof. case: n A=> // n A. have Hp: forall (p : E), ((lead_coef p)^-1 *: p %= p)%P. move=> p; have [-> | p0] := eqVneq p 0; first by rewrite scaler0 eqpxx. apply/eqpP; exists ((lead_coef p),1). by rewrite oner_neq0 andbT lead_coef_eq0. rewrite scalerA mulrV ?scale1r //. by rewrite unitfE lead_coef_eq0. suff : sorted (@dvdr _) (Frobenius_seq A). by apply: sorted_trans=> x y _ _; rewrite dvdr_dvdp=> ->. have /mono_sorted it : {mono (fun p : {poly F} => (lead_coef p)^-1 *: p) : x y / x %| y}. by move=> x y; rewrite !dvdr_dvdp (eqp_dvdl _ (Hp x)) (eqp_dvdr _ (Hp y)). rewrite it. set s := Smith_seq _. apply/(sorted_take (@dvdr_trans _))/sorted_Smith. Qed. Lemma size_Frobenius_seq n (A : 'M[F]_n) : size (Frobenius_seq A) = n. Proof. by rewrite size_map size_Smith_seq // -size_poly_eq0 size_char_poly. Qed. Lemma Frobenius_seq_char_poly n (A : 'M[F]_n) : \prod_(p <- Frobenius_seq A) p = char_poly A. Proof. rewrite big_map scaler_prod prodfV. have Hs m (B : 'M[F]_m): size (take m (Smith_seq (char_poly_mx B))) = m. by move: (size_Frobenius_seq B); rewrite size_map. have Hp1: \prod_(i <- (take n (Smith_seq (char_poly_mx A)))) i = char_poly A. case: n A => [A| n A]; first by rewrite big_nil /char_poly det_mx00. rewrite -(det_diag_mx_seq (Hs _ A)). by rewrite diag_mx_seq_takel det_Smith. have ->: \prod_(i <- (take n (Smith_seq (char_poly_mx A)))) lead_coef i = 1. rewrite lead_coef_prod Hp1. by apply/monicP/char_poly_monic. by rewrite Hp1 invr1 scale1r. Qed. Lemma Frobenius_seq_neq0 n (A : 'M[F]_n) p : p \in Frobenius_seq A -> p != 0. Proof. have Hc := (Frobenius_seq_char_poly A). have: char_poly A != 0. by rewrite -size_poly_eq0 size_char_poly. rewrite -Hc (big_nth 0) big_mkord. move/prodf_neq0=> H0 /(nthP 0) [i Hi] <-. exact: (H0 (Ordinal Hi)). Qed. Lemma monic_Frobenius_seq n (A : 'M[F]_n) p: p \in Frobenius_seq A -> p \is monic. Proof. move=> Hp. have := Frobenius_seq_neq0 Hp. move: Hp; rewrite /Frobenius_seq=> /(nthP 0) []i. rewrite size_map=> Hi; rewrite (nth_map 0) // => <-. rewrite scaler_eq0 negb_or=> /andP [_ H0]. by apply: monic_leadVMp; rewrite unitfE lead_coef_eq0. Qed. Lemma equiv_Frobenius_seq n (A : 'M[F]_n) : equivalent (diag_mx_seq n n (Smith_seq (char_poly_mx A))) (diag_mx_seq n n (Frobenius_seq A)). Proof. rewrite -diag_mx_seq_takel. apply: eqd_equiv=> // [|i]; first by rewrite size_map. set s := take _ _. case: (ltnP i (size s)) => Hi; last by rewrite !nth_default // size_map. rewrite (nth_map 0) //; apply/eqdP. exists ((lead_coef s`_i)^-1%:P). have Hin: (Frobenius_seq A)`_i \in Frobenius_seq A. by rewrite mem_nth // size_map. have:= Frobenius_seq_neq0 Hin. rewrite (nth_map 0) // scaler_eq0 negb_or=> /andP [Hl _]. by rewrite rmorph_unit // unitfE. by rewrite mul_polyC. Qed. Definition invariant_factors n (A : 'M[F]_n) := filter (fun p : E => (1 < size p)%N) (Frobenius_seq A). Lemma invariant_factor_neq0 n (A : 'M[F]_n) : forall p, p \in invariant_factors A -> p != 0. Proof. by move=> p; rewrite mem_filter; case/andP=> _; exact: Frobenius_seq_neq0. Qed. Lemma monic_invariant_factors n (A : 'M[F]_n) : forall p, p \in invariant_factors A -> p \is monic. Proof. by move=> p; rewrite mem_filter; case/andP=> _; apply: monic_Frobenius_seq. Qed. Section dvdp_monic. Local Open Scope ring_scope. Import GRing.Theory. Import PolyPriField. Variable T : fieldType. Definition dvdpm (p q : {poly T}) := (p \is monic) && (q \is monic) && (dvdp p q). Lemma dvdpm_trans : transitive dvdpm. Proof. move=> p q r /andP [] /andP [] Hq Hp Hqp /andP [] /andP [] _ Hr Hpr. apply/andP; split; first by apply/andP. exact: (dvdp_trans Hqp). Qed. Lemma dvdpm_asym : antisymmetric dvdpm. Proof. move=> p q /andP [] /andP [] /andP [] Hp Hq Hpq /andP [] _ Hqp. by apply/eqP; rewrite -eqp_monic // /eqp Hpq. Qed. Lemma dvd1pm (p : {poly T}) : p \is monic -> dvdpm 1 p. Proof. have H1:= (@monic1 T). move=> Hp; apply/andP; split; first by apply/andP. by rewrite dvd1p. Qed. End dvdp_monic. Lemma Frobenius_seqE n (A : 'M[F]_n) : Frobenius_seq A = nseq (n - size (invariant_factors A)) 1 ++ invariant_factors A. Proof. set m := subn _ _. have HfA:= (size_Frobenius_seq A). have Hfrob: sorted (@dvdpm F) (Frobenius_seq A). have Hdvd: {in (Frobenius_seq A) &, forall p q, dvdp p q -> dvdpm p q}. move=> p q /= /monic_Frobenius_seq Hp /monic_Frobenius_seq Hq H. by rewrite /dvdpm Hp Hq H. by apply/(sorted_trans Hdvd)/sorted_Frobenius_seq. have Hst: sorted (@dvdpm F) (nseq m 1 ++ invariant_factors A). apply: (@path_sorted _ _ 1); rewrite cat_path; apply/andP; split. apply/(pathP 0); rewrite size_nseq=> [][|i] Hi. by rewrite nth0 dvd1pm // nth_nseq Hi monic1. rewrite -nth_behead nth_nseq (ltn_trans (ltnSn i) Hi) dvd1pm //. by rewrite nth_nseq Hi monic1. rewrite path_min_sorted; [|apply/allP=>p Hp]. by rewrite sorted_filter //;first exact: dvdpm_trans. rewrite -nth_last nth_nseq size_nseq. by case: (m.-1 < m)%N; rewrite dvd1pm //; apply: (monic_invariant_factors Hp). apply: (sorted_eq (@dvdpm_trans F) (@dvdpm_asym F) Hfrob Hst). pose a:= fun p : E => (size p <= 1)%N. have HaC: {in (Frobenius_seq A), (fun p : E => (1 < size p)%N) =1 (predC a)}. by move=> p /=; rewrite -ltnNge. have Hfi: (invariant_factors A) = filter (predC a) (Frobenius_seq A). by rewrite -(eq_in_filter HaC). have Hm: m = size (filter a (Frobenius_seq A)). rewrite /m Hfi !size_filter. apply/eqP; rewrite -(eqn_add2r (count (predC a) (Frobenius_seq A))). by apply/eqP; rewrite subnK ?count_predC // -{2}HfA count_size. have Hfn: nseq m 1 = filter a (Frobenius_seq A). apply: (@eq_from_nth _ 0)=> [|i]; first by rewrite size_nseq. rewrite size_nseq => Hi; rewrite nth_nseq Hi. have: (filter a (Frobenius_seq A))`_i \in (filter a (Frobenius_seq A)). by rewrite mem_nth // -Hm. rewrite mem_filter=> /andP [Ha1 Ha2]. move: (monicP (monic_Frobenius_seq Ha2)). by rewrite (size1_polyC Ha1) lead_coefC => ->. by rewrite perm_sym Hfn Hfi; apply/permPl/perm_filterC. Qed. Lemma invf_char_poly n (A : 'M[F]_n) : \prod_(p <- invariant_factors A) p = char_poly A. Proof. rewrite -Frobenius_seq_char_poly Frobenius_seqE. rewrite big_cat /= (big1_seq (nseq _ _)) ?mul1r // => i. case/andP=> _ /(nthP 0) [j]. by rewrite size_nseq=> Hj; rewrite nth_nseq Hj=> ->. Qed. Lemma dvdp_invf_char_poly m (A : 'M[F]_m) (p : {poly F}) : p \in (invariant_factors A) -> dvdp p (char_poly A). Proof. move=> Hp. rewrite -invf_char_poly prod_seq_count. have Hi: p \in undup (invariant_factors A) by rewrite mem_undup. rewrite (bigD1_seq _ Hi) ?undup_uniq //= dvdp_mulr // dvdp_exp //. by rewrite -has_count has_pred1. Qed. Lemma sorted_invf n (A : 'M[F]_n) : sorted (@dvdp _) (invariant_factors A). Proof. have := sorted_Frobenius_seq A. rewrite Frobenius_seqE. apply: subseq_sorted. exact: dvdp_trans. exact: suffix_subseq. Qed. Lemma sum_size_inv_factors n (A : 'M[F]_n) : (\sum_(p <- invariant_factors A) (size p).-1 = n)%N. Proof. have {2}->: n = n.+1.-1 by []. rewrite -(size_char_poly A) -invf_char_poly (big_nth 0) [in RHS](big_nth 0). rewrite !big_mkord size_prod=> [|i _]; last first. by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth. rewrite subSKn -sum1_card; apply/eqP. set s := (\sum_(i in _) 1)%N. rewrite -(eqn_add2r s) subnK. apply/eqP; rewrite -big_split /=; apply: eq_bigr=> i _. rewrite addn1 prednK // size_poly_gt0. by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth. apply: leq_sum=> i _; rewrite size_poly_gt0. by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth. Qed. Lemma nnil_inv_factors n (A : 'M_n.+1) : invariant_factors A != [::]. Proof. apply: contraPneq (sum_size_inv_factors A) => ->. by rewrite big_nil. Qed. Let Smith_block_cpmx n (A : 'M[F]_n) := let sp := invariant_factors A in let size := [seq (size p).-2 | p : E <- sp] in let blocks m i := diag_mx_seq m.+1 m.+1 (rcons (nseq m 1) sp`_i) in diag_block_mx size blocks. Let Smith_seq_cpmx n (A : 'M[F]_n) := let sp := invariant_factors A in let m := size_sum [seq (size p).-2 | p : E <- sp] in diag_mx_seq m.+1 m.+1 (Frobenius_seq A). Lemma cast_inv n (A : 'M[F]_n.+1) : size (Frobenius_seq A) = (size_sum [seq (size p).-2 | p : E <- invariant_factors A]).+1. Proof. rewrite size_Frobenius_seq -{1}(sum_size_inv_factors A). rewrite size_sum_big; last first. by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors. rewrite !big_map /=; apply: eq_big_seq=> i. rewrite mem_filter=> /andP [Hi _]. by rewrite prednK // -subn1 subn_gt0. Qed. Lemma equiv_sbc_ssc n (A : 'M[F]_n) : equivalent (Smith_block_cpmx A) (Smith_seq_cpmx A). Proof. rewrite /Smith_block_cpmx /Smith_seq_cpmx Frobenius_seqE. have: forall p, p \in invariant_factors A -> (0 < (size p).-1)%N. by move=> p; rewrite mem_filter -subn1 subn_gt0=> /andP []. rewrite -{10}(sum_size_inv_factors A). case: (invariant_factors A)=> [_|a l]. by rewrite big_nil diag_mx_seq_nil; exact: equiv_refl. elim: l a=> /= [a Hp|b l IHl a Hp]. by rewrite big_cons big_nil addn0 subn1 cats1; exact: equiv_refl. have IHp : forall p : E, p \in b :: l -> (0 < (size p).-1)%N. by move=> p H; apply: Hp; rewrite mem_behead. have Ha: (0 < (size a).-1)%N by rewrite Hp // mem_head. have Hb: (0 < (size b).-1)%N by rewrite IHp // mem_head. set M := diag_mx_seq _ _ _. apply: (equiv_trans (equiv_drblockmx M (IHl b IHp))). rewrite -diag_mx_seq_cat ?size_rcons ?size_nseq //. set s2 := [seq (size p).-2 | p : E <- (b :: l)]. set k := (\sum_(_ <- _) _)%N. set m := (\sum_(_ <- _) _)%N. have Hk: k = (size_sum s2).+1. rewrite size_sum_big_cons /k !big_cons !big_map /= prednK //. congr (_ + _)%N; apply: eq_big_seq=> i Hi. by rewrite (@prednK (size i).-1) // IHp // mem_behead. have Hltk : (size l < k)%N. rewrite /k (eq_big_seq (fun p : E => (size p).-2 + 1)%N). rewrite big_split /= addnC (big_nth 0) sum_nat_const_nat. by rewrite subn0 muln1 leq_addr. by move=> i Hi /=; rewrite addn1 prednK // IHp. apply/similar_equiv/similar_diag_mx_seq=> //. by rewrite !size_cat size_rcons !size_nseq subnK // Hk. apply/seq.permP=> x /=. rewrite -cats1 !count_cat /= !count_nseq. rewrite !addnA addn0 (addnAC _ (x a)) -mulnDr; congr (_ * _ + _ + _ + _)%N. by rewrite /m big_cons (subnS _ (size l).+1) -{2}(prednK Ha) -addnBA //. Qed. Lemma Smith_companion (p : E) : (1 < size p)%N -> p \is monic -> equivalent (Smith_form (char_poly_mx (companion_mx p))) (diag_mx_seq (size p).-2.+1 (size p).-2.+1 (rcons (nseq (size p).-2 1) p)). Proof. move=> Hsp Hmp. rewrite /Smith_form -diag_mx_seq_takel. set s := take _ _. have Hs1: (size p).-2.+1 = size s. by rewrite -(size_Frobenius_seq (companion_mx p)) size_map. have Hs2: (size p).-2.+1 = size (rcons (nseq (size p).-2 1) p). by rewrite size_rcons size_nseq. apply: eqd_equiv=> //; first by rewrite -Hs1 -Hs2. have := leqnSn (size p).-2. rewrite -[X in (_ <= X)%N]minnn=> Hop. have Hsort: sorted %|%R s. by apply/(sorted_take (@dvdr_trans _))/sorted_Smith. have := (equiv_Smith (char_poly_mx (companion_mx p))). rewrite /Smith_form -diag_mx_seq_takel=> Hsm. have {Hop Hsort Hsm} := (Smith_gcdr_spec Hop Hsort Hsm). set d := \big[_/_]_(_<_) _=> H. have {H} Hd1: d %= 1. apply/(eqd_trans H)/andP; split; last by rewrite dvd1r. apply: big_gcdr_def; exists (finfun (lift ord0)). apply: big_gcdr_def; exists (finfun (lift ord_max)). rewrite /minor.minor /minor.submatrix /=. set M := \matrix_(_,_) _. have Hut: upper_triangular_mx M. apply/upper_triangular_mxP => i j Hij. rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. rewrite !eqn_leq !(leqNgt _ j) ltn_ord subr0. by rewrite ltnW // ltnNge Hij !andFb subr0. rewrite (det_triangular_mx Hut). rewrite (eq_bigr (fun _ => -1)) ?prodr_const ?card_ord; last first. move=> i; rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. by rewrite eqxx !eqn_leq ltnn (leqNgt _ i) ltn_ord sub0r subr0. by apply/dvdrP; exists ((-1)^+ (size p).-2); rewrite -expr2 sqrr_sign. have Hip: s`_(size p).-2 %= p. rewrite eqd_sym in Hd1. rewrite -(mul1r s`_(size p).-2) (eqd_ltrans (eqd_mulr _ Hd1)). rewrite -{2}(comp_char_polyK Hmp Hsp) /char_poly -det_Smith. rewrite /Smith_form -diag_mx_seq_takel. rewrite det_diag_mx_seq // eqd_sym (big_nth 0) big_mkord. by rewrite -Hs1 big_ord_recr /=. move/eqd_big_mul1: Hd1 => H i. case: (ltngtP i (size p).-2) => Hi. - by rewrite nth_rcons size_nseq Hi nth_nseq Hi (H (Ordinal Hi)). - by rewrite !nth_default // -?Hs1 // size_rcons size_nseq. by rewrite nth_rcons size_nseq Hi eqxx ltnn. Qed. Definition Frobenius_form n (A : 'M[F]_n) := let sp := invariant_factors A in let size := [seq (size p).-2 | p : E <- sp] in let blocks n i := [seq companion_mxn n.+1 p | p <- sp]`_i in diag_block_mx size blocks. Lemma Frobenius n (A : 'M[F]_n.+1) : similar A (Frobenius_form A). Proof. apply/similar_fundamental; rewrite char_diag_block_mx; last first. by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors. apply: (equiv_trans (equiv_Smith (char_poly_mx A))). rewrite /Smith_form. apply/(equiv_trans (equiv_Frobenius_seq A))/equiv_sym. have Hn := size_Frobenius_seq A. rewrite /equivalent -{2 4 37 38 43 44}Hn cast_inv. apply: (equiv_trans _ (equiv_sbc_ssc A)). apply: equiv_diag_block=>[|i]; first by rewrite !size_map. rewrite size_map=> Hi. rewrite !(nth_map 0) //. set C := char_poly_mx _. apply: (equiv_trans (equiv_Smith C)). apply: Smith_companion; move: (mem_nth 0 Hi). by rewrite mem_filter=> /andP []. exact: monic_invariant_factors. Qed. Lemma Frobenius_unicity n m (A : 'M[F]_n) (B : 'M_m) : similar A B <-> invariant_factors A = invariant_factors B. Proof. split=> [[Hmn H]|H]; rewrite /invariant_factors. congr filter; apply: (@eq_from_nth _ 0)=>[|i Hi]. by rewrite !size_Frobenius_seq. have/Frobenius_seq_neq0 := mem_nth 0 Hi. rewrite size_Frobenius_seq in Hi. rewrite !(nth_map 0) ?size_Smith_seq -?Hmn -?size_poly_eq0 ?size_char_poly //. rewrite size_poly_eq0 scaler_eq0 negb_or invr_eq0=> /andP [Hl0 _]. apply: (scalerI Hl0); rewrite !scalerA mulrV ?unitfE // scale1r. apply: eqpfP; rewrite /eqp -!dvdr_dvdp [X in take X]Hmn. rewrite Hmn in Hi; rewrite !nth_take //. apply: Smith_unicity => //; first exact: sorted_Smith. set D := char_poly_mx A. rewrite -{3 4 6 7}Hmn. apply: (equiv_trans _ (equiv_Smith D)). by apply/similar_fundamental/similar_sym. have/eqP: n = m. - by rewrite -(sum_size_inv_factors A) -(sum_size_inv_factors B) H. case: n A H => [A|n A]; case: m B=> [B|m B] H Hmn //. exact: similar0. apply/(similar_trans (Frobenius A))/similar_sym/(similar_trans (Frobenius B)). rewrite /Frobenius_form H. exact: similar_refl. Qed. Lemma mxminpoly_inv_factors n (A : 'M[F]_n.+1) : last 0 (Frobenius_seq A) = mxminpoly A. Proof. have Hif: (0 < size (invariant_factors A))%N. by rewrite lt0n size_eq0 nnil_inv_factors. have Hfn: [seq (size p).-2 | p : E <- invariant_factors A] != [::]. by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors. apply: mxminpolyP=> [||q HA]. - apply: (@monic_Frobenius_seq _ A). by rewrite -nth_last mem_nth // size_Frobenius_seq. - apply: (similar_horner (similar_sym (Frobenius A))). rewrite horner_mx_diag_block //. apply/diag_block_mx0=> i; rewrite size_map=> Hi. rewrite !(nth_map 0) // Frobenius_seqE last_cat -nth_last. rewrite (set_nth_default 0) ?prednK // ?Hif //. set p := nth _ _ _. apply: (@horner_mx_dvdp _ _ p). apply: sorted_leq_nth=> //. - exact: dvdp_trans. - exact: sorted_invf. - by rewrite inE prednK. by rewrite -ltnS prednK. rewrite -{5}[p]comp_mxminpolyK. - exact: mx_root_minpoly. - exact: (monic_invariant_factors (mem_nth 0 Hi)). move: (mem_nth 0 Hi). by rewrite mem_filter -subn_gt0 subn1; case/andP. move: (similar_horner (Frobenius A) HA). rewrite horner_mx_diag_block // => /diag_block_mx0=> H. rewrite Frobenius_seqE last_cat -nth_last (set_nth_default 0) ?prednK //. move: (H (size (invariant_factors A)).-1). rewrite size_map !(nth_map 0) ?prednK //. set p := nth _ _ _=> Hp. have Hm:= @mem_nth _ 0 (invariant_factors A) (size (invariant_factors A)).-1. rewrite -[p]comp_mxminpolyK ?dvdr_dvdp. - exact: (mxminpoly_min (Hp (leqnn _))). - apply/(@monic_invariant_factors _ A)/Hm. by rewrite prednK // mem_filter -subn_gt0 subn1. move: Hm; rewrite prednK // mem_filter -subn_gt0 subn1=> h. by case/andP: (h (leqnn _)). Qed. End Frobenius. Section Polynomial. Local Open Scope ring_scope. Import GRing.Theory. Import PolyPriField. Variable R : closedFieldType. Lemma similar_poly_inv (p : {poly R}) : let sp := linear_factor_seq p in let size_seq := [seq (size p).-2 | p : {poly R} <- sp] in let blocks n i := companion_mxn n.+1 sp`_i in (1 < (size p))%N -> p \is monic -> similar (companion_mx p) (diag_block_mx size_seq blocks). Proof. move=> /= Hp1 Hmp. move: (@coprimep_linear_factor_seq _ p). move: (@monic_linear_factor_seq _ p). move: (@size_linear_factor_leq1 _ p). move: Hmp Hp1 (monic_prod_factor Hmp). elim: (linear_factor_seq p) {1 2 3 14 16}p. move=> p0 Hmp0 Hsp0; rewrite big_nil=> H. by rewrite H size_poly1 in Hsp0. move=> a; case=> [_ p1 _ _ Hp1 _ _ _ | b l IHl p1 Hmp1 Hsp1 Hp1 Hs Hm Hcp] /=. rewrite Hp1 big_cons big_nil mulr1. by apply: similar_refl. have Hicp : forall i j : 'I_(size (b :: l)), i != j -> coprimep (b :: l)`_i (b :: l)`_j. move=> i j H. have Hij: (lift ord0 i) != (lift ord0 j). by apply/val_eqP=> /lift_inj; apply/eqP. by move: (Hcp _ _ Hij); rewrite -!nth_behead. pose p2:= p1 %/ a. have Hma: a \is monic by apply: Hm; rewrite mem_head. have Hsa: (1 < size a)%N by apply: Hs; rewrite mem_head. have Hp2: p2 = \prod_(x <- (b :: l)) x. by rewrite /p2 Hp1 big_cons divr_mulKr // monic_neq0. have Hml: forall x, x \in (b :: l) -> x \is monic. by move=> x Hx; apply: Hm; rewrite mem_behead. have Hsl: forall x, x \in b :: l -> (1 < size x)%N. by move=> x Hx; apply: Hs; rewrite mem_behead. have {Hs} Hsb: (1 < size b)%N by apply: Hsl; rewrite mem_head. have {Hm} Hmb: b \is monic by apply: Hml; rewrite mem_head. have {Hp1} Hp12: p1 = a * p2 by rewrite Hp1 Hp2 big_cons. have Hmp2: p2 \is monic by rewrite -(monicMl _ Hma) -Hp12. have sp1gt0 : (0 < size (1%:P : {poly R}))%N by rewrite size_poly1. have mgt0 (x y : {poly R}) : (0 < size x -> 0 < size y -> 0 < size (x * y)%R)%N. by move=> sx sy; rewrite size_mul -?size_poly_eq0; move: sx sy; case: (size x); case: (size y) => // n1 n2; rewrite ?addnS. have {Hsb Hmb} Hsp2: (1 < size p2)%N. rewrite Hp2 big_cons size_proper_mul. rewrite -subn1 -addnBA ?ltn_addr //. rewrite big_seq. apply: (big_ind (fun (p : {poly R}) => (0 < size p)%N) sp1gt0 mgt0)=> q Hq. have: (1 < size q)%N by apply: Hsl; rewrite mem_behead. by apply: ltn_trans. move/monicP: Hmb => ->; rewrite mul1r lead_coef_eq0 -size_poly_leq0. rewrite -ltnNge big_seq. apply: (big_ind (fun (p : {poly R}) => (0 < size p)%N) sp1gt0 mgt0)=> q Hq. have: (1 < size q)%N by apply: Hsl; rewrite mem_behead. by apply: ltn_trans. move=> {sp1gt0 mgt0}. apply: (@similar_trans _ _ _ _ (block_mx (companion_mx a) 0 0 (companion_mx p2))); last first. by apply: (similar_drblockmx _ (IHl _ Hmp2 Hsp2 Hp2 Hsl Hml Hicp)). have {Hp2 Hml Hsl Hcp Hicp IHl} Hcap: coprimep a p2. have copa1 : coprimep a 1%P by apply: coprimep1. have copaxy (x y : {poly R}) : coprimep a x -> coprimep a y -> coprimep a (x * y)%R. by rewrite coprimepMr=> -> ->. rewrite Hp2 big_seq. apply: (big_ind (fun p => coprimep a p)). + by apply: coprimep1. + by move=> x y; rewrite coprimepMr => -> ->. move=> i iin; move/(nth_index 0): (iin)=> iid. move: (iin); rewrite -index_mem -ltnS=> ii_prf. set j := Ordinal ii_prf. have vi : [:: a, b & l]`_j = i by apply: (nth_index 0 iin). by have := Hcp ord0 j isT; rewrite vi /=. apply/similar_fundamental. apply: (equiv_trans (equiv_Smith _)). apply: (equiv_trans (Smith_companion Hsp1 Hmp1)). rewrite Hp12 char_dblock_mx. apply: (@equiv_trans _ _ _ _ _ _ _ (block_mx (diag_mx_seq (size a).-2.+1 (size a).-2.+1 (rcons (nseq (size a).-2 1) a)) 0 0 (diag_mx_seq (size p2).-2.+1 (size p2).-2.+1 (rcons (nseq (size p2).-2 1) p2)))); last first. apply: equiv_dgblockmx; apply: equiv_sym; set C := char_poly_mx _ . by apply: (equiv_trans (equiv_Smith C)); apply: Smith_companion. by apply: (equiv_trans (equiv_Smith C)); apply: Smith_companion. rewrite -diag_mx_seq_cat ?size_rcons ?size_nseq //. set M := diag_mx_seq _ _ (_ ++ _). set sap := (size (a * p2)).-2.+1. set sa := (size a).-2.+1. set sp := (size p2).-2.+1. have Hcast: sap = (sa + sp)%N. rewrite /sap /sa /sp size_proper_mul. rewrite -!subn1 -addnBA; last by rewrite ltnW. rewrite addnC -addnBA; last by rewrite ltnW. rewrite -addnBA ?subn_gt0 // addSn addnC !subn1 (@prednK (_.-1)) //. by rewrite -subn1 subn_gt0. by move/monicP: Hma; move/monicP: Hmp2=> -> ->; rewrite mulr1 oner_eq0. have HdetM: \det M = p1. rewrite det_diag_mx_seq ?size_cat ?size_rcons ?size_nseq //. rewrite -!cats1 !big_cat /= !big_cons !big_nil. rewrite !big1_seq=> [|i|i]; try by rewrite mem_nseq => /= /andP[] _ /eqP. by rewrite !mul1r !mulr1 -Hp12. have Ho: (sa.-1 < (sa + sp).-1)%N by rewrite prednK // addnS leq_addr. have HM1: row' (Ordinal Ho) (col' (Ordinal Ho) (row' ord_max (col' ord_max M))) = 1%:M. apply/matrixP=> j k; rewrite !mxE !lift_max. rewrite nth_cat size_rcons size_nseq. case: ifP; rewrite nth_rcons size_nseq. rewrite ltnS leq_eqVlt eq_sym (negbTE (neq_bump _ _)) /= => Hb. by rewrite Hb nth_nseq Hb eqn_leq !leq_bump2 -eqn_leq. move/negbT;rewrite -leqNgt=> Hb. have Hb2: (bump (size a).-2 j - (size a).-2.+1 < (size p2).-2)%N. rewrite -(ltn_add2r sa _ _.-2) subnK //. by rewrite (leq_trans (ltn_ord (lift (Ordinal Ho) j))) // addnC addSn. by rewrite Hb2 nth_nseq Hb2 eqn_leq !leq_bump2 -eqn_leq. apply/equiv_sym/(equiv_trans (equiv_Smith M)). rewrite /Smith_form -diag_mx_seq_takel. set s := take _ _. have Hs1: size s = sap by rewrite Hcast size_Smith_seq // HdetM monic_neq0. apply: eqd_equiv=> // [|i]; first by rewrite size_rcons size_nseq. have Hle: (sap.-2 <= sa + sp)%N by rewrite -Hcast -subn2 leq_subr. have Hsort: sorted (@dvdr _) s. by apply/(sorted_take (@dvdr_trans _))/sorted_Smith. have:= (equiv_Smith M). rewrite /Smith_form -diag_mx_seq_takel=> Hequiv. have Hle2: (sap.-2 < minn (sa + sp) (sa + sp))%N by rewrite minnn Hcast addnS addSn. have:= Smith_gcdr_spec Hle2 Hsort Hequiv. set d2 := \big[_/_]_(_<_) _=> H2. have {H2} Hd2: d2 %= 1. apply/(eqd_trans H2); rewrite /eqd !dvdr_dvdp. apply: (coprimepP _ _ Hcap); rewrite -dvdr_dvdp. +apply: big_gcdr_def; rewrite Hcast prednK ?addnS ?addSn //. exists (finfun (lift (@ord_max (sa + sp).-1))). apply: big_gcdr_def. exists (finfun (lift (@ord_max (sa + sp).-1))). rewrite /minor.minor /minor.submatrix /=. rewrite (expand_det_row _ (Ordinal Ho)) (bigD1 (Ordinal Ho)) //=. rewrite !mxE !ffunE big1 ?addr0. rewrite nth_cat size_rcons size_nseq lift_max /=. rewrite ltnS leqnn nth_rcons size_nseq ltnn eqxx. rewrite /cofactor exprD -expr2 sqrr_sign mul1r. set N:= row' _ _. have ->: N = 1%:M. by rewrite -HM1; apply/matrixP=> j k; rewrite !mxE !ffunE !lift_max. by rewrite det1 mulr1. move=> j /negbTE Hj; rewrite !mxE !ffunE. by rewrite (inj_eq (@ord_inj _)) (inj_eq (@lift_inj _ _)) eq_sym Hj mul0r. have Ho2: (sa .-1 < sa + sp)%N by rewrite prednK // leq_addr. apply: big_gcdr_def; rewrite Hcast prednK ?addnS ?addSn //. exists (finfun (lift (Ordinal Ho2))). apply: big_gcdr_def. exists (finfun (lift (Ordinal Ho2))). rewrite /minor.minor /minor.submatrix /=. have Hom: ((size a).-2 + (size p2).-2 < (size a).-2 + sp)%N by rewrite addnS. have Hlom k : lift (Ordinal Hom) k = widen_ord (leq_pred _) k. apply: ord_inj=> /=; rewrite /bump leqNgt. by rewrite (leq_trans (ltn_ord k)) // addnS leqnn. rewrite (expand_det_row _ (Ordinal Hom)). rewrite (bigD1 (Ordinal Hom)) //= big1 ?addr0. rewrite !mxE !ffunE /= -[X in bump X _]addn0 bumpDl /bump leq0n /=. rewrite nth_cat size_rcons size_nseq ltnS add1n {1}addnS. rewrite ltnNge leq_addr /= nth_rcons size_nseq. rewrite {1 3}addnS !subSS !addKn !ltnn !eqxx. rewrite /cofactor exprD -expr2 sqrr_sign mul1r. set N:= row' _ _. have ->: N = 1%:M. rewrite -HM1; apply/matrixP=> j k. by rewrite !mxE !ffunE !lift_max !Hlom /=. by rewrite det1 mulr1. move=> j /negbTE Hj; rewrite !mxE !ffunE (inj_eq (@ord_inj _)). by rewrite (inj_eq (@lift_inj _ _)) eq_sym Hj mul0r. have Hsp: s`_sap.-1 %= p1. rewrite eqd_sym in Hd2. rewrite -(mul1r s`_sap.-1) (eqd_ltrans (eqd_mulr _ Hd2)). rewrite -HdetM -det_Smith /Smith_form -diag_mx_seq_takel det_diag_mx_seq. rewrite (big_nth 0) big_mkord Hs1 big_ord_recr /=. by apply: eqd_mul=> //; rewrite /d2 prednK // Hcast addnS addSn. by rewrite Hs1 Hcast. move/eqd_big_mul1: Hd2=> H. have [Hi|Hi|/eqP Hi] := (ltngtP i sap.-1). +have Hi2: (i < sap.-2.+1)%N by rewrite prednK // Hcast addnS addSn. rewrite nth_rcons size_nseq Hi nth_nseq Hi. exact: (H (Ordinal Hi2)). by rewrite !nth_default // ?Hs1 // size_rcons size_nseq. by rewrite nth_rcons size_nseq Hi (eqP Hi) ltnn -Hp12. Qed. Definition Frobenius_form_CF n (A : 'M[R]_n) := let fm f s := flatten (map f s) in let sp := invariant_factors A in let l p := linear_factor_seq p in let sc p := [seq (size q).-2 | q : {poly R} <- l p] in let size := flatten (map sc sp) in let blocks m i := companion_mxn m.+1 (fm l sp)`_i in diag_block_mx size blocks. Lemma similar_Frobenius n (A : 'M[R]_n.+1) : similar (Frobenius_form A) (Frobenius_form_CF A). Proof. rewrite /Frobenius_form /Frobenius_form_CF. move: (@monic_invariant_factors _ _ A). have: forall p, p \in (invariant_factors A) -> (1 < size p)%N. by move=> p; rewrite mem_filter; case/andP. case: (invariant_factors A)=>[_ _|a l]; first exact: similar_refl. elim: l a=> /= [a Hsa Hma |b l IHl a Hs Hm]. rewrite !cats0; apply: similar_poly_inv. by rewrite Hsa // mem_head. by rewrite Hma // mem_head. have IHs: forall p : {poly R}, p \in b :: l -> (1 < size p)%N. by move=> p Hp; apply: Hs; rewrite mem_behead. have IHm: forall p : {poly R}, p \in b :: l -> p \is monic. by move=> p HP; apply: Hm; rewrite mem_behead. have Hsa: (1 < size a)%N by rewrite Hs // mem_head. have Hma: a \is monic by rewrite Hm // mem_head. set M := companion_mxn _ _. apply: (similar_trans (similar_drblockmx M (IHl b IHs IHm))). apply: (similar_trans (similar_ulblockmx _ (similar_poly_inv Hsa Hma))). have Hnv: forall p, p \in [:: a, b & l] -> linear_factor_seq p != [::]. move=> p Hp; rewrite /linear_factor_seq -size_eq0 !size_map size_eq0. rewrite /root_seq_uniq; apply: contra_neq; first exact: undup_nil. by rewrite -root_seq_nil -ltnNge; apply: Hs. set s1 := _ ++ _. set s2 := linear_factor_seq _ ++ _. have: (linear_factor_seq a) != [::] by rewrite Hnv // mem_head. have t: s2 != [::]. have: linear_factor_seq b != [::] by rewrite Hnv // mem_behead // mem_head. by rewrite /s2; case: (linear_factor_seq b). clear -t. have ->: s1 = [seq (size p).-2 | p : {poly R} <- s2]. by rewrite /s1 map_cat map_flatten; congr (_ ++ _); rewrite [in LHS]map_comp. case: (linear_factor_seq a)=> //= c s _. elim: s c=> [c|c s IHs d] /=. case: s2 t => // d s2 _ /=. exact: similar_refl. set M := companion_mxn _ _. apply: similar_sym. apply: (similar_trans (similar_drblockmx M (similar_sym (IHs c)))). rewrite /GRing.zero /= -row_mx_const -col_mx_const block_mxA. apply/similar_sym/similar_cast. rewrite col_mx_const row_mx_const. exact: similar_refl. Qed. End Polynomial. coqeal-2.1.0/theory/gauss.v000066400000000000000000000065041475512565300156230ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg. From mathcomp Require Import mxalgebra perm zmodp matrix ssrint. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section Gaussian. Import GRing.Theory. Local Open Scope ring_scope. Variable F : fieldType. Definition find_pivot m n (A : 'M[F]_(m,n.+1)) : option 'I_m := [pick k | A k 0 != 0]. Fixpoint cormen_lup {m n} := match m, n return 'M_(m.+1,n.+1) -> 'S_m.+1 * 'M_(m.+1,m.+1) * 'M_(m.+1,n.+1) with | p.+1, _.+1 => fun (A : 'M_(1 + (1 + p), 1 + _)) => let k := odflt 0 (find_pivot A) in let A1 : 'M_(1 + _, 1 + _) := xrow 0 k A in let P1 : 'S_(1 + (1 + p)) := tperm 0 k in let Schur := ((fun_of_matrix A k 0)^-1 *: dlsubmx A1) *m ursubmx A1 in let: (P2, L2, U2) := cormen_lup (drsubmx A1 - Schur) in let P := (lift0_perm P2 * P1)%g in let pA1 := row_perm P2 (dlsubmx A1) in let L := block_mx 1%:M (const_mx 0) ((fun_of_matrix A k 0)^-1 *: pA1) L2 in let U := block_mx (ulsubmx A1) (ursubmx A1) (const_mx 0) U2 in (P, L, U) | _, _ => fun A => (1%g, 1%:M, A) end. Lemma cormen_lup_correct n (A : 'M_n.+1) : let: (P, L, U) := cormen_lup A in matrix.row_perm P A = L * U. Proof. elim: n => [|n IHn] /= in A *; first by rewrite row_perm1 mul1r. set k := odflt _ _; set A1 : 'M_(1 + _) := matrix.xrow _ _ _. set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P' L' U']] /= IHn. (* glueing code *) rewrite row_permM !row_permE. rewrite -lift0_mx_perm. rewrite /lift0_mx. (****************) rewrite -!mulmxE -xrowE -/A1 /= -[n.+2]/(1 + n.+1)%N -{1}(submxK A1). rewrite !mulmx_block !mul0mx !mulmx0 !add0r !addr0 !mul1mx -{L' U'}[L' *m _]IHn. rewrite row_permE. rewrite -scalemxAl !scalemxAr -!mulmxA addrC -mulrDr {A'}subrK. congr (block_mx _ _ (_ *m _) _). rewrite [_ *: _]mx11_scalar !mxE lshift0 tpermL {}/A1 {}/k /find_pivot. case: pickP => /= [k nzAk0 | no_k]; first by rewrite mulVf ?mulmx1. rewrite (_ : matrix.dlsubmx _ = 0) ?mul0mx //; apply/colP=> i. by rewrite !mxE lshift0 (elimNf eqP (no_k _)). Qed. Lemma cormen_lup_detL n (A : 'M_n.+1) : \det (cormen_lup A).1.2 = 1. Proof. elim: n => [|n IHn] /= in A *; first by rewrite det1. set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= detL. by rewrite (@det_lblock _ 1) det1 mul1r. Qed. Lemma cormen_lup_lower n (A : 'M_n.+1) (i j : 'I_n.+1) : i <= j -> (cormen_lup A).1.2 i j = (i == j)%:R. Proof. elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1 [j]ord1 mxE. set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Ll. rewrite !mxE split1; case: unliftP => [i'|] -> /=; rewrite !mxE split1. by case: unliftP => [j'|] -> //; exact: Ll. by case: unliftP => [j'|] ->; rewrite /= mxE. Qed. Lemma cormen_lup_upper n A (i j : 'I_n.+1) : j < i -> (cormen_lup A).2 i j = 0 :> F. Proof. elim: n => [|n IHn] /= in A i j *; first by rewrite [i]ord1. set A' := _ - _; move/(_ A'): IHn; case: cormen_lup => [[P L U]] {A'}/= Uu. rewrite !mxE split1; case: unliftP => [i'|] -> //=; rewrite !mxE split1. by case: unliftP => [j'|] ->; [exact: Uu | rewrite /= mxE]. Qed. End Gaussian. coqeal-2.1.0/theory/jordan.v000066400000000000000000000270271475512565300157610ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect. From mathcomp Require Import all_algebra. From mathcomp Require Import all_fingroup. From mathcomp Require Import all_real_closed. From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor. From CoqEAL Require Import smith dvdring polydvd. From CoqEAL Require Import similar perm_eq_image companion closed_poly smith_complements. From CoqEAL Require Import frobenius_form. (** The main result of this file is the theorem of Jordan decomposition. A direct consequence of this theorem is the diagonalization theorem. Jordan_block lam n == The Jordan block of dimension n with the value lam on the diagonal. Jordan_form M == The block diagonal matrix formed by the Jordan blocks of roots of invariant factors of M, and of dimension their multiplicity. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section def. Variable R : ringType. Import GRing.Theory. Local Open Scope ring_scope. Definition Jordan_block lam n : 'M[R]_n := \matrix_(i,j) (lam *+ (i == j :> nat) + (i.+1 == j)%:R). Lemma Jordan_block0 : Jordan_block 0 1 = 0. Proof. by apply/matrixP=> i j; rewrite !mxE !ord1 addr0. Qed. Lemma upt_Jordan_block lam n : upper_triangular_mx (Jordan_block lam n). Proof. apply/upper_triangular_mxP=> i j Hij ; rewrite mxE. by rewrite (gtn_eqF Hij) eqn_leq ltnNge (ltnW Hij) addr0. Qed. End def. Section trigonal. Variable R : comRingType. Import GRing.Theory. Local Open Scope ring_scope. Lemma det_Jordan_block (lam : R) n : \det (Jordan_block lam n) = lam ^+ n. Proof. rewrite det_triangular_mx; last by apply: upt_Jordan_block. rewrite -{8}[n]card_ord -prodr_const. by apply: eq_bigr=> i _; rewrite mxE eqxx eqn_leq ltnn addr0. Qed. Lemma Jordan_expn (lam : R) n k : (Jordan_block lam n.+1)^+ k = \matrix_(i,j) (('C(k,j - i)%:R * (lam^+ (k - (j - i)))) *+ (i <= j)). Proof. elim: k =>[|k IHk]. apply/matrixP=> i j; rewrite !mxE bin0n subn_eq0 sub0n mulr1 [RHS]mulrb. by rewrite -(inj_eq (@ord_inj _)) eqn_leq /andb; case: ifP. rewrite exprS IHk. apply/matrixP=> i j; rewrite !mxE. case: (eqVneq i ord_max) => Hi. - rewrite (bigD1 i) //= !mxE big1 ?addr0=>[|l /negbTE Hl]. - rewrite eqxx eqn_leq ltnn addr0. have ->: (j - i)%N = 0%N by apply/eqP; rewrite subn_eq0 Hi -ltnS. by rewrite !bin0 !mul1r !subn0 mulrnAr exprS. rewrite !mxE eq_sym [(_ == _ :> nat)]Hl Hi eqn_leq. by rewrite ltnNge -ltnS ltn_ord addr0 mul0r. have Ho: (i.+1 < n.+1)%N by rewrite ltn_neqAle Hi ltn_ord. rewrite (bigD1 i) //= (bigD1 (Ordinal Ho)); last first. by rewrite -(inj_eq (@ord_inj _)) eqn_leq ltnn. rewrite !mxE eqxx (@eq_sym nat i) !eqn_leq !ltnn addr0 add0r. rewrite !leqnn mul1r subnS /= big1 ?addr0; last first. move=> l /andP [] /negbTE Hil /negbTE Hl. by rewrite !mxE eq_sym [_ == _ :>nat]Hil eq_sym [_ == _ :>nat]Hl addr0 mul0r. case: (ltngtP i j)=> Hij; last first. (*******************cas i = j***********************************) - by rewrite Hij subnn !subn0 addr0 !bin0 !mul1r exprS. (****************** cas j < i ****************************************) - by rewrite addr0 mulr0. (************* cas i <= j***************************) rewrite !mulr1n mulrC -mulrA -exprSr -{2}subn1. have H1ij: (1 <= j - i)%N by rewrite subn_gt0. rewrite (subnBA _ H1ij) addn1. case: (leqP (j-i) k)=> Hijk. by rewrite (subSn Hijk) -mulrDl -{1}(prednK H1ij) -natrD -binS prednK. have:= Hijk; rewrite -subn_eq0=> /eqP Hijk2. rewrite (bin_small Hijk) // mul0r Hijk2 !mulr1 add0r. rewrite leq_eqVlt in Hijk. case/orP: Hijk=> Hijk. rewrite (eqP Hijk) binn. rewrite -(prednK H1ij) eqSS in Hijk. by rewrite (eqP Hijk) binn. by rewrite !bin_small // -ltnS prednK. Qed. Lemma char_poly_Jordan_block (lam : R) n : char_poly (Jordan_block lam n) = ('X - lam%:P) ^+n. Proof. rewrite char_poly_triangular_mx; last by apply: upt_Jordan_block. rewrite (eq_bigr (fun _ => ('X - lam%:P))) ?prodr_const ?card_ord //. by move=> i; rewrite mxE eqxx eqn_leq ltnn addr0. Qed. End trigonal. Section similar. Variable R : fieldType. Import GRing.Theory. Import PolyPriField. Local Open Scope ring_scope. Lemma similar_cj n (lam : R) : similar (companion_mx (('X - lam%:P)^+ n.+1)) (Jordan_block lam n.+1). Proof. set p := _^+n.+1. have Hmp: p \is monic by rewrite monic_exp // monicXsubC. have Hsp: (1 < size p)%N by rewrite size_exp_XsubC. apply/similar_fundamental. apply: (equiv_trans (equiv_Smith _)). apply: (equiv_trans (Smith_companion Hsp Hmp)). set M := char_poly_mx _. apply/equiv_sym/(equiv_trans (equiv_Smith M)). rewrite /Smith_form -diag_mx_seq_takel. set s := take _ _. have Hs1: size s = n.+1. rewrite size_Smith_seq // -/(char_poly _) char_poly_Jordan_block. by rewrite -size_poly_eq0 size_exp_XsubC. apply: eqd_equiv; rewrite ?size_exp_XsubC // ?size_rcons ?size_nseq //=. have Hsort: sorted (@dvdr _) s. by apply/(sorted_take (@dvdr_trans _))/sorted_Smith. move: (equiv_Smith M). rewrite /Smith_form -diag_mx_seq_takel => Hequiv. have Hlemin: (n <= minn n.+1 n.+1)%N by rewrite minnn. move: (Smith_gcdr_spec Hlemin Hsort Hequiv). set d := \big[_/_]_(_<_) _=> H. have {H} Hd1: d %= 1. apply/(eqd_trans H)/andP; split; last by rewrite dvd1r. apply: big_gcdr_def; exists (finfun (lift ord_max)). apply: big_gcdr_def; exists (finfun (lift ord0)). rewrite /minor.minor /minor.submatrix /=. set N := \matrix_(_,_) _. have Hut: upper_triangular_mx N^T. apply/upper_triangular_mxP=> i j Hij. rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. rewrite !eqn_leq !(leqNgt _ j) ltnS (ltnW Hij) ltnNge Hij. by rewrite andbF addr0 subr0. rewrite -det_tr (det_triangular_mx Hut). rewrite (eq_bigr (fun _ => -1)) ?prodr_const ?card_ord; last first. move=> i; rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max. by rewrite eqxx !eqn_leq ltnn andbF sub0r add0r. by apply/dvdrP; exists ((-1)^+ n); rewrite -expr2 sqrr_sign. have Hip: s`_n %= p. rewrite eqd_sym in Hd1. rewrite -(mul1r s`_n) (eqd_ltrans (eqd_mulr _ Hd1)). rewrite /p -char_poly_Jordan_block /char_poly -det_Smith. rewrite /Smith_form -diag_mx_seq_takel det_diag_mx_seq //. by rewrite (big_nth 0) big_mkord Hs1 big_ord_recr. move/eqd_big_mul1: Hd1 => H i. case: (ltngtP i n) => Hi. - by rewrite nth_rcons size_nseq Hi nth_nseq Hi (H (Ordinal Hi)). - by rewrite !nth_default // ?Hs1 // size_rcons size_nseq. by rewrite nth_rcons size_nseq Hi ltnn eqxx. Qed. End similar. Section jordan. Variable R : closedFieldType. Import GRing.Theory. Import PolyPriField. Local Open Scope ring_scope. Definition Jordan_form m (A : 'M[R]_m.+1) := let sp := root_seq_poly (invariant_factors A) in let sizes := [seq (x.2).-1 | x <- sp] in let blocks n i := Jordan_block (nth (0,0%N) sp i).1 n.+1 in diag_block_mx sizes blocks. Lemma upt_Jordan n (A : 'M[R]_n.+1) : upper_triangular_mx (Jordan_form A). Proof. apply: upper_triangular_diag_block=> j. exact: upt_Jordan_block. Qed. Lemma Jordan n (A : 'M[R]_n.+1) : similar A (Jordan_form A). Proof. apply: (similar_trans (Frobenius _)). apply: (similar_trans (similar_Frobenius _)). rewrite /Frobenius_form_CF /Jordan_form /root_seq_poly /linear_factor_seq. set s1 := flatten _. set s2 := map _ _. have Hs: size s1 = size s2. rewrite /s1 size_map. by do 2! rewrite map_comp -map_flatten size_map. apply: similar_diag_block=> // i; rewrite /s1. (do 2! rewrite map_comp -map_flatten size_map) => Hi. rewrite (nth_map 0) ?size_map //. rewrite !(nth_map (0,0%N)) ?size_map //. set x := nth _ _ _. rewrite -(@prednK x.2); first exact: similar_cj. have/flattenP [s Hfs Hx] := mem_nth (0,0%N) Hi; move: Hfs. case/(nthP nil)=> m; rewrite !size_map=> Hm Heq. move: Heq Hx; rewrite (nth_map 0) // => <-. apply: root_mu_seq_pos. apply: (@invariant_factor_neq0 _ _ A). by rewrite mem_nth. Qed. Lemma Jordan_char_poly n (A : 'M_n.+1) : char_poly A = \prod_i ('X - ((Jordan_form A) i i)%:P). Proof. rewrite (similar_char_poly (Jordan A)). exact: (char_poly_triangular_mx (upt_Jordan A)). Qed. Lemma eigen_diag n (A : 'M_n.+1) : let sp := root_seq_poly (invariant_factors A) in let sizes := [seq (x.2).-1 | x <- sp] in perm_eq [seq (Jordan_form A) i i | i <- enum 'I_(size_sum sizes).+1] (root_seq (char_poly A)). Proof. have Hinj: injective (fun (c : R) => 'X - c%:P). by move=> x y /= H; apply/polyC_inj/oppr_inj/(addrI 'X). apply: (perm_map_inj Hinj). apply: (@unicity_decomposition _ _ _ (char_poly A)). + move=> r /(nthP 0) []i; rewrite !size_map=> Hi. rewrite (nth_map 0) ?size_map // => <-. exact: irredp_XsubC. - move=> r /(nthP 0) []i; rewrite !size_map=> Hi. rewrite (nth_map 0) ?size_map // => <-. exact: irredp_XsubC. + move=> r /(nthP 0) []i; rewrite !size_map=> Hi. rewrite (nth_map 0) ?size_map // => <-. exact: monicXsubC. - move=> r /(nthP 0) []i; rewrite !size_map=> Hi. rewrite (nth_map 0) ?size_map // => <-. exact: monicXsubC. + by rewrite !big_map; exact: Jordan_char_poly. rewrite big_map {1}[char_poly A]root_seq_eq. by rewrite (monicP (char_poly_monic A)) scale1r. Qed. Lemma diagonalization n (A : 'M[R]_n.+1) : uniq (root_seq (mxminpoly A)) -> similar A (diag_mx_seq n.+1 n.+1 (root_seq (char_poly A))). Proof. move=> H. have [Heq _]:= Jordan A. pose s := [seq (x.2).-1 | x <- root_seq_poly (invariant_factors A)]. have Hs: size ([seq (Jordan_form A) i i | i <- enum 'I_(size_sum s).+1]) = n.+1. by rewrite size_map size_enum_ord. have Hn i: nth 0%N s i = 0%N. case: (ltnP i (size (root_seq_poly (invariant_factors A))))=> Hi. rewrite (nth_map (0,0%N)) //. have/flattenP [s2 Hd Hs2] := (mem_nth (0,0%N) Hi); move: Hd. case/(nthP nil)=> m; rewrite !size_map=> Hm Heq2. move: Heq2 Hs2; rewrite (nth_map 0) // => <-. move=> Hr; rewrite (uniq_root_mu_seq _ Hr) //. apply: (uniq_root_dvdp _ H). by rewrite monic_neq0 // mxminpoly_monic. rewrite -mxminpoly_inv_factors Frobenius_seqE last_cat -nth_last. have Hif: (0 < (size (invariant_factors A)))%N. by rewrite lt0n size_eq0 nnil_inv_factors. rewrite (set_nth_default 0) ?prednK //. apply: sorted_leq_nth=> //. -exact: dvdp_trans. -exact: sorted_invf. -by rewrite inE prednK. by rewrite -ltnS prednK. by rewrite nth_default // size_map. apply: (similar_trans (Jordan A)). apply: (similar_trans _ (similar_diag_mx_seq (erefl n.+1) Hs (eigen_diag A))). rewrite /Jordan_form diag_block_mx_seq //. rewrite size_map size_enum_ord in Hs. rewrite Hs. set s1 := mkseq _ _. set s2 := map _ _. have ->: s2 = s1. apply: (@eq_from_nth _ 0). rewrite size_map size_enum_ord Heq size_mkseq. rewrite size_sum_big. rewrite (eq_big_seq (fun _ => 1%N)). by rewrite (big_nth 0%N) sum_nat_const_nat subn0 muln1. by move=> x /(nthP 0%N) [i Hi]; rewrite Hn=> <-. rewrite -size_eq0 size_map size_flatten sumn_big !big_map. have H0: (0 < (size (invariant_factors A)))%N. by rewrite lt0n size_eq0 nnil_inv_factors. rewrite (big_nth 0) big_mkord (bigD1 (Ordinal H0)) //. rewrite size_map -lt0n addn_gt0 lt0n size_eq0. apply/orP; left; apply/eqP=>/undup_nil; apply/eqP. rewrite -root_seq_nil -ltnNge. have:= (mem_nth 0 H0). by rewrite mem_filter; case/andP=> ->. move=> i; rewrite size_map size_enum_ord=> Hi. rewrite (nth_map 0) ?size_enum_ord //. by rewrite (nth_ord_enum 0 (Ordinal Hi)) !mxE eqxx. exact: similar_refl. Qed. Lemma ex_diagonalization n (A : 'M[R]_n.+1) : uniq (root_seq (mxminpoly A)) -> {s | similar A (diag_mx_seq n.+1 n.+1 s)}. Proof. move=> H; exists (root_seq (char_poly A)). exact: diagonalization. Qed. End jordan. coqeal-2.1.0/theory/kaplansky.v000066400000000000000000000746441475512565300165100ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype matrix mxalgebra bigop zmodp perm choice. Require Import dvdring mxstructure minor stronglydiscrete coherent edr. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. Section Smith2x2. Variable R : dvdRingType. Variable smith2x2 : 'M[R]_2 -> 'M[R]_2 * seq R * 'M[R]_2. Definition smith1xn n (smith2xn : 'M[R]_(2,n.+2) -> 'M[R]_2 * seq R * 'M[R]_n.+2) (M : 'M[R]_(1,n.+2)) : 'M[R]_1 * seq R * 'M[R]_n.+2 := let: (L,d,R) := smith2xn (col_mx M 0) in if d`_0 == 0 then (1%:M,[::],1%:M) else ((L 0 0)%:M, [:: d`_0], R). Fixpoint smith2xn n : 'M[R]_(2,1 + (1 + n)) -> 'M[R]_2 * seq R * 'M[R]_n.+2 := if n is p.+1 then fun A : 'M[R]_(2,1 + _) => let: A1 := lsubmx A in let: A2 := rsubmx A in let: (P1,d1,Q1) := smith2xn A2 in let: C := row_mx (P1 *m A1) (P1 *m A2 *m Q1) : 'M[R]_(2,1 + (1 + _)) in let: D := row_mx (col 0 C) (col 1 C) in let: E := rsubmx (rsubmx C) in let: (P2,d2,Q2) := smith2x2 D in let: H := row_mx (P2 *m D *m Q2) (P2 *m E) : 'M[R]_(1 + 1, 1 + _) in let: y := d2`_0 in let: r' := map_mx (fun x => odflt 0 (x %/? y)) (ursubmx H) in let: H' := drsubmx H : 'rV_(2 + _) in let: (L1,d,R1) := smith1xn smith2x2 (lsubmx H') in let: R1' := (block_mx R1 0 0 1%:M) in (lift0_mx L1 *m P2 *m P1, y :: d, lift0_mx Q1 *m block_mx Q2 0 0 1%:M *m block_mx 1%:M (- r' *m R1') 0 R1') else fun A => smith2x2 A. Fixpoint smithmxn_rec m n : 'M[R]_(1 + (1 + m),1 + (1 + n)) -> 'M[R]_(1 + (1 + m)) * seq R * 'M[R]_(1 + (1 + n)) := match m,n with | 0,_ => fun A => smith2xn A | _,0 => fun A => let: (L,d,R) := smith2xn A^T in (R^T,d,L^T) | m'.+1,n'.+1 => fun A => let: A1 := usubmx A in let: A2 := dsubmx A in let: (P1,x,Q1) := smithmxn_rec A2 in let: C := col_mx (A1 *m Q1) (P1 *m A2 *m Q1) in let: D := col_mx (row 0 C) (row 1 C) in let: E := dsubmx (dsubmx C) in let: (P2,y,Q2) := smith2xn D in let: H := col_mx (P2 *m D *m Q2) (E *m Q2) : 'M[R]_(1 + _, 1 + _) in let: y := y`_0 in let: c' := map_mx (fun x => odflt 0 (x %/? y)) (dlsubmx H) in let: (L1,d,R1) := smithmxn_rec (drsubmx H) in let: P := block_mx P2 0 0 1%:M : 'M[R]_(1 + _) in (block_mx 1%:M 0 (- L1 *m c') L1 *m P *m lift0_mx P1, y :: d, Q1 *m Q2 *m lift0_mx R1) end. Definition smithmxn m n : 'M[R]_(m,n) -> 'M[R]_m * seq R * 'M[R]_n := match m,n with | 0,_ => fun _ => (1%:M,[::],1%:M) | _,0 => fun _ => (1%:M,[::],1%:M) | 1,1 => fun A => (1%:M,[:: A 0 0],1%:M) | 1,_.+2 => smith1xn (@smith2xn _) | _.+2,1 => fun A => let: (L,d,R) := smith1xn (@smith2xn _) A^T in (R^T,d,L^T) | _.+2,_.+2 => fun A => smithmxn_rec A end. End Smith2x2. Definition simplmx := (mulmx1,mul1mx,mul0mx,mulmx0,addr0,add0r). Section Smith2x2_correctness. Variable R : dvdRingType. Variable smith2x2 : 'M[R]_2 -> 'M[R]_2 * seq R * 'M[R]_2. Hypothesis smith2x2P : forall M, smith_spec M (smith2x2 M). Lemma surgery m n (M : 'M[R]_(1 + (1 + m),n)) : M = col_mx (col_mx (row 0 M) (row 1 M)) (dsubmx (dsubmx M)). Proof. apply/matrixP=> i j; rewrite !mxE; case: splitP=> k hk; rewrite !mxE. by case: splitP=> l hl; rewrite !mxE; congr fun_of_matrix; apply/ord_inj; rewrite hk hl ord1. by congr fun_of_matrix; apply/ord_inj. Qed. Lemma surgery2 m n (M : 'M[R]_(m,1 + (1 + n))) : M = row_mx (row_mx (col 0 M) (col 1 M)) (rsubmx (rsubmx M)). Proof. apply: trmx_inj; rewrite (tr_row_mx (row_mx (col 0 M) (col 1 M))). by rewrite tr_row_mx !tr_col !trmx_rsub {1}[M^T]surgery. Qed. Hint Resolve dvdr0 : core. Lemma smith1xnP n (M : 'M[R]_(1,1 + (1 + n))) (smith2xn : 'M[R]_(2,n.+2) -> 'M[R]_2 * seq R * 'M[R]_n.+2) (smith2xnP : forall M, smith_spec M (smith2xn M)) : smith_spec M (smith1xn smith2xn M). Proof. rewrite /smith1xn; case: smith2xnP; rewrite [2%N]/(1+1)%N=> P d Q h_eq hs hP hQ. have [d0|d_neq0] := (boolP (d`_0 == 0)). constructor; rewrite ?unitmx1 // ?simplmx; apply/matrixP=> i j. move/(canRL (mulmxK hQ))/(canRL (mulKmx hP))/matrixP: h_eq. rewrite diag_mx_seq0; last by rewrite sorted_dvd0r // sorted_cons // dvd0r. rewrite mul0mx mulmx0 ord1 {i} diag_mx_seq_nil. by move/(_ (widen_ord (lt0n 2) 0) j); rewrite !mxE split1; case: unliftP. move/matrixP: h_eq; rewrite -mulmxA [col_mx M 0 *m _]mul_col_mx mul0mx=> h_eq. have hP00 : ((P 0 0)%:M : 'M_1) \in unitmx. rewrite unitmxE det_scalar expr1; apply/unitrPr; exists ((invmx P) 0 0). move/matrixP: (mulVmx hP) => /(_ 0 0); rewrite !mxE !big_ord_recl big_ord0. suff -> : P (lift 0 0) 0 = 0 by rewrite mulr0 !addr0 mulrC. rewrite -{1}[P]submxK (mul_block_col (ulsubmx P)) ?(mulmx0,addr0) in h_eq. move/eqP: (h_eq 1 0) (h_eq 0 0) d_neq0. rewrite ?(mxE,mulr0n,split1); case: unliftP unliftP=> // i _ [] //= _. rewrite ord1 ?(mxE,big_ord_recl,big_ord0) addr0 lshift0 rshift1 mulr1n. by rewrite mulf_eq0; case/orP=> /eqP -> // <-; rewrite mulr0 addr0 eqxx. constructor=> //; apply/matrixP=> i j; rewrite ord1 {i}. move: (h_eq 0 j); rewrite ?(big_ord_recl,big_ord0,addr0,mxE,split1,mulr1n). case: unliftP unliftP => // _ [] //= k _ <-. rewrite ?(ord1,mxE,big_ord_recl,mulr0,addr0,mulrDr,mulrA) {k} big_distrr /=. by do ?congr (_ + _); apply: eq_bigr=> i _; rewrite ?(mxE,big_ord1) mulrA. Qed. Arguments nth : simpl never. Lemma smith2xnP : forall n (M : 'M[R]_(2,1 + (1 + n))), smith_spec M (smith2xn smith2x2 M). Proof. elim=> [|n ih]; first exact: smith2x2P. rewrite [n.+1]/(1 + n)%N => M /=; set A1 := lsubmx M; set A2 := rsubmx M. case: ih=> /= P1 d1 Q1 h1 h2 hP1 hQ1; set E := rsubmx _. set C := row_mx (P1 *m A1) _ : 'M[R]_(2,1 + (1 + _)); set D := row_mx _ _. case: smith2x2P=> /= P2 d2 Q2 H1 H2 hP2 hQ2. set H := row_mx (P2 *m D *m Q2) _ : 'M[R]_(1 + _, 1 + (1 + _)). case: (smith1xnP _ smith2x2P)=> L1 d R1; rewrite -mulmxA=> hLdR dsorted hL1 hR1. set r := ursubmx H; set r' := map_mx _ _; set H' := drsubmx H : 'rV[R]_(2 + n). have dvd_d20_d0 : d2`_0 %| d1`_0. have -> : d1`_0 = D 0 (rshift 1 0). rewrite row_mxEr !mxE split1 h1; case: unliftP => //= j hj. by rewrite !mxE; case: j hj=> [[]]. move/(canRL (mulmxK hQ2))/(canRL (mulKmx hP2)): H1 => ->. apply: dvdr_mulmxl=> i j; apply: dvdr_mulmxr=> {}i {}j. by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n ?dvdr0. have hx0 i j : d1`_0 %| d1`_i *+ (i == j). by case: eqP => _; rewrite ?sorted_nth0 // mulr0n dvdr0. have Hdvd i j : d2`_0 %| H i j. rewrite -[(1 + (1 + _))%N]/(2 + _)%N /H H1 dvdr_row_mx //; split=> {}i {}j. by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n ?dvdr0. apply: dvdr_mulmxl=> {}i {}j; rewrite /E row_mxKr h1 !mxE. move: (dvdr_trans dvd_d20_d0 (hx0 i (rshift 1 j))). by case: eqP => _; rewrite ?(mulr0n,dvdr0,mulr1n). constructor; rewrite ?unitmx_mul; last first. - rewrite !unitmxE ?(det_lblock,det_ublock,det_lblock Q2,det1,mulr1,mul1r). by rewrite -!unitmxE hQ1 hQ2 hR1. - by rewrite hP2 hP1 unitmxE (@det_ublock _ 1) det1 mul1r -unitmxE hL1. - apply: sorted_cons=> //; move/matrixP: hLdR => /(_ 0 0). rewrite [RHS]mxE mulr1n => <-. exact: (dvdr_mulmxl _ (dvdr_mulmxr _ (dvdr_lsubmx (n0:=2) (dvdr_drsubmx _)))). rewrite -[M]hsubmxK -/A1 -/A2 -[_ *m P1 *m _]mulmxA (mul_mx_row _ A1) -!mulmxA. rewrite [row_mx (P1 *m A1) _ *m (_ *m _)]mulmxA mul_row_block ?simplmx !mulmxA. have -> : lift0_mx L1 *m P2 *m C *m block_mx Q2 0 0 1%:M = lift0_mx L1 *m block_mx d2`_0%:M r 0 H'. rewrite -!mulmxA; congr (_ *m _); rewrite mulmxA [C]surgery2 -mulmxA. rewrite (mul_row_block D) ?simplmx mul_mx_row mulmxA -/H -[H]submxK. f_equal; apply/rowP=> i; rewrite !mxE H1 ?ord1 ?lshift0; by case: splitP=> // j hj; rewrite !mxE -hj. rewrite -[lift0_mx L1 *m _ *m _]mulmxA (mulmx_block d2`_0%:M r) ?simplmx. rewrite mulmx_block ?simplmx mulmxA -mulmxDl mulmxN mul_scalar_mx. have -> : - (d2`_0 *: r') + r = 0. apply/rowP=> i; rewrite 4!mxE. case: odivrP=> /= [w ->|]; first by rewrite mulrC addrC subrr mxE. move: (Hdvd (lshift _ 0) (rshift 1 i)); rewrite -[H]submxK block_mxEur. by case/dvdrP=> w hw /(_ w); rewrite hw eqxx. rewrite mul0mx diag_mx_seq_cons; f_equal; rewrite -[H']hsubmxK mulmxA. rewrite (mul_mx_row _ (lsubmx H')) (mul_row_block (L1 *m lsubmx H')) ?simplmx. rewrite -mulmxA hLdR; apply/rowP=> i; rewrite !mxE. case: splitP=> j ->; rewrite !mxE //= mulr0n big_ord1 !mxE /H' /E row_mxKr h1. case: splitP=> [[[] // []]|] //= [[]] //= m hm hh. by rewrite !mxE big_ord_recl big_ord1 ?(mxE,mulr0n,mulr0,addr0). Qed. Arguments smith2xn : simpl never. Lemma smithmxn_recP : forall m n (M : 'M[R]_(1 + (1 + m),1 + (1 + n))), smith_spec M (smithmxn_rec smith2x2 M). Proof. elim=> [|m ih [|n] A] /=; first exact: smith2xnP. case: smith2xnP=> L0 d R0 h1 h2 h3 h4. constructor; rewrite ?unitmx_tr //; apply/trmx_inj. by rewrite !trmx_mul !trmxK tr_diag_mx_seq mulmxA. set A1 := usubmx A; set A2 := dsubmx A. case: (ih) => P1 x Q1 hP1xQ1 x_sorted hP1 hQ1; rewrite hP1xQ1. set C := col_mx (A1 *m Q1) _; set D := col_mx (row 0 C) (row 1 C). set E := dsubmx (dsubmx C). case: smith2xnP=> P2 y Q2 hP2yQ2 y_sorted hP2 hQ2. set H := col_mx (P2 *m D *m Q2) (E *m Q2) : 'M[R]_(1 + (1 + _),1 + (1 + _)). set y0 := y`_0; set c := dlsubmx H; set c' := map_mx _ _; set H' := drsubmx H. case: ih=> L1 d R1; rewrite -mulmxA=> hLdR d_sorted hL1 hR1. have dvd_y0_x0 : y0 %| x`_0. have -> : x`_0 = D (rshift 1 0) 0. rewrite col_mxEd !mxE split1. by case: unliftP=> // [[[]]] //= i _; rewrite !mxE. move/(canRL (mulmxK hQ2))/(canRL (mulKmx hP2)): hP2yQ2=> ->. apply: dvdr_mulmxl=> i j; apply: dvdr_mulmxr=> {}i {}j. by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n ?dvdr0. have hx0 i j : x`_0 %| x`_i *+ (i == j). by case: (i == j :> nat); rewrite ?sorted_nth0 // mulr0n dvdr0. have Hdvd i j : y0 %| H i j. rewrite -[(1 + (1 + _))%N]/(2 + _)%N; apply: dvdr_col_mx; split=> {}i {}j. rewrite hP2yQ2 !mxE. by case: (i == j :> nat); rewrite ?sorted_nth0 // mulr0n dvdr0. apply: dvdr_mulmxr=> {}i {}j; rewrite /E col_mxKd. apply: dvdr_dsubmx=> {}i {}j; rewrite !mxE. move: (dvdr_trans dvd_y0_x0 (hx0 i j)). by case: (i == j :> nat); rewrite ?(mulr0n,dvdr0,mulr1n). constructor; last first. - by rewrite !unitmx_mul hQ1 hQ2 unitmxE det_lblock det1 mul1r -unitmxE. - rewrite !unitmx_mul /lift0_mx ?(unitmxE,det_lblock,@det_lblock _ 2,det1,mul1r). by rewrite mulr1 -!unitmxE hL1 hP1 hP2. - apply: sorted_cons=> //. move/matrixP: hLdR => /(_ 0 0); rewrite [RHS]mxE mulr1n => <-. exact: (dvdr_mulmxl L1 (dvdr_mulmxr R1 (dvdr_drsubmx Hdvd))). rewrite -[A]vsubmxK -!mulmxA [_ *m (col_mx A1 _ *m _)]mulmxA mul_block_col. rewrite !mul0mx addr0 add0r mul1mx [_ *m (Q1 *m _)]mulmxA [_ *m Q1]mul_col_mx. rewrite hP1xQ1 [_ *m (C *m _)]mulmxA [_ *m (Q2 *m _)]mulmxA diag_mx_seq_cons. have -> : block_mx P2 0 0 1%:M *m C *m Q2 = block_mx y0%:M 0 c H'. rewrite [C]surgery mul_block_col ?simplmx mul_col_mx -/H -[H]submxK. f_equal; apply/rowP=> i; rewrite !mxE hP2yQ2; by case: splitP=> // j hj; rewrite !mxE -hj. rewrite !mulmx_block ?simplmx -hLdR; congr block_mx. rewrite -mulmxA mulNmx -mulmxN -mulmxDr mul_mx_scalar. suff -> : - (y0 *: c') + c = 0 by rewrite mulmx0. apply/colP=> i; rewrite 4!mxE. case: odivrP=> /= [w ->|]; first by rewrite mulrC addrC subrr mxE. move: (Hdvd (rshift 1 i) (lshift _ 0)); rewrite -[H]submxK block_mxEdl. by case/dvdrP=> w hw /(_ w); rewrite hw eqxx. Qed. Lemma smithmxnP : forall m n (M : 'M[R]_(m,n)), smith_spec M (smithmxn smith2x2 M). Proof. case=> [|[[|[|n M]]|m [|[M|n M]]]] /=; do ?by constructor; rewrite ?unitmx1 ?flatmx0 ?thinmx0 ?diag_mx_seq_nil. - constructor; rewrite ?unitmx1 // mul1mx mulmx1. by apply/rowP=> i; rewrite ord1 !mxE. - exact: (smith1xnP _ (@smith2xnP _)). - case: (smith1xnP _ (@smith2xnP _))=> L1 d R1 h1 h2 h3 h4. constructor; rewrite ?unitmx_tr //. by apply/trmx_inj; rewrite !trmx_mul !trmxK tr_diag_mx_seq mulmxA. exact: smithmxn_recP. Qed. End Smith2x2_correctness. (* Bézout domains are Hermite rings *) Section Bezout_hermite. Variable R : bezoutDomainType. Definition hermite (M : 'M[R]_2) := Bezout_step (M 0 0) (M 1 0) M 0. Lemma hermite10 M : (hermite M) 1 0 = 0. Proof. rewrite /hermite Bezout_stepE /Bezout_mx /combine_mx. rewrite !mxE !big_ord_recl big_ord0 addr0 /=. case: egcdrP=> g u v a1 b1 heq hg ha1 hb1. rewrite ?(mxE,mulr0n,mulr1n,mulr0,mulr1,addr0,add0r) /=. have -> : lift 0 0 = 1 by move=> n; apply/ord_inj. by rewrite ha1 hb1 !mulrA -mulrDl [a1 * b1]mulrC -mulrDl addrC subrr !mul0r. Qed. End Bezout_hermite. Section Mx2. Variable R : comRingType. Definition mx2 a b c d := block_mx (a%:M : 'M[R]_1) b%:M c%:M d%:M. Lemma mx2_E00 a b c d : (mx2 a b c d) 0 0 = a. Proof. by do ?(rewrite mxE split1; case: unliftP=> //=); rewrite mxE mulr1n. Qed. Lemma mx2_E01 a b c d : (mx2 a b c d) 0 1 = b. Proof. by do ?(rewrite mxE split1; case: unliftP=> //= * ); rewrite ord1 mxE mulr1n. Qed. Lemma mx2_E10 a b c d : (mx2 a b c d) 1 0 = c. Proof. by do ?(rewrite mxE split1; case: unliftP=> //= * ); rewrite ord1 mxE mulr1n. Qed. Lemma mx2_E11 a b c d : (mx2 a b c d) 1 1 = d. Proof. have -> : 1 = rshift 1 0 :> 'I_2 by apply/ord_inj. by rewrite block_mxEdr mxE mulr1n. Qed. Lemma detmx2 a b c d : \det (mx2 a b c d) = a * d - c * b. Proof. by rewrite det2 mx2_E00 mx2_E01 mx2_E10 mx2_E11. Qed. End Mx2. (* The necessary and sufficient first order condition in Kaplanskys paper *) Section Kaplansky_suff. Variable R : bezoutDomainType. Variable kap : R -> R -> R -> R * R. Hypothesis kapP : forall (a b c : R), gcdr a (gcdr b c) %= 1 -> let: (p,q) := kap a b c in coprimer (p * a) (p * b + q * c). Lemma coprimerP (a b : R) : reflect (exists xy, xy.1 * a + xy.2 * b = 1) (coprimer a b). Proof. case: (egcdrP a b) => g u v a1 b1 h1 h2 h3 h4. apply: (iffP idP)=> [/(eqd_trans h2) | [[x y]]] /=. rewrite -unitd1; case/unitrP=> x [hx1 hx2]; exists (x*u,x*v). by rewrite -!mulrA -mulrDr h3 h4 !mulrA -mulrDl h1 mul1r. rewrite {1}h3 {1}h4 !mulrA -mulrDl=> H; move: (@unitr1 R). rewrite -H unitrM !unitd1=> /andP [_ H']. by rewrite /coprimer eqd_sym (eqd_trans _ h2) // eqd_sym. Qed. Definition kapW a b c : R * R := let: (p,q) := kap a b c in if coprimerP (p * a) (p * b + q * c) is ReflectT P then projT1 (sig_eqW P) else (0,0). Lemma kapWP a b c : let: (p,q) := kap a b c in coprimer (p * a) (p * b + q * c) -> let: (x,y) := kapW a b c in x * (p * a) + y * (p * b + q * c) = 1. Proof. rewrite /kapW; case: kap => p q. case: coprimerP=> // [[[x y]]] /= Hxy _. by case: sig_eqW=> /= [[]]. Qed. Definition egcdr3 (a b c : R) := let: (g',u1,vv1,b1,c1) := egcdr b c in let: (g,u,v,a1,g1) := egcdr a g' in (g, u, v * u1, v * vv1, a1, b1 * g1,c1 * g1). Variant egcdr3_spec a b c : R * R * R * R * R * R * R -> Type := EgcdrSpec g x y z a1 b1 c1 of x * a1 + y * b1 + z * c1 = 1 & g %= gcdr a (gcdr b c) & a = a1 * g & b = b1 * g & c = c1 * g : egcdr3_spec a b c (g,x,y,z,a1,b1,c1). Lemma egcdr3P a b c : egcdr3_spec a b c (egcdr3 a b c). Proof. rewrite /egcdr3; case: egcdrP=> /= g' u1 v1 b1 c1 heq hg' hb1 hc1. case: egcdrP=> /= g u v a1 g1 heq' hg ha1 hg1. constructor; rewrite -?mulrA -?hg1 ?(eqd_trans hg) ?eqd_gcd //. by rewrite -addrA -mulrDr !mulrA -mulrDl heq mul1r. Qed. Definition kap_smith (M : 'M[R]_2) : 'M[R]_2 * seq R * 'M[R]_2 := let: A := hermite M in let: a00 := A 0 0 in let: a01 := A 0 1 in let: a11 := A 1 1 in let: (d,_,_,_,a,b,c) := egcdr3 a00 a01 a11 in if d == 0 then (Bezout_mx (M 0 0) (M 1 0) 0,[::],1%:M) else let: (p,q) := kap a b c in let: (x1,y1) := kapW a b c in let: (x,y) := (a * x1 + y1 * b, c * y1) in (mx2 p q (- y) x *m Bezout_mx (M 0 0) (M 1 0) 0, map (fun x => d * x) [:: 1; - a * c], mx2 x1 (p * b + q * c) y1 (- p * a)). Arguments map : simpl never. Lemma kap_smithP (M : 'M[R]_2) : smith_spec M (kap_smith M). Proof. rewrite /kap_smith; set A := hermite _ : 'M_(1+1). set a00 := (_ 0 0); set a01 := (_ 0 1); set a11 := (_ 1 1). case: egcdr3P=> /= d xd yd zd a b c heq; rewrite eqd_sym=> hgcd ha hb hc. have [d0|dn0] := boolP (d == 0). constructor; rewrite ?unitmx1 ?unit_Bezout_mx // mulmx1 -Bezout_stepE. have -> : Bezout_step (M 0 0) (M 1 0) M 0 = A by []. rewrite diag_mx_seq_nil -(@block_mx0 _ 1 _ 1). have -> : A = mx2 a00 a01 0 a11. rewrite -[A]submxK. congr block_mx; apply/rowP=> i; rewrite !mxE ord1 ?lshift0 ?mulr1n ?rshift1 //; have -> // : lift 0 0 = 1 by move=> n; apply/ord_inj. by rewrite hermite10. by rewrite /mx2; f_equal; rewrite ?ha ?hb ?hc ?(eqP d0) ?mulr0 -scalemx1 scale0r. have /kapP : gcdr a (gcdr b c) %= 1. rewrite -(eqd_mul2r _ _ dn0) mul1r (eqd_trans _ hgcd) //. rewrite (eqd_trans (mulr_gcdl _ _ _)) //. by rewrite -ha eqd_gcd ?(eqd_trans (mulr_gcdl _ _ _)) // -hb -hc. move: (kapWP a b c); case: kap => p q H1 H3; move: (H1 H3). case: kapW=> x1 y1 => {H1 H3} H; move: (H). rewrite mulrCA [x1 * a]mulrC mulrDr [y1 * _]mulrCA addrA -mulrDr. set x := a * x1 + y1 * b; rewrite mulrCA [y1 * c]mulrC; set y := c * y1=> Hxy. constructor. * set M1 := mx2 _ _ _ _; set M2 := mx2 _ _ _ _. rewrite -!mulmxA [_ *m (_ *m M2)]mulmxA -Bezout_stepE. have -> : Bezout_step (M 0 0) (M 1 0) M 0 = d *: mx2 a b 0 c. rewrite scale_block_mx -!mul_scalar_mx -!scalar_mxM mulr0 mulrC -ha mulrC. rewrite -hb -mulrC -hc -[Bezout_step _ _ _ _](@submxK _ 1). have h1 : lift 0 0 = 1 by move=> n; apply/ord_inj. f_equal; apply/rowP=> i; rewrite !mxE ord1 ?(lshift0,rshift1,h1) mulr1n //. by rewrite hermite10. rewrite -scalemxAl -!scalemxAr -diag_mx_seq_scale; congr (_ *: _). rewrite /M1 /M2 /mx2 !(@mulmx_block _ 1) -[0%:M]scalemx1 scale0r !mul0mx. rewrite !add0r -?(scalar_mxM,raddfD) /= mulrC [_ * y1]mulrC. rewrite !diag_mx_seq_cons diag_mx_seq_nil. f_equal. - by rewrite mulrC Hxy. - rewrite [a * _ + _]addrC [a * _]mulrDr addrA mulrCA [a * _]mulrCA. rewrite [b * a]mulrC mulNr addNr add0r ![_ * (- p * _)]mulrCA mulNr. by rewrite [c * _]mulrC [q * (_ * _)]mulrCA addrN -[0%:M]scalemx1 scale0r. - by rewrite -/x -/y mulNr mulrC addNr -[0%:M]scalemx1 scale0r. - apply/matrixP=> i j; rewrite !ord1 {i j} [RHS]mxE split1. case: unliftP=> //= _; rewrite [RHS]mxE split1; case: unliftP => //= _. rewrite !mxE !mulr1n !mulrDr !mulNr !mulrN opprK [_ + y * _]addrC addrA. rewrite [p * b]mulrC [a * (b * p)]mulrCA [p * a]mulrC addrN sub0r. rewrite ![_ * (a * _)]mulrCA -!mulNr -mulrDr mulrCA mulrAC -mulrA -mulrDr. by rewrite [x * p]mulrC addrC -mulrA Hxy mulr1. * by apply: sorted_cons => //=; rewrite mulr1 dvdr_mulr. * rewrite !unitmx_mul unit_Bezout_mx !unitmxE detmx2 /x /y mulNr opprK. by rewrite [_ * q]mulrC Hxy unitr1. by rewrite unitmxE detmx2 mulNr mulrN -opprD -mulN1r unitrMl ?unitrN1 // H unitr1. Qed. End Kaplansky_suff. Section Kaplansky_necc. Variable R : edrType. Variables a b c : R. Lemma kapP : gcdr a (gcdr b c) %= 1 -> exists p q, coprimer (p * a) (p * b + q * c). Proof. case: (smithP (mx2 a b 0 c))=> /= P d Q; rewrite -dvdr1. set D := diag_mx_seq _ _ _ => heq hsorted P_unitmx Q_unitmx Hgcd. exists (P 0 0); exists (P 0 1). suff [[x y /=]] : exists xy, xy.1 * (P 0 0 * a) + xy.2 * (P 0 0 * b + P 0 1 * c) %= 1. rewrite -unitd1; case/unitrP=> z [hz1 _]. by apply/coprimerP; exists (z*x,z*y); rewrite -!mulrA -mulrDr. exists (Q 0 0,Q 1 0)=> /=. suff : (D 0 0) \is a GRing.unit. rewrite -unitd1 -heq; do 2!(rewrite !mxE big_ord_recl big_ord1). rewrite big_ord_recl big_ord1 mx2_E00. have -> : lift 0 0 = 1 :> 'I_2 by apply/ord_inj. by rewrite mx2_E10 mx2_E11 mx2_E01 mulr0 addr0 mulrC [_ * Q 1 0]mulrC. rewrite unitd1 -dvdr1; apply/(dvdr_trans _ Hgcd). have Hij : forall i j, D 0 0 %| (mx2 a b 0 c) i j. rewrite (canRL (mulKmx P_unitmx) (canRL (mulmxK Q_unitmx) heq)). apply: dvdr_mulmxl; apply: dvdr_mulmxr=> i j; rewrite !mxE eqxx /=. case: eqP => _ /=; last by rewrite mulr0n dvdr0. by rewrite !mulr1n; exact: sorted_nth0. rewrite !dvdr_gcd; move: (Hij 0 0) (Hij 0 1) (Hij 1 1). by rewrite mx2_E00 mx2_E01 mx2_E11=> -> -> ->. Qed. End Kaplansky_necc. Section AdequacyGdco. Variable R : gcdDomainType. Variant adequate_spec (a b : R) : R -> Type := | AdequateSpec0 of b = 0 : adequate_spec a b 0 | AdequateSpec r of b != 0 & r %| b & coprimer r a & (forall d, d * r %| b -> d \isn't a GRing.unit -> ~~ coprimer d a) : adequate_spec a b r. Variant gdco_spec (a b : R) : R -> Type := | GdcoSpec0 of b = 0 : gdco_spec a b 0 | GdcoSpec r of b != 0 & r %| b & coprimer r a & (forall d, d %| b -> coprimer d a -> d %| r) : gdco_spec a b r. Lemma adequate_gdco a b r : adequate_spec a b r -> gdco_spec a b r. Proof. move=> [->|]; first by constructor => //; rewrite eqxx. move=> {}r b_neq0 dvd_rb cra /= Hs; constructor=> //=. move=> /= d dvd_db cda; have [du|dnu] := boolP (d \is a GRing.unit). by rewrite dvdUr ?eqd1. case: dvdrP dvd_rb => // [[s ->]] _ in Hs dvd_db *. rewrite -(@euclid _ s) // /coprimer 1?mulrC // -unitd1. apply: (contraLR (Hs _ _)); first by rewrite dvdr_mul // dvdr_gcdr. rewrite /coprimer -(eqd_ltrans (gcdrA _ _ _)). exact: coprimer_dvdr (dvdr_gcdr _ _) _. Qed. Lemma gdco_adequate a b r : gdco_spec a b r -> adequate_spec a b r. Proof. move=> [|/= {}r b_neq0 rb cra Hd]; first by constructor. constructor => //= d dr_dvd_b; apply: contra => cda. case: dvdrP rb => [[s ->]|//] {b} _ in Hd dr_dvd_b b_neq0 *. have r_neq0 : r != 0 by move: b_neq0; rewrite mulf_eq0 negb_or => /andP []. have := Hd _ dr_dvd_b. rewrite -[r as X in _ %| X]mul1r dvdr_mul2r // dvdr1 unitd1; apply. by rewrite coprimer_mull cra cda. Qed. End AdequacyGdco. Section AdequacyEDR. Variable R : bezoutDomainType. Variable gdco : R -> R -> R. Hypothesis gdcoP : forall p q, gdco_spec p q (gdco p q). Lemma coprimer_gdco q p : p != 0 -> coprimer (gdco q p) q. Proof. by case: gdcoP => [->|//]; rewrite eqxx. Qed. Definition gdco_kap (a b c : R) : R * R := let: (_, x, y, z, _, _, _) := egcdr3 a b c in if a == 0 then (y, z) else let: r := gdco c a in let: (g, _, v, _, _) := egcdr r c in if (1 - b) %/? g is Some k' then (1, k' * v) else (1, 0). Lemma gdco_kapP (a b c : R) : gcdr a (gcdr b c) %= 1 -> let: (p, q) := gdco_kap a b c in coprimer (p * a) (p * b + q * c). Proof. rewrite /gdco_kap /=. have [g /= x y z a1 b1 c1] := egcdr3P a b c. move=> Habc1 /eqd_ltrans <- Ha Hb Hc g_eq1. move: Habc1 g_eq1 => /(congr1 ( *%R^~ g)); rewrite !mulrDl mul1r. rewrite -!mulrA -Ha -Hb -Hc {Ha Hb Hc} => <- {g a1 b1 c1}. have [-> | an0 Habc] := eqVneq a 0. rewrite /coprimer !mulr0 add0r => Hbc. by rewrite (eqd_ltrans (gcd0r _)). case: egcdrP => /= g u v a' b' Hab' Hg Hc Hr. move: Hab' Hg => /(congr1 ( *%R^~ g)); rewrite mulrDl mul1r. rewrite -!mulrA -Hc -Hr {Hc Hr} => <- {a' b' g}. rewrite (eqd_rtrans (coprimer_gdco c an0)) => Hu. have: 1 %| 1 - b by rewrite dvd1r. rewrite -(eqd_dvdl _ Hu) /dvdr. case: odivrP => //= k' /(canRL (addrNK _)). rewrite mulrDr !mulrA addrAC !mul1r => Hk' _. rewrite /coprimer; set d := gcdr _ _. have cdc: coprimer d c. apply: gcdr_def; rewrite ?dvd1r // => t td tc. rewrite -(eqd_dvdr _ Habc) -addrA dvdr_add //. by rewrite dvdr_mull ?(dvdr_trans td) /d ?dvdr_gcdl. rewrite -[y * b](@addrNK _ (y * (b + k' * v * c))). rewrite {1}mulrDr opprD addrA subrr sub0r addrAC dvdr_add //; last first. by rewrite dvdr_mull // (dvdr_trans td) /d // dvdr_gcdr. by rewrite !mulrA addrC -mulrBl dvdr_mull. suff dr: d %| gdco c a. by rewrite -dvdr1 Hk' -addrA dvdr_add // /d ?dvdr_gcdr // dvdr_mull. case: gdcoP => /= [a_eq0|r a_neq0 ra crc]; first by rewrite a_eq0 eqxx in an0. by apply => //; rewrite dvdr_gcdl. Qed. Definition gdco_smith := smithmxn (kap_smith gdco_kap). Lemma gdco_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (gdco_smith M). Proof. rewrite /gdco_smith. by apply: smithmxnP; apply: kap_smithP; apply: gdco_kapP. Qed. End AdequacyEDR. HB.factory Record BezoutDomain_isAdequacyEDR R of BezoutDomain R := { gdco : R -> R -> R; gdcoP : forall p q, gdco_spec p q (gdco p q) }. HB.builders Context R of BezoutDomain_isAdequacyEDR R. HB.instance Definition _ := DvdRing_isEDR.Build R (gdco_smithP gdcoP). HB.end. HB.factory Record BezoutDomain_isKrull1EDR R of BezoutDomain R := { krull1 : forall a u : [the bezoutDomainType of R], exists m v, a %| u ^+ m * (1 - u * v) }. HB.builders Context R of BezoutDomain_isKrull1EDR R. Implicit Types a b u : [the bezoutDomainType of R]. Lemma krull1_factor a b : exists n b1 b2, [&& 0 < n, b == b1 * b2, coprimer b1 a & b2 %| a ^+ n]. Proof. wlog suff: / exists n b1 b2, [&& 0 < n, b %= b1 * b2, coprimer b1 a & b2 %| a ^+ n]. case=> n [b1 [b2 /and4P [Hn Hb Hb1 Hb2]]]. have [b2_eq0|b2_neq0] := eqVneq b2 0. exists n, b1, b2; move: Hn Hb Hb1 Hb2. by rewrite b2_eq0 mulr0 eqdr0 => -> -> -> ->. have : b2 %| b by rewrite (eqd_dvdr _ Hb) dvdr_mull. case: dvdrP Hb => [[b1' ->]|//]; rewrite eqd_mul2r // => eq_b1'. exists n, b1', b2; rewrite !eqxx Hn Hb2 /coprimer andbT /=. by rewrite (eqd_ltrans (eqd_gcd eq_b1' (eqdd _))). have kidem x : exists d (s : R) k, [&& 0 < d, b %| s ^+ 2 - s, b %| x ^+ d - (x ^+ d) * s & b %| s - k * x ^+ d]. have [m [y]] := krull1 b x. have [-> Hy|m_gt0 Hy] := posnP m. exists 1%N, 1, y; rewrite !expr1n mulr1 expr1 !subrr dvdr0 /=. by move: Hy; rewrite expr0 mul1r mulrC. set s := (x * y) ^+ m; exists m, s, (y ^+ m). have xsn n : b %| x ^+ m * (x * y) ^+ n - x ^+ m. elim: n => [|n ihn]; first by rewrite mulr1 subrr dvdr0. rewrite -[X in X - _](addrNK (x ^+ m * (x * y) ^+ n)) -addrA dvdr_add //. rewrite exprS mulrA -mulrBl dvdr_mulr //. by rewrite -dvdrN opprB -[X in X - _]mulr1 -mulrBr. have s_idem n : b %| s * (x * y) ^+ n - s. elim: n => [|n ihn]; first by rewrite mulr1 subrr dvdr0. rewrite -[X in X - _](addrNK (s * (x * y) ^+ n)) -addrA dvdr_add //. rewrite exprS mulrA -mulrBl dvdr_mulr //. rewrite /s -exprSr !exprMn exprSr exprS mulrA -mulrBl dvdr_mulr //. by rewrite -dvdrN opprB -{1}[x ^+ m]mulr1 -mulrA -mulrBr. rewrite m_gt0 (s_idem m) /= -opprB dvdrN (xsn m) /=. by rewrite mulrC -exprMn subrr dvdr0. have [d [s [k /and4P [d_gt0 s_idem ads ska]]]] := kidem a. set b1 := gcdr b (1 - s); set b2 := gcdr b s; exists d, b1, b2. have dvd_b2_bd: b2 %| a ^+ d. rewrite -[a ^+ d](addrNK (a ^+ d * s)) dvdr_add ?andbT //=; last 2 first. by rewrite (dvdr_trans (dvdr_gcdl _ _)) //. by rewrite dvdr_mull // dvdr_gcdr. have eq_b : b %= b1 * b2. rewrite eqd_def /b1 /b2. rewrite -[b as X in _ %| X](addrNK (b * s)). rewrite -[X in X - b * s]mulr1 -mulrBr dvdr_add ?andbT //=; last 2 first. by rewrite mulrC dvdr_mul // (dvdr_gcdl, dvdr_gcdr). by rewrite dvdr_mul // (dvdr_gcdl, dvdr_gcdr). have [[x y gbs] [x' y' gbs']] := (bezoutP b s, bezoutP b (1 - s)). rewrite (eqd_dvdr _ (eqd_mulr _ gbs')) (eqd_dvdr _ (eqd_mull _ gbs)). rewrite [1 - s]lock !(mulrDr, mulrDl) -!lock !addrA dvdr_add //=. by rewrite ![_ * b * _](mulrAC, mulrA) !mulrA -!mulrDl dvdr_mull. by rewrite mulrCA -mulrA dvdr_mull // dvdr_mull // mulrBl mul1r -opprB dvdrN. rewrite dvd_b2_bd eq_b d_gt0 andbT //=. have: coprimer b1 b2. apply: gcdr_def; rewrite ?dvd1r //= => p ps' ps. rewrite -[1](addrNK s) dvdr_add //. by rewrite (dvdr_trans ps') ?dvdr_gcdr. by rewrite (dvdr_trans ps) ?dvdr_gcdr. have b2_eq : gcdr b s %= gcdr b (a ^+ d). rewrite eqd_def !dvdr_gcd !dvdr_gcdl /=. rewrite -[a ^+ d as X in _ %| X](addrNK ((a ^+ d) * s)). rewrite dvdr_add //=; last 2 first. by rewrite (dvdr_trans (dvdr_gcdl _ _)). by rewrite dvdr_mull ?dvdr_gcdr. rewrite -[s as X in _ %| X](addrNK (k * (a ^+ d))) dvdr_add //. by rewrite (dvdr_trans (dvdr_gcdl _ _)). by rewrite dvdr_mull ?dvdr_gcdr. rewrite /b2 /coprimer (eqd_ltrans (eqd_gcd (eqdd _) b2_eq)). rewrite (eqd_ltrans (gcdrA _ _ _)). have gb1b: gcdr b1 b %= b1. rewrite eqd_def dvdr_gcdl dvdr_gcd dvdrr /=. by rewrite (eqd_dvdr _ eq_b) dvdr_mulr. rewrite (eqd_ltrans (eqd_gcd gb1b (eqdd _))). apply: coprimer_dvdr. by rewrite -[d]prednK // exprS dvdr_mulr. Qed. Lemma krull1_adequate a b : { r : R & adequate_spec a b r }. Proof. have [] := eqVneq b 0; first by exists 0; constructor. move: (krull1_factor a b) => factored. have /sigW : (exists (x : nat * (R * R)), [&& 0 < x.1, b == x.2.1 * x.2.2, coprimer x.2.1 a & x.2.2 %| a ^+ x.1]). by case: factored => n [b1 [b2]]; exists (n,(b1,b2)). case=> /= [[n [b1 b2]]] /= /and4P [ngt0 /eqP -> ca1b dvda2bn aneq0]. exists b1; constructor => /= [|||d] //; first by rewrite dvdr_mulr. rewrite mulrC dvdr_mul2l ?unitd1 => [dvdda2|]. apply: contra; rewrite -(@coprimer_pexpr _ n) //. apply: dvdr_coprime; exact: (dvdr_trans dvdda2 dvda2bn). by apply: contraNneq aneq0 => ->; rewrite mul0r. Qed. Definition krull1_gdco a b := projT1 (krull1_adequate a b). Lemma krull1_gdcoP a b : gdco_spec a b (krull1_gdco a b). Proof. rewrite /krull1_gdco; case: (krull1_adequate a b)=> r hr /=. exact: adequate_gdco. Qed. Definition krull1_smith := gdco_smith krull1_gdco. Lemma krull1_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (krull1_smith M). Proof. by apply: gdco_smithP=> a b; apply: krull1_gdcoP. Qed. HB.instance Definition _ := DvdRing_isEDR.Build R krull1_smithP. HB.end. Module AdequacyPID. Section AdequacyPID. Variable R : pidType. Implicit Types a b : R. Lemma pid_gdco a b : {r : R & gdco_spec a b r}. Proof. have [->|b_neq0] := eqVneq b 0; first by exists 0; constructor. elim: (sdvdr_wf b) => {}b _ ihp in b_neq0 *. have [cba|ncba] := boolP (coprimer a b). by exists b; constructor; rewrite ?cpa ?orbT // coprimer_sym. have := dvdr_gcdr a b; case: dvdrP => // [/choice.sig_eqW /= [r b_eq _]]. have := b_neq0; rewrite b_eq mulf_eq0 negb_or => /andP [r_neq0 g_neq0]. have [||r' r_gdco] // := ihp r. by rewrite sdvdr_def b_eq dvdr_mulr //= dvdr_mull_l. case: r_gdco r_neq0 => [->|/= {}r' _ dvdr'r cr'q r'P r_neq0]. by rewrite eqxx. exists r'; constructor; rewrite ?dvdr_mulr // -?b_eq //=. move=> d dp cdq; apply: r'P => //. rewrite -(@euclid _ (gcdr a b)) -?b_eq //. exact: coprimer_dvdr (dvdr_gcdl _ _) _. Qed. Definition pid_smith := gdco_smith (fun a b => projT1 (pid_gdco a b)). Lemma pid_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (pid_smith M). Proof. by rewrite /pid_smith; apply: gdco_smithP=> a b; case: (pid_gdco a b). Qed. #[non_forgetful_inheritance] HB.instance Definition _ := DvdRing_isEDR.Build R pid_smithP. (* This should be provable *) (* Lemma pri_krull1 (a : R) (u : R) : exists m v, a %| u ^+ m * (1 - u * v). *) (* Proof. *) (* admit. *) (* Qed. *) End AdequacyPID. End AdequacyPID. coqeal-2.1.0/theory/karatsuba.v000066400000000000000000000040641475512565300164550ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. From mathcomp Require Import zmodp path choice fintype tuple finset ssralg. From mathcomp Require Import bigop poly polydiv. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic. Section karatsuba. Variable R : ringType. Definition split_poly n (p : {poly R}) := (rdivp p 'X^n, rmodp p 'X^n). Definition shift_poly n : {poly R} -> {poly R} := *%R^~ 'X^n. Definition normalize (p : {poly R}) := p. Fixpoint karatsuba_rec (n : nat) (p q : {poly R}) := if n is n'.+1 then let np := normalize p in let nq := normalize q in let sp := size p in let sq := size q in if (sp <= 2) || (sq <= 2) then p * q else let m := minn sp./2 sq./2 in let (p1,p2) := split_poly m p in let (q1,q2) := split_poly m q in let p1q1 := karatsuba_rec n' p1 q1 in let p2q2 := karatsuba_rec n' p2 q2 in let p12 := p1 + p2 in let q12 := q1 + q2 in let p12q12 := karatsuba_rec n' p12 q12 in shift_poly (2 * m)%N p1q1 + shift_poly m (p12q12 - p1q1 - p2q2) + p2q2 else p * q. Definition karatsuba (p q : {poly R}) := karatsuba_rec (maxn (size p) (size q)) p q. Lemma karatsuba_recE n (p q : {poly R}) : karatsuba_rec n p q = p * q. Proof. elim: n=> //= n ih in p q *; case: ifP=> // _; set m := minn _ _. rewrite [p in RHS](rdivp_eq (monicXn _ m)) [q in RHS](rdivp_eq (monicXn _ m)). set dp := rdivp p _; set dq := rdivp q _; set rp := rmodp p _; set rq := rmodp q _. rewrite /shift_poly /split_poly !ih !(mulrDr, mulrDl, mulNr) mulnC exprM. rewrite -[_ - _ - _]addrA [_ + _ + (- _ - _)]addrACA [_ + _ - _]addrAC. by rewrite subrr add0r addrK !(commr_polyXn, mulrA, addrA). Qed. Lemma karatsubaE (p q : {poly R}) : karatsuba p q = p * q. Proof. exact: karatsuba_recE. Qed. End karatsuba. coqeal-2.1.0/theory/minor.v000066400000000000000000000223771475512565300156330ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path ssralg. From mathcomp Require Import fintype perm choice finfun matrix bigop zmodp poly mxpoly. Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope ring_scope. Section submatrix_def. Variable A B : Type. Definition submatrix T m n p q (f : 'I_p -> 'I_m) (g : 'I_q -> 'I_n) (M : 'M[T]_(m,n)) := \matrix_(i < p, j < q) M (f i) (g j). Lemma sub_submatrix k k' l l' m n (M : 'M[A]_(m,n)) (f' : 'I_k -> 'I_m) (f : 'I_k' -> 'I_k) (g' : 'I_l -> 'I_n) (g : 'I_l' -> 'I_l) : submatrix f g (submatrix f' g' M) = submatrix (f' \o f) (g' \o g) M. Proof. by rewrite /submatrix; apply/matrixP=> i j; rewrite !mxE. Qed. Lemma submatrix_map_mx (f : A -> B) m n p k (M : 'M[A]_(m,n)) (g : 'I_p -> 'I_m) (h : 'I_k -> 'I_n) : submatrix g h (map_mx f M) = map_mx f (submatrix g h M). Proof. by rewrite /submatrix; apply/matrixP=> i j; rewrite !mxE. Qed. End submatrix_def. Section lifting. Lemma widen_ord_eq (m n : nat) (h h' : n <= m) : widen_ord h =1 widen_ord h'. Proof. by move=> x; apply/ord_inj. Qed. (* transform [a .. b] into [0, a+1, .., b+1] *) Definition lift_pred m n (f : 'I_n -> 'I_m) : 'I_n.+1 -> 'I_m.+1 := fun (x : 'I_(1 + n)) => if split x is inr j then lift 0 (f j) else 0. Lemma size_tool n k : k <= n -> k < n.+1. Proof. by rewrite ltnS. Qed. (* lift step [ 0.. n-1] = [0 .. n ] *) Lemma lift_pred_widen_ord m n (h : n <= m) : lift_pred (widen_ord h) =1 widen_ord (size_tool h). Proof. rewrite /lift_pred => x; have [y hx|y hx] := splitP; apply/ord_inj => //=. by rewrite hx [y]ord1. Qed. Lemma lift_pred0 n k (f: 'I_k -> 'I_n) : lift_pred f 0 = 0. Proof. by rewrite /lift_pred; case: splitP. Qed. Lemma lift_predS n k (f : 'I_k -> 'I_n) (x : 'I_k) : lift_pred f (lift 0 x) = lift 0 (f x). Proof. by rewrite /lift_pred split1 liftK. Qed. (* Lemma step0 n (h : 1 <= n.+1) (x : 'I_1) : widen_ord h x = 0. *) (* Proof. by rewrite [x]ord1; apply/ord_inj. Qed. *) (* Lemma stepn n (h : n <= n) (x : 'I_n) : widen_ord h x = x. *) (* Proof. by apply/ord_inj. Qed. *) Lemma inj_lift m n (f : 'I_n -> 'I_m) : injective f -> injective (lift_pred f). Proof. rewrite /lift_pred => hf x y; rewrite !split1. have [/= j ->|->] := unliftP; last by have [|-> //] := unliftP. by have [/= i -> /lift_inj/hf ->|] := unliftP. Qed. Lemma inj_widen_ord n m (h : n <= m) : injective (widen_ord h). Proof. move => x y hxy. have /= {}hxy : widen_ord h x = widen_ord h y :> nat by rewrite hxy. by apply/ord_inj. Qed. End lifting. Section submatrix_theory. Variable R : ringType. Lemma submatrix_eq m n p q (f1 g1 : 'I_p -> 'I_m) (f2 g2 : 'I_q -> 'I_n) (M : 'M[R]_(m,n)) (h1 : f1 =1 g1) (h2 : f2 =1 g2) : submatrix f1 f2 M = submatrix g1 g2 M. Proof. by apply/matrixP => i j; rewrite !mxE (h1 i) (h2 j). Qed. Lemma submatrix_lift_block m n p q (f1 : 'I_p -> 'I_m) (f2 : 'I_q -> 'I_n) a (M: 'M[R]_(m,n)) (c : 'cV[R]_m) (l : 'rV[R]_n) : submatrix (lift_pred f1) (lift_pred f2) (block_mx a%:M l c M) = block_mx a%:M (submatrix id f2 l) (submatrix f1 id c) (submatrix f1 f2 M). Proof. apply/matrixP => i j; rewrite !mxE /lift_pred !split1. case: (oapp _ _ (unlift 0 i)) => x. rewrite unlift_none /= [x]ord1 !mxE !split1. case: (oapp _ _ (unlift 0 j)) => y; first by rewrite unlift_none [y]ord1. by rewrite liftK mxE. rewrite liftK /= !mxE !split1. case: (oapp _ _ (unlift 0 j)) => y; first by rewrite unlift_none mxE [y]ord1. by rewrite liftK mxE. Qed. Lemma submatrix0 n m p q (f1 : 'I_p -> 'I_m) (f2 : 'I_q -> 'I_n) : submatrix f1 f2 0 = 0 :> 'M[R]__. Proof. by apply/matrixP => i j; rewrite !mxE. Qed. Lemma submatrix_scale m n p k (A : 'M[R]_(m,n)) (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) a : submatrix f g (a *: A) = a *: submatrix f g A. Proof. by apply/matrixP => i j; rewrite !mxE. Qed. Lemma submatrix_add m n p k (A B : 'M[R]_(m,n)) (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : submatrix f g (A + B) = submatrix f g A + submatrix f g B. Proof. by apply/matrixP => i j; rewrite !mxE. Qed. Lemma submatrix_opp m n p k (A : 'M[R]_(m,n)) (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : submatrix f g (- A) = - submatrix f g A. Proof. by apply/matrixP => i j; rewrite !mxE. Qed. Lemma submatrix_sub m n p k (A B : 'M[R]_(m,n)) (f : 'I_p -> 'I_m) (g : 'I_k -> 'I_n) : submatrix f g (A - B) = submatrix f g A - submatrix f g B. Proof. by apply/matrixP => i j; rewrite !mxE. Qed. Lemma submatrix_mul m n p k l (A : 'M[R]_(m,n)) (B : 'M[R]_(n,p)) (f : 'I_k -> 'I_m) (g : 'I_l -> 'I_p): submatrix f g (A *m B) = (submatrix f id A) *m (submatrix id g B). Proof. apply/matrixP => i j; rewrite !mxE. by apply/eq_big => // x _; rewrite !mxE. Qed. Lemma submatrix_scalar_mx m p (f : 'I_p -> 'I_m) (hf : injective f) (a : R) : submatrix f f a%:M = a%:M. Proof. apply/matrixP => i j; rewrite !mxE. case h : (f i == f j); first by rewrite (hf _ _ (eqP h)) eqxx. by case h': (i == j) => //; move: h; rewrite (eqP h') eqxx. Qed. End submatrix_theory. (* This must be put in a new section as it uses the theory on submatrix *) Section submatrix_char_poly_mx. Variable R : ringType. Lemma submatrix_char_poly_mx m p (M : 'M[R]_m) (f : 'I_p -> 'I_m) (hf : injective f) : submatrix f f (char_poly_mx M) = char_poly_mx (submatrix f f M). Proof. by rewrite /char_poly_mx -submatrix_map_mx submatrix_sub submatrix_scalar_mx. Qed. End submatrix_char_poly_mx. (* Minors *) Section minor_def. Variable R : ringType. Definition minor (m n p : nat) (f : 'I_p -> 'I_m) (g : 'I_p -> 'I_n) (A : 'M[R]_(m,n)) := \det (submatrix f g A). (* Principal minor *) Definition pminor (m n p : nat) (h : p < m) (h' : p < n) (A : 'M[R]_(m,n)) := minor (widen_ord h) (widen_ord h') A. End minor_def. Arguments minor {R m n p} f g A. Section minor_theory. Variable R : comRingType. Lemma minor1 m n (A : 'M[R]_(m,n)) i j : minor (fun (_ : 'I_1) => i) (fun _ => j) A = A i j. Proof. by rewrite /minor [submatrix _ _ _]mx11_scalar det_scalar1 !mxE. Qed. Lemma minorn n (A : 'M[R]_n) : minor id id A = \det A. Proof. by rewrite /minor /submatrix; congr (\det _); apply/matrixP=> i j; rewrite mxE. Qed. Lemma det2 (A : 'M[R]_(2,2)) : \det A = A 0 0 * A 1 1 - A 1 0 * A 0 1. Proof. rewrite (expand_det_col _ 0) !big_ord_recl big_ord0 addr0 /cofactor /=. rewrite ?(addn0,expr0,mul1r) /bump leq0n /= addn0 expr1. do 2! rewrite [X in \det X]mx11_scalar det_scalar1 /=. by rewrite !mxE !mulNr mul1r mulrN; do ?f_equal; apply/ord_inj. Qed. (* Sanity check of the definiton *) Lemma minor2 m n (A : 'M[R]_(m,n)) (f : 'I_2 -> 'I_m) (g : 'I_2 -> 'I_n) : minor f g A = A (f 0) (g 0) * A (f 1) (g 1) - A (f 1) (g 0) * A (f 0) (g 1). Proof. by rewrite /minor det2 !mxE. Qed. Lemma minor_ltn_eq0l k m1 m2 n1 n2 x (f : 'I_k -> 'I_(m1 + m2)) g (M : 'M[R]_(m1,n1)) (N : 'M_(m1,n2)) (H : m1 < f x) : minor f g (block_mx M N 0 0) = 0. Proof. rewrite /minor (expand_det_row _ x) big1 // => i _; rewrite !mxE. case: splitP H => [j ->|j Hj]; first by rewrite ltnNge ltnW. by rewrite row_mx0 mxE mul0r. Qed. Lemma minor_ltn_eq0r k m1 m2 n1 n2 x f (g : 'I_k -> 'I_(n1 + n2)) (M : 'M[R]_(m1,n1)) (N : 'M_(m2,n1)) (H : n1 < g x) : minor f g (block_mx M 0 N 0) = 0. Proof. rewrite /minor (expand_det_col _ x) big1 // => i _; rewrite !mxE. by case: splitP=> j Hj; rewrite mxE; case: splitP H=> [l ->|l]; rewrite ?ltnNge ?mxE ?mul0r // ltnW. Qed. Lemma minor_alternate_f m n p (f : 'I_p -> 'I_m) g (M : 'M[R]_(m,n)) : (exists x y, (x != y) /\ (f x == f y)) -> minor f g M = 0. Proof. rewrite /minor => [[x [y [hxy /eqP hf]]]]. by rewrite (determinant_alternate hxy) // => a; rewrite !mxE hf. Qed. Lemma minor_alternate_g m n p (f : 'I_p -> 'I_m) g (M : 'M[R]_(m,n)) : (exists x y, (x != y) /\ (g x == g y)) -> minor f g M = 0. Proof. rewrite /minor => [[x [y [hxy /eqP hg]]]]. by rewrite -det_tr (determinant_alternate hxy) // => a /=; rewrite !mxE hg. Qed. Lemma minor_f_not_injective m n p (f : 'I_p -> 'I_m) g (M: 'M[R]_(m,n)) : ~ injective f -> minor f g M = 0. Proof. move/injectiveP/injectivePn => [x [y hxy hf]]; apply minor_alternate_f. by exists x, y; rewrite hf. Qed. Lemma minor_g_not_injective m n p (f : 'I_p -> 'I_m) g (M: 'M[R]_(m,n)) : ~ injective g -> minor f g M = 0. Proof. move/injectiveP/injectivePn => [x [y hxy hg]]; apply minor_alternate_g. by exists x, y; rewrite hg. Qed. Lemma minor_eq m n p (f1 g1 : 'I_p -> 'I_m) (f2 g2 : 'I_p -> 'I_n) (h1 : f1 =1 g1) (h2 : f2 =1 g2) (M : 'M[R]_(m,n)) : minor f1 f2 M = minor g1 g2 M. Proof. by rewrite /minor (submatrix_eq M h1 h2). Qed. Lemma minor_lift_block m n p (f1 : 'I_p -> 'I_m) (f2 : 'I_p -> 'I_n) a (M : 'M[R]_(m,n)) (l : 'rV[R]_n) : minor (lift_pred f1) (lift_pred f2) (block_mx a%:M l 0 M) = a * minor f1 f2 M. Proof. by rewrite /minor submatrix_lift_block submatrix0 (@det_ublock _ 1) det_scalar1. Qed. End minor_theory. Section minor_char_poly_mx. Variable R : comRingType. (* all principal minor of the characteristic matrix are monic *) Lemma pminor_char_poly_mx_monic m p (M : 'M[R]_m) (h h': p.+1 <= m) : pminor h h' (char_poly_mx M) \is monic. Proof. have h'h : widen_ord h' =1 widen_ord h by apply/widen_ord_eq. rewrite /pminor (minor_eq (frefl _) h'h) /minor submatrix_char_poly_mx. by rewrite char_poly_monic. exact: inj_widen_ord. Qed. End minor_char_poly_mx. coqeal-2.1.0/theory/mxstructure.v000066400000000000000000000566701475512565300171170ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm poly mxpoly finfun tuple. From mathcomp Require Import matrix bigop zmodp polydiv. Require Import ssrcomplements dvdring. (** This file contains three parts about different structures of matrices. *** Lower and upper triangular matrices : upper_triangular_mx M == The BOOLEAN predicate that hold if M is an upper traiangular matrix. lower_triangular_mx M == The same as upper_trianglar_mx but for lower triangular matrices. is_triangular_mx M == M is upper or lower triangular matrix. *** Block diagonal matrices : diag_block_mx s F == A block diagonal matrix where the ith block is F (nth 0 s i) i. F n i is a square matrix of dimension n.+1, and s is the sequence of dimension of each block minus 1. It is defined by calling recursivly the function block_mx. (size_sum s).+1 == It is the type of the matrix diag_block_mx s F. *** Diagonal matrices : diag_mx_seq m n s == A diagonal matrix of type 'M_(m,n) where the ith diagonal coefficient is the ith element of s. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (** Triangular Matrices *) Section Triangular. Local Open Scope ring_scope. Variable R : ringType. Definition upper_part_mx m n (M : 'M[R]_(m,n)) := \matrix_(i, j) (M i j *+ (i <= j)). Definition lower_part_mx m n (M : 'M[R]_(m,n)) := \matrix_(i, j) (M i j *+ (j <= i)). Definition upper_triangular_mx m n (M : 'M[R]_(m,n)) := M == upper_part_mx M. Lemma upper_triangular_mxP m n {M : 'M_(m,n)} : reflect (forall (i : 'I_m) (j : 'I_n), j < i -> M i j = 0) (upper_triangular_mx M). Proof. apply/(iffP eqP)=> [H i j Hij|H]. rewrite /upper_triangular_mx in H. by rewrite H mxE leqNgt Hij. apply/matrixP => i j; rewrite mxE leqNgt. by case/boolP: (j < i) => // /H ->. Qed. Definition lower_triangular_mx m n (M : 'M[R]_(m,n)) := M == lower_part_mx M. Definition is_triangular_mx m n (M : 'M[R]_(m,n)) := upper_triangular_mx M || lower_triangular_mx M. Lemma upper_triangular_mx0 m n : upper_triangular_mx (0 : 'M[R]_(m,n)). Proof. by apply/upper_triangular_mxP=> i j; rewrite mxE. Qed. Lemma lower_triangular_mxP m n (M : 'M[R]_(m,n)) : lower_triangular_mx M <-> upper_triangular_mx M^T. Proof. rewrite /lower_triangular_mx /upper_triangular_mx. rewrite /lower_part_mx /upper_part_mx. split=> [/eqP ->|/eqP H]; apply/eqP. by apply/matrixP=> i j; rewrite !mxE; case: leqP. by rewrite -[M]trmxK H; apply/matrixP=> i j; rewrite !mxE; case: leqP. Qed. End Triangular. Section TriangularBlock. Local Open Scope ring_scope. Variable R : ringType. Variables m1 m2 n1 n2 : nat. Variables (Aul : 'M[R]_(m1, n1)) (Aur : 'M[R]_(m1, n2)). Variables (Adl : 'M[R]_(m2, n1)) (Adr : 'M[R]_(m2, n2)). Lemma upper_triangular_block_mxdl : upper_triangular_mx (block_mx Aul Aur Adl Adr) -> n1 <= m1 -> Adl = 0. Proof. move=> HA Hn1. apply/matrixP=> i j. transitivity (block_mx Aul Aur Adl Adr (rshift m1 i) (lshift n2 j)). by rewrite block_mxEdl. rewrite (upper_triangular_mxP HA) ?mxE //=. by apply/ltn_addr/(leq_trans (ltn_ord j)). Qed. Lemma upper_triangular_block_mxdr : upper_triangular_mx (block_mx Aul Aur Adl Adr) -> n1 <= m1 -> upper_triangular_mx Adr. Proof. move=> /upper_triangular_mxP HA Hn1; apply/upper_triangular_mxP=> i j Hij. rewrite -(HA (rshift m1 i) (rshift n1 j)) ?block_mxEdr // -addnS. exact: leq_add. Qed. Lemma upper_triangular_block_mxul : upper_triangular_mx (block_mx Aul Aur Adl Adr) -> upper_triangular_mx Aul. Proof. move=> /upper_triangular_mxP HA; apply/upper_triangular_mxP=> i j Hij. by rewrite -(HA (lshift m2 i) (lshift n2 j)) ?block_mxEul. Qed. Lemma upper_triangular_block : upper_triangular_mx Aul -> upper_triangular_mx Adr -> m1 <= n1 -> upper_triangular_mx (block_mx Aul 0 0 Adr). Proof. move=> /upper_triangular_mxP HAul /upper_triangular_mxP HAdr H. apply/upper_triangular_mxP=> i j Hij; rewrite !mxE. case: splitP=> k Hk; rewrite !mxE; case: splitP=> l Hl; rewrite ?mxE //. by apply: HAul; rewrite -Hk -Hl. apply: HAdr; rewrite -(ltn_add2l m1) -Hk. rewrite Hl in Hij; apply: (leq_ltn_trans _ Hij). by rewrite leq_add2r. Qed. End TriangularBlock. Section SquareTriangular. Local Open Scope ring_scope. Variable R : comRingType. Lemma det_triangular_mx : forall n (M : 'M[R]_n), upper_triangular_mx M -> \det M = \prod_i M i i. Proof. elim=> [M _|n IHn]; first by rewrite det_mx00 big_ord0. rewrite -[n.+1]add1n=> M. rewrite -(submxK M)=> HM. rewrite (upper_triangular_block_mxdl HM) // det_ublock IHn. rewrite {1}[ulsubmx M]mx11_scalar det_scalar1 big_split_ord big_ord1. by rewrite block_mxEul; congr *%R; apply:eq_bigr=> i _; rewrite block_mxEdr. exact: (upper_triangular_block_mxdr HM). Qed. Lemma char_poly_mx_triangular_mx n (M : 'M[R]_n) : upper_triangular_mx M -> upper_triangular_mx (char_poly_mx M). Proof. move/upper_triangular_mxP=> HM; apply/upper_triangular_mxP=>i j Hij. rewrite !mxE. suff /negbTE->/=: i != j by rewrite (HM i j Hij) GRing.subr0. by move: Hij; rewrite ltn_neqAle eq_sym; case/andP. Qed. Lemma row'_col'_triangular_mx n (M : 'M[R]_n) i: upper_triangular_mx M -> upper_triangular_mx (row' i (col' i M)). Proof. move/upper_triangular_mxP=> HM; apply/upper_triangular_mxP=> j k Hij. rewrite !mxE HM // /lift /= /bump /ltn -addn1 -addnA addn1. apply: leq_add=> //; case H: (i <= k)=> //=. by rewrite (ltnW (leq_ltn_trans H Hij)). Qed. End SquareTriangular. Section SquareTriangular2. Local Open Scope ring_scope. Variable R : comRingType. Lemma char_poly_triangular_mx n (M : 'M[R]_n) : upper_triangular_mx M -> char_poly M = \prod_i ('X - (M i i)%:P). Proof. move=> Ht; rewrite /char_poly det_triangular_mx ?char_poly_mx_triangular_mx //. by apply: eq_bigr=> i _; rewrite !mxE eqxx. Qed. End SquareTriangular2. (** Block Diagonal Matrices *) Section diag_block_ringType. Variable R : ringType. Local Open Scope ring_scope. Import GRing.Theory. Fixpoint size_sum_rec k (s : seq nat) : nat := if s is x :: l then (k + (size_sum_rec x l).+1)%N else k. Fixpoint diag_block_mx_rec k (s : seq nat) (F : (forall n, nat -> 'M[R]_n.+1)) := if s is x :: l return 'M_((size_sum_rec k s).+1) then block_mx (F k 0%N) 0 0 (diag_block_mx_rec x l (fun n i => F n i.+1)) else F k 0%N. Definition size_sum s := if s is x :: l then size_sum_rec x l else 0%N. Definition diag_block_mx s F := if s is x :: l return 'M_((size_sum s).+1) then diag_block_mx_rec x l F else 0. Lemma size_sum_big_cons : forall s x, (size_sum (x :: s)).+1 = (\sum_(k <- x :: s) k.+1)%N. Proof. elim=> [s|n s IHn x] /=; rewrite big_cons. by rewrite big_nil addn0. by rewrite IHn. Qed. Lemma size_sum_big s : s != [::] -> (size_sum s).+1 = (\sum_(k <- s) k.+1)%N. Proof. by case: s=> // a l _; rewrite size_sum_big_cons. Qed. Lemma ext_block s (F1 F2 : forall n, nat -> 'M_n.+1) : (forall i, i < size s -> (F1 (nth 0%N s i) i) = (F2 (nth 0%N s i) i)) -> diag_block_mx s F1 = diag_block_mx s F2. Proof. case: s=> // a l. elim: l a F1 F2=> /= [a F1 F2 Hi|b l IHl a F1 F2 Hi]. exact: (Hi 0%N). set F3 := (fun n i : nat => _). set F4 := (fun n i : nat => _). rewrite (Hi 0%N) // (IHl b F3 F4) //. by move=> i Hi2; apply: (Hi i.+1). Qed. Lemma upper_triangular_diag_block (s : seq nat) (F : (forall n, nat -> 'M[R]_n.+1)) : (forall j, upper_triangular_mx (F (nth 0%N s j) j)) -> upper_triangular_mx (diag_block_mx s F). Proof. case: s=>[_|a l]; first exact: upper_triangular_mx0. elim: l a F=> /= [a F H|b l IHl a F H]; first exact: (H 0%N). apply: (@upper_triangular_block _ a.+1 _ a.+1)=> //. exact: (H 0%N). by apply: IHl=> j; apply: (H j.+1). Qed. Lemma scalar_diag_block_mx c s (F : forall n, nat -> 'M_n.+1) : s != [::] -> (forall i, i < size s -> F (nth 0%N s i) i = c%:M ) -> diag_block_mx s F = c%:M. Proof. case: s => // x s _. elim: s x F=> /= [a F Hi| b l IHl a F Hi]. exact: (Hi 0%N). rewrite (Hi 0%N) // IHl -?scalar_mx_block // => i Hi2. exact: (Hi i.+1). Qed. Lemma diag_block_mx0 s (F : forall n, nat -> 'M_n.+1) : (forall i, i < size s -> F (nth 0%N s i) i = 0) <-> diag_block_mx s F = 0. Proof. split; case: s=> //a l Hi. rewrite -(scale0r 1%:M) scalemx1. apply: scalar_diag_block_mx=> // i H. by rewrite Hi // -(scale0r 1%:M) scalemx1. elim: l a F Hi => /= [a F Ha i|b l Ihl a F]. by rewrite ltnS leqn0=> /eqP ->. rewrite {3}/GRing.zero /= -(@block_mx_const _ a.+1 _ a.+1)=> Ha. have [HFa _ _ H] := (@eq_block_mx _ _ _ _ _ (F a 0%N) _ _ _ _ _ _ _ Ha). by case=> // i Hi; apply: (Ihl b _ H). Qed. Lemma add_diag_block s F1 F2 : diag_block_mx s F1 + diag_block_mx s F2 = diag_block_mx s (fun n i => F1 n i + F2 n i). Proof. case: s=> [|a l]; first by rewrite addr0. elim: l a F1 F2=> //= b l IHl a F1 F2. by rewrite -IHl (add_block_mx (F1 a 0%N)) !addr0. Qed. Lemma mulmx_diag_block s F1 F2 : diag_block_mx s F1 *m diag_block_mx s F2 = diag_block_mx s (fun n i => F1 n i *m F2 n i). Proof. case: s=>[|a l]; first by rewrite mulmx0. elim: l a F1 F2=> //= b l IHl a F1 F2. rewrite -IHl (mulmx_block (F1 a 0%N) 0 0 _ (F2 a 0%N)). by rewrite !mul0mx !mulmx0 addr0 !add0r. Qed. Lemma exp_diag_block_S s F k : (diag_block_mx s F)^+ k.+1 = diag_block_mx s (fun n i => (F n i)^+ k.+1). Proof. case: s=>[|a l]; first by rewrite expr0n /=. elim: l a F=> //= b l IHl a F. by rewrite -IHl exp_block_mx. Qed. Lemma exp_diag_block_cons s F k : s != [::] -> (diag_block_mx s F)^+ k = diag_block_mx s (fun n i => (F n i)^+ k). Proof. case: s=> // x s _. elim: s x F => //= a l IHl x F. by rewrite -IHl exp_block_mx. Qed. Lemma tr_diag_block_mx s F : (diag_block_mx s F)^T = diag_block_mx s (fun n i => (F n i)^T). Proof. case: s=> [|a l] /=; first by rewrite trmx0. elim: l a F=> //= b l IHl a F. by rewrite (tr_block_mx (F a 0%N)) !trmx0 IHl. Qed. End diag_block_ringType. Section diag_block_ringType2. Variable R : ringType. Local Open Scope ring_scope. Import GRing.Theory. Lemma char_diag_block_mx s (F : forall n, nat -> 'M[R]_n.+1) : s != [::] -> char_poly_mx (diag_block_mx s F) = diag_block_mx s (fun n i => char_poly_mx (F n i)). Proof. case: s=> //= a l _. elim: l a F=> //= b l IHl a F. by rewrite -IHl -char_block_mx. Qed. End diag_block_ringType2. Section diag_block_comRingType. Variable R : comRingType. Local Open Scope ring_scope. Import GRing.Theory. Lemma det_diag_block s (F : forall n, nat -> 'M[R]_n.+1) : s != [::] -> \det (diag_block_mx s F) = \prod_(i < size s) \det (F (nth 0%N s i) i). Proof. case: s=> // n s _. elim: s n F=>[n F|a l IHl n F] /=. by rewrite big_ord_recl big_ord0 mulr1 /=. by rewrite (det_ublock (F n 0%N)) big_ord_recl IHl. Qed. Lemma horner_mx_diag_block (p : {poly R}) s F : s != [::] -> horner_mx (diag_block_mx s F) p = diag_block_mx s (fun n i => horner_mx (F n i) p). Proof. case: s=> // x s _. elim/poly_ind: p. rewrite rmorph0; apply: esym; apply/diag_block_mx0=> // i _. by rewrite rmorph0. move=> p c IHp. set s1 := _ :: _. set F1 := fun n i => _ _ (_ + _). pose F2 := fun n i => horner_mx (F n i) p *m (F n i) + horner_mx (F n i) c%:P. have Hi: forall i, i < size s1 -> F1 (nth 0%N s1 i) i = F2 (nth 0%N s1 i) i. by move=> i _; rewrite /F1 /F2 rmorphD rmorphM /= horner_mx_X. rewrite (ext_block Hi) /F2 -add_diag_block -mulmx_diag_block. rewrite rmorphD rmorphM /=. rewrite horner_mx_X horner_mx_C IHp. set F3 := fun n i => _ _ c%:P. rewrite -(@scalar_diag_block_mx _ c (x :: s) F3) // => i Hi2. by rewrite /F3 horner_mx_C. Qed. End diag_block_comRingType. Section diag_block_comUnitRingType. Variable R : comUnitRingType. Local Open Scope ring_scope. Import GRing.Theory. Lemma unitmx_diag_block s (F : forall n, nat -> 'M[R]_n.+1) : s != [::] -> (forall i, i < size s -> (F (nth 0%N s i) i) \in unitmx) -> (diag_block_mx s F) \in unitmx. Proof. case: s=> // a l _ H. have Ha: (F a 0%N) \in unitmx by exact: (H 0%N). elim: l a F Ha H=> //= b l IHl a F Ha H. rewrite unitmxE (det_ublock (F a 0%N)) unitrM -!unitmxE Ha /=. apply: IHl=> [|i]; first exact: (H 1%N). exact: (H i.+1). Qed. Lemma invmx_diag_block s (F : forall n, nat -> 'M[R]_n.+1) : (diag_block_mx s F) \in unitmx -> (diag_block_mx s F)^-1 = diag_block_mx s (fun n i => (F n i)^-1). Proof. case: s=> [|a l]; first by rewrite unitr0. elim: l a F => //= b l IHl a F H. rewrite invmx_block // IHl //. by move: H; rewrite !unitmxE (det_ublock (F a 0%N)) unitrM; case/andP. Qed. End diag_block_comUnitRingType. (** Diagonal Matrices *) Section diag_mx_seq. Variable R : ringType. Local Open Scope ring_scope. Import GRing.Theory. Definition diag_mx_seq m n (s : seq R) := \matrix_(i < m, j < n) (s`_i *+ (i == j :> nat)). Lemma diag_mx_seq_nil m n : diag_mx_seq m n [::] = 0. Proof. by apply/matrixP=> i j; rewrite !mxE nth_nil mul0rn. Qed. Lemma diag_mx_seq_cons m n x (s : seq R) : diag_mx_seq (1 + m) (1 + n) (x :: s) = block_mx x%:M 0 0 (diag_mx_seq m n s). Proof. apply/matrixP => i j; rewrite !mxE. by case: splitP => i' ->; rewrite mxE; case:splitP => j' ->; rewrite mxE ?ord1. Qed. Lemma diag_mx_seq_cat m1 m2 n1 n2 (s1 s2 : seq R) : size s1 = m1 -> size s1 = n1 -> diag_mx_seq (m1 + m2) (n1 + n2) (s1 ++ s2) = block_mx (diag_mx_seq m1 n1 s1) 0 0 (diag_mx_seq m2 n2 s2). Proof. elim: s1 s2 m1 n1=> [s2 m1 n1 Hn1 Hn2|a s1 IHs1 s2 m1 n1 /eqP Hm1 /eqP Hn1]. by rewrite /block_mx -Hn1 -Hn2 !row_thin_mx col_flat_mx. case:m1 Hm1 IHs1=> // m1 Hm1 IHs1; case:n1 Hn1 IHs1=> // n1 Hn1 IHs1. rewrite diag_mx_seq_cons IHs1; apply/eqP=> //; rewrite diag_mx_seq_cons. by rewrite -row_mx0 -col_mx0 block_mxA castmx_id row_mx0 col_mx0. Qed. Lemma diag_mx_seq_block_mx m m' n n' s : size s <= minn m n -> diag_mx_seq (m + m') (n + n') s = block_mx (diag_mx_seq m n s) 0 0 0. Proof. move=> H; apply/matrixP=> i j; rewrite !mxE. case: (splitP _)=> k Hk; rewrite mxE; case: (splitP _)=> l Hl; rewrite mxE Hk Hl //. + case: eqP => //= ->. rewrite nth_default ?mul0rn // (leq_trans H) //. by rewrite geq_min leq_addr orbT. + rewrite nth_default ?mul0rn // (leq_trans H) //. by rewrite geq_min leq_addr. rewrite nth_default ?mul0rn // (leq_trans H) //. by rewrite geq_min leq_addr. Qed. Lemma diag_mx_seq_block s : let l := nseq (size s) 0%N in let F := (fun n i => (@scalar_mx _ n.+1 s`_i)) in diag_mx_seq (size_sum l).+1 (size_sum l).+1 s = diag_block_mx l F. Proof. case: s=> /= [|a l]; first by rewrite diag_mx_seq_nil. have Ha: forall a, diag_mx_seq 1 1 [:: a] = a%:M. by move=> b; apply/matrixP=> i j; rewrite !mxE ord1. elim: l a=> //= b l IHl a. by rewrite -IHl -cat1s (@diag_mx_seq_cat 1 _ 1) // Ha. Qed. Lemma diag_block_mx_seq s (F : forall n, nat -> 'M_n.+1) : let n := size_sum s in let l := mkseq (fun i => (F 0%N i) ord0 ord0) (size s) in (forall i, nth 0%N s i = 0%N) -> diag_block_mx s F = diag_mx_seq n.+1 n.+1 l. Proof. move=> /= Hs. set s1 := mkseq _ _. have ->: s = nseq (size s1) 0%N. apply: (@eq_from_nth _ 0%N); first by rewrite size_mkseq size_nseq. by move=> i Hi; rewrite Hs nth_nseq size_mkseq Hi. rewrite diag_mx_seq_block. apply: ext_block=> i; rewrite size_nseq size_mkseq => Hi. rewrite nth_nseq Hi nth_mkseq //. by apply/matrixP=> k l; rewrite !mxE !ord1. Qed. Lemma diag_mx_seq_deltal m n (i : 'I_m) (j : 'I_n) (s : seq R) : delta_mx i j *m diag_mx_seq n n s = s`_j *: delta_mx i j. Proof. apply/matrixP=> k l; rewrite !mxE (bigD1 l) //= big1 ?addr0. rewrite !mxE eqxx; case: (eqVneq l j)=>[->/=|_]; last by rewrite andbF mulr0 mul0r. by rewrite andbT; case: eqP=> _; [rewrite mulr1 mul1r | rewrite mulr0 mul0r]. move=> p; rewrite !mxE=> /negbTE; rewrite (inj_eq (@ord_inj _))=> ->. by rewrite mulr0. Qed. Lemma diag_mx_seq_deltar m n (i : 'I_m) (j : 'I_n) (s : seq R) : diag_mx_seq m m s *m delta_mx i j = s`_i *: delta_mx i j. Proof. apply/matrixP=> k l; rewrite !mxE (bigD1 k) //= big1 ?addr0. rewrite !mxE eqxx; case: (eqVneq k i)=>[->/=|_]; last by rewrite !mulr0. by case: eqP. move=> p; rewrite !mxE=> /negbTE; rewrite (inj_eq (@ord_inj _)) eq_sym=> ->. by rewrite mul0r. Qed. Lemma diag_mx_seq_takel m n (s : seq R) : diag_mx_seq m n (take m s) = diag_mx_seq m n s. Proof. by apply/matrixP=> i j; rewrite !mxE nth_take. Qed. Lemma diag_mx_seq_taker m n (s : seq R) : diag_mx_seq m n (take n s) = diag_mx_seq m n s. Proof. apply/matrixP=> i j; rewrite !mxE. by case: eqP => //=->; rewrite nth_take. Qed. Lemma diag_mx_seq_take_min m n (s : seq R) : diag_mx_seq m n (take (minn m n) s) = diag_mx_seq m n s. Proof. by case: leqP; rewrite (diag_mx_seq_takel, diag_mx_seq_taker). Qed. Lemma tr_diag_mx_seq m n s : (diag_mx_seq m n s)^T = diag_mx_seq n m s. Proof. apply/matrixP=> i j; rewrite !mxE eq_sym. by case: eqP => //=->. Qed. Lemma mul_pid_mx_diag m n p r s : r <= p -> @pid_mx R m p r *m diag_mx_seq p n s = diag_mx_seq m n (take r s). Proof. move=> le_r_p; apply/matrixP=> i j; rewrite !mxE. have [le_p_i | lt_i_p] := leqP p i. rewrite big1; last first. by move=> k _; rewrite !mxE eqn_leq leqNgt (leq_trans (ltn_ord k)) // mul0r. rewrite nth_default ?mul0rn // size_take. case: ltnP=> [_|le_s_r]; first exact: (leq_trans le_r_p). by apply: (leq_trans le_s_r); exact: (leq_trans le_r_p). rewrite (bigD1 (Ordinal lt_i_p)) //= !mxE big1; last first. by move=> k; rewrite /eq_op /= => neq_k_i; rewrite !mxE eq_sym (negbTE neq_k_i) mul0r. rewrite eqxx addr0 /=. have [lt_i_r | le_r_i] := ltnP i r; first by rewrite nth_take // mul1r. rewrite mul0r nth_default ?mul0rn // size_take; case:ltnP=> // le_s_r. exact: (leq_trans le_s_r). Qed. Lemma diag_mx_seq0 m n s : all (eq_op^~ 0) s -> diag_mx_seq m n s = 0. Proof. elim: s m n=> [m n _|a s ih m n] /=; first by rewrite diag_mx_seq_nil. case/andP=> /eqP -> hA. case: m n=> [n|m [|n]]; [by apply/matrixP=> [[]]|by apply/matrixP=> i []|]. rewrite diag_mx_seq_cons ih //; apply/matrixP=> i j. by do 2!(rewrite !mxE split1; case: unliftP=> * /=); rewrite mxE. Qed. Lemma diag_mx_seq_eq0 m n s : size s <= minn m n -> diag_mx_seq m n s = 0 -> all (eq_op^~ 0) s. Proof. rewrite leq_min; case/andP=> hsn hsm. move/matrixP=> H; apply/(all_nthP 0)=> i hi; apply/eqP. set jn := Ordinal (leq_trans hi hsn); set jm := Ordinal (leq_trans hi hsm). by move: (H jn jm); rewrite !mxE eqxx. Qed. Lemma diag_mx_seq_scale m n s (d : R) : d *: diag_mx_seq m n s = diag_mx_seq m n [seq d * x | x <- s]. Proof. apply/matrixP=> i j; rewrite !mxE. case: eqP => _ /=; last by rewrite !mulr0n mulr0. have [hi|hl] := (ltnP i (size s)); first by rewrite (@nth_map _ 0). by rewrite ?nth_default ?mulr0 // size_map. Qed. End diag_mx_seq. Section diag_mx_seq2. Variable R : ringType. Local Open Scope ring_scope. Import GRing.Theory. Lemma mul_diag_mx_pid m n p r s : r <= p -> diag_mx_seq m p s *m @pid_mx R p n r = diag_mx_seq m n (take r s). Proof. move=> le_r_p; rewrite -[_ *m _]trmxK trmx_mul_rev tr_pid_mx tr_diag_mx_seq. by rewrite mul_pid_mx_diag // tr_diag_mx_seq. Qed. Lemma mul_diag_mx_copid m n r s : minn (minn m n) (size s) <= r -> diag_mx_seq m n s *m @copid_mx R n r = 0. Proof. move=> le_s_r; apply/matrixP=> i j; rewrite !mxE big1 // => k _; rewrite !mxE. case: eqP => /= [eq_i_k|]; last by rewrite mul0r. have [le_s_k|lt_k_s] := leqP (size s) k. by rewrite eq_i_k nth_default // mul0rn mul0r. suff ->/= : k < r by rewrite andbT eqE /= subrr mulr0. by apply: (leq_trans _ le_s_r); rewrite !leq_min lt_k_s -{1}eq_i_k !ltn_ord. Qed. End diag_mx_seq2. Section diag_mx_seq_comRingType. Variable R : comRingType. Local Open Scope ring_scope. Import GRing.Theory. (* Why is this not in the ssr libraries? *) Lemma tr_copid_mx m r : (copid_mx r)^T = @copid_mx R m r. Proof. apply/matrixP=> i j; rewrite !mxE eq_sym. case: eqP=> [->|/eqP hij] //=; rewrite eq_sym. by have -> : (i == j :> nat) = false by apply/eqP/eqP. Qed. Lemma mul_copid_mx_diag m n r s : minn (minn m n) (size s) <= r -> @copid_mx R n r *m diag_mx_seq n m s = 0. Proof. move=> le_s_r. rewrite -[_ *m _]trmxK trmx_mul tr_diag_mx_seq tr_copid_mx. by rewrite mul_diag_mx_copid // trmx0. Qed. Lemma det_diag_mx_seq_truncated m (s : seq R) : \det (diag_mx_seq m m s) = (\prod_(i <- take m s) i) *+ (m <= size s). Proof. elim: s m=> [[|m]|a l IHl [|m]]; rewrite ?det_mx00 ?leq0n ?take0 ?big_nil //. by rewrite diag_mx_seq_nil det0. rewrite big_cons ltnS diag_mx_seq_cons (@det_ublock _ 1 m). by rewrite IHl det_scalar expr1 mulrnAr. Qed. Lemma det_diag_mx_seq m (s : seq R) : size s = m -> \det (diag_mx_seq m m s) = \prod_(i <- s) i. Proof. by move=> <-; rewrite det_diag_mx_seq_truncated take_size // leqnn. Qed. End diag_mx_seq_comRingType. Section diag_mx_idomain. Variable R : idomainType. Local Open Scope ring_scope. Import GRing.Theory. Lemma mul_mx_diag_seq_min m r (s : seq R) (A : 'M_(m, r)) (B : 'M_(r, m)) : all (predC1 0) s -> m <= size s -> A *m B = diag_mx_seq _ _ s -> m <= r. Proof. move=> neq0_s le_m_s ABd; rewrite leqNgt; apply/negP=> /subnKC; rewrite addSnnS. move: (_ - _)%N => m' def_m; move: le_m_s ABd; rewrite -{m}def_m in A B *. rewrite -(vsubmxK A) -(hsubmxK B) mul_col_row => le_m_s. have lt_r_s: r < size s. by move: le_m_s; rewrite addnS; apply:leq_ltn_trans; exact: leq_addr. rewrite -[s](cat_take_drop r) diag_mx_seq_cat ?size_take ?lt_r_s //. case/eq_block_mx=> AuBld AuBr0 AdBl0 AdBrd. have detBl0: \det (lsubmx B) = 0. apply/eqP/det0P; exists (nz_row (dsubmx A)). rewrite nz_row_eq0; apply/eqP=> Ad0; move/matrixP/(_ 0 0):AdBrd. rewrite Ad0 mul0mx !mxE nth_drop addn0. move/(all_nthP 0)/(_ r)/(_ lt_r_s): neq0_s. by rewrite mulr1n /= eq_sym; move/eqP. rewrite /nz_row; case:pickP=> /= [i|_]; last by rewrite mul0mx. by rewrite -row_mul AdBl0 row0. have: \det (diag_mx_seq r r (take r s)) = 0. by rewrite -AuBld det_mulmx detBl0 mulr0. rewrite det_diag_mx_seq ?size_take ?lt_r_s // => /eqP; rewrite prodf_seq_eq0 /=. apply/negP; move: neq0_s; rewrite -{1}[s](cat_take_drop r) all_cat -all_predC. by case/andP. Qed. Lemma mul_diag_mx_seq_eq0 m n p (M : 'M[R]_(m,n)) s : (forall i, i < size s -> s`_i != 0) -> (M *m diag_mx_seq n p s == 0) -> (M *m @pid_mx R n p (size s) == 0). Proof. move=> s_i_eq0 /eqP /matrixP HM. apply/eqP/matrixP=> i j; move: (HM i j); rewrite !mxE. have [le_nj|lt_nj] := leqP n j. move=> _; rewrite big1 // => k _. by rewrite mxE ltn_eqF ?mulr0 // (leq_trans _ le_nj). rewrite (bigD1 (Ordinal lt_nj)) // !mxE /= eqxx mulr1n. rewrite big1 ?addr0; last first. move=> k; rewrite -val_eqE /= => neq_k_j. by rewrite mxE (negPf neq_k_j) mulr0n mulr0. rewrite (bigD1 (Ordinal lt_nj)) // !mxE /= eqxx. rewrite big1 ?addr0 /=; last first. move=> k; rewrite -val_eqE /= => neq_k_j. by rewrite mxE (negPf neq_k_j) mulr0n mulr0. have [small_j|big_j] := ltnP; last by rewrite mulr0. by move/eqP; rewrite mulf_eq0 (negPf (s_i_eq0 _ _)) ?orbF //= ?mulr1 => /eqP. Qed. End diag_mx_idomain. Section diag_mx_dvdring. Variable R : dvdRingType. Local Open Scope ring_scope. Lemma diag_mx_seq_filter0 m n (s : seq R) : sorted %|%R s -> diag_mx_seq m n [seq x <- s | x != 0] = diag_mx_seq m n s. Proof. elim: s m n=> // a s ih m n h_sorted. have h_s /= := subseq_sorted (@dvdr_trans R) (subseq_cons s a) h_sorted. move: h_sorted; have [-> hs |an0 _] /= := eqP. by rewrite ih // !diag_mx_seq0 //= ?eqxx /=; apply/sorted_dvd0r. case: m n=> [n|m [|n]]; [by apply/matrixP=> [[]]|by apply/matrixP=> i []|]. by rewrite !diag_mx_seq_cons ih. Qed. End diag_mx_dvdring. coqeal-2.1.0/theory/perm_eq_image.v000066400000000000000000000154761475512565300173030ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect all_algebra. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section seq_eqType. Variable T1 : eqType. Lemma sorted_trans (leT1 leT2 : rel T1) s : {in s &, (forall x y, leT1 x y -> leT2 x y)} -> sorted leT1 s -> sorted leT2 s. Proof. elim: s=> // a [] //= b l IHl leT12 /andP [leT1ab pleT1]. rewrite leT12 ?inE ?eqxx ?orbT // IHl // => x y xbcl ybcl leT1xy. by rewrite leT12 // mem_behead. Qed. End seq_eqType. Section FinType. Lemma enum_ord_enum n : enum 'I_n = ord_enum n. Proof. by rewrite enumT unlock. Qed. End FinType. Section Finfun. Variables (aT : finType) (rT : eqType). Variables (f g : aT -> rT). Variable (P : pred aT). Hypothesis (Hf : injective f) (Hg : injective g). Lemma uniq_image (h : aT -> rT): injective h -> uniq (image h P). Proof. by move/map_inj_uniq=> ->; rewrite enum_uniq. Qed. Lemma perm_eq_image : {subset (image f P) <= (image g P)} -> perm_eq (image f P) (image g P). Proof. move=> imfsubimg. rewrite uniq_perm // ?uniq_image //. have []:= (uniq_min_size (uniq_image Hf) imfsubimg)=> //. by rewrite !size_map. Qed. End Finfun. Section BigOp. Variables (T : Type) (idx : T) (op : Monoid.com_law idx). Lemma sumn_big s : sumn s = (\sum_(i <- s) i)%N. Proof. elim: s=> /= [|a l ->]; first by rewrite big_nil. by rewrite big_cons. Qed. (***Not in bigop.v and I not found a short way to prove this. ****) Lemma big_lift_ord n F j : \big[op/idx]_( i < n.+1 | j != i ) F i = \big[op/idx]_i F (lift j i). Proof. case: (pickP 'I_n) => [k0 _ | n0]; last first. by rewrite !big1 // => [i _ | k /unlift_some[i]]; have:= n0 i. rewrite (reindex (lift j)). by apply: eq_bigl=> k; rewrite neq_lift. exists (fun k => odflt k0 (unlift j k)) => k; first by rewrite liftK. by case/unlift_some=> k' -> ->. Qed. Variable R : idomainType. Open Scope ring_scope. Lemma lead_coef_prod (s : seq {poly R}) : \prod_(p <- s) lead_coef p = lead_coef (\prod_(p <- s) p). Proof. elim: s=> [|a l IHl]; first by rewrite !big_nil lead_coef1. by rewrite !big_cons lead_coefM -IHl. Qed. Import GRing.Theory. Lemma monic_leadVMp (p : {poly R}) : (lead_coef p) \is a GRing.unit -> ((lead_coef p)^-1 *: p) \is monic. Proof. by move=> *; apply/monicP; rewrite lead_coefZ mulVr. Qed. End BigOp. Section Matrix. Import GRing.Theory. Local Open Scope ring_scope. Section matrix_Type. Variable T : Type. (**** This lemma is useful to rewrite in a big expression, and it is unsightly to do a "have" in a proof for proving that. *********) Lemma matrix_comp k l m n (E : 'I_k -> 'I_l -> T) (F : 'I_n -> 'I_k) G : \matrix_(i < n, j < m) ((\matrix_(i0 < k, j0 < l) E i0 j0) (F i) (G j)) = \matrix_(i, j) (E (F i) (G j)). Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. End matrix_Type. Section matrix_fieldType. Variable F : fieldType. (* mx_poly *) Lemma horner_mx_dvdp n (p q : {poly F}) (A : 'M_n.+1) : (dvdp p q) -> horner_mx A p = 0 -> horner_mx A q = 0. Proof. by case/dvdpP=> r ->; rewrite rmorphM=> /= ->; rewrite mulr0. Qed. Lemma mxminpolyP n (A : 'M[F]_n.+1) (p : {poly F}) : p \is monic -> horner_mx A p = 0 -> (forall q, horner_mx A q = 0 -> (dvdp p q)) -> p = mxminpoly A. Proof. move=> pmon eqpA0 pdvq. apply/eqP; rewrite -eqp_monic //; last exact: mxminpoly_monic. apply/andP; split. by apply/pdvq/mx_root_minpoly. exact: mxminpoly_min. Qed. End matrix_fieldType. Section matrix_ringType. Variable R : ringType. Lemma char_block_mx m n (A : 'M[R]_m) (D : 'M[R]_n) B C : char_poly_mx (block_mx A B C D) = block_mx (char_poly_mx A) (map_mx polyC (-B)) (map_mx polyC (-C)) (char_poly_mx D). Proof. apply/matrixP=> i j; rewrite !mxE. case: splitP=> k eqik; rewrite !mxE; case: splitP=> l eqjmpl; rewrite !mxE; rewrite -!(inj_eq (@ord_inj _)) eqik eqjmpl ?eqn_add2l // rmorphN. by rewrite ltn_eqF ?ltn_addr // sub0r. by rewrite gtn_eqF ?ltn_addr // sub0r. Qed. Lemma char_dblock_mx m n (A : 'M[R]_m) (B : 'M[R]_n) : char_poly_mx (block_mx A 0 0 B) = block_mx (char_poly_mx A) 0 0 (char_poly_mx B). Proof. by rewrite char_block_mx !oppr0 !map_mx0. Qed. End matrix_ringType. End Matrix. Section poly_idomainType. Variable R : idomainType. Import GRing.Theory. Local Open Scope ring_scope. Lemma coprimep_irreducible (p q : {poly R}) : ~~(p %= q) -> irreducible_poly p -> irreducible_poly q -> coprimep p q. Proof. move=> neqdpq [szpgt1 Heqdp] [szqgt1 Heqdq]. have gcdvp:= (dvdp_gcdl p q). have gcdvq:= (dvdp_gcdr p q). rewrite /coprimep; apply: contraT => neqsz1. move: (Heqdp _ neqsz1 gcdvp); rewrite eqp_sym /eqp dvdp_gcd. case/andP=> [/andP [ _ pdvq]] _. move: (Heqdq _ neqsz1 gcdvq); rewrite eqp_sym /eqp dvdp_gcd. case/andP=> [/andP [qdvp _]] _. by rewrite /eqp pdvq qdvp in neqdpq. Qed. Lemma irreducible_dvdp_seq (p r : {poly R}) s : irreducible_poly p -> p \is monic -> (dvdp p r) -> (forall q, q \in s -> irreducible_poly q) -> (forall q, q \in s -> q \is monic) -> r = \prod_(t <- s) t -> p \in s. Proof. move=> pIrr pm. elim: s r => [r pdvr _ _|a l IHl r pdvr Irr mon]. rewrite big_nil=> eqr1; move: pdvr pIrr. rewrite eqr1 dvdp1 /irreducible_poly=> /eqP ->. by rewrite ltnn; case. rewrite big_cons=> eqrM; move: pdvr; rewrite eqrM=> pdvM. case/boolP: (eqp p a)=>[|neqdpa]. have am: a \is monic by apply: mon; rewrite mem_head. by rewrite eqp_monic // => /eqP ->; rewrite mem_head. have Hia: irreducible_poly a by apply: Irr; rewrite mem_head. have cppa := coprimep_irreducible neqdpa pIrr Hia. rewrite (Gauss_dvdpr _ cppa) in pdvM. apply/mem_behead/(IHl _ pdvM)=> // q qinl. by apply: Irr; rewrite mem_behead. by rewrite mon // mem_behead. Qed. Lemma unicity_decomposition (s1 s2 : seq {poly R}) : forall (p : {poly R}), (forall r, r \in s1 -> irreducible_poly r) -> (forall r, r \in s2 -> irreducible_poly r) -> (forall r, r \in s1 -> r \is monic) -> (forall r, r \in s2 -> r \is monic) -> p = \prod_(r <- s1) r -> p = \prod_(r <- s2) r -> perm_eq s1 s2. Proof. elim: s1 s2=> [|a1 l1 IHl s2 p Irr1 Irr2 mon1 mon2]. case=> // a l p _ Irr2 _ mon2->. rewrite big_nil big_cons=> eq1M. have: irreducible_poly a by apply: Irr2; rewrite mem_head. rewrite /irreducible_poly; case. by rewrite ltnNge leq_eqVlt -dvdp1 eq1M dvdp_mulr. rewrite big_cons=> eqpM eqpbig /=. have a1ins2: a1 \in s2. apply: (irreducible_dvdp_seq _ _ _ Irr2 mon2 eqpbig). +by apply: Irr1; rewrite mem_head. -by rewrite mon1 // mem_head. by rewrite eqpM dvdp_mulr. rewrite perm_sym (perm_trans (perm_to_rem a1ins2)) //. rewrite perm_cons perm_sym. have nza1: a1 != 0. by apply: irredp_neq0; apply: Irr1; rewrite mem_head. rewrite (perm_big _ (perm_to_rem a1ins2)) /= big_cons eqpM in eqpbig. have/(mulfI nza1) eqbig := eqpbig. set q:= \prod_(j <- l1) j. apply: (IHl _ q)=> // r Hr. +by apply: Irr1; rewrite mem_behead. -by apply: Irr2; rewrite (mem_rem Hr). +by rewrite mon1 // mem_behead. -by rewrite mon2 // (mem_rem Hr). Qed. End poly_idomainType. coqeal-2.1.0/theory/polydvd.v000066400000000000000000000706531475512565300161700ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg. *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. From mathcomp Require Import path choice fintype tuple finset ssralg. From mathcomp Require Import matrix poly. (* generic_quotient. *) From mathcomp Require Import bigop polydiv. From CoqEAL Require Import stronglydiscrete dvdring. Import GRing.Theory. Import Pdiv.Ring Pdiv.Idomain Pdiv.RingComRreg dvdring.Notations. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* Local fix for poly notations *) Declare Scope poly_scope. Delimit Scope poly_scope with P. Notation "m %/ d" := (rdivp m d) : poly_scope. Notation "m %% d" := (rmodp m d) : poly_scope. Notation "p %| q" := (rdvdp p q) : poly_scope. Notation "p %= q" := (eqp p q) : poly_scope. Local Open Scope ring_scope. Module PolyDvdRing. Section PolyDvdRing. Variable R : dvdRingType. Implicit Types p q : {poly R}. (* Long division of polynomials *) Definition odivp_rec q := let sq := size q in let lq := lead_coef q in fix loop (n : nat) (r p : {poly R}) {struct n} := if p == 0 then Some r else if size p < sq then None else if odivr (lead_coef p) lq is Some x then let m := x%:P * 'X^(size p - sq) in let r1 := r + m in let p1 := p - m * q in if n is n1.+1 then loop n1 r1 p1 else None else None. Definition odivp p q : option {poly R} := if p == 0 then Some 0 else odivp_rec q (size p) 0 p. Lemma odivp_recP : forall q n p r, size p <= n -> div_spec p q (omap (fun x => x - r) (odivp_rec q n r p)). Proof. move=> q; elim=> [|n ihn] p r hn /=. move: hn; rewrite leqn0 size_poly_eq0 => /eqP->. by rewrite eqxx /= subrr; constructor; rewrite mul0r. have [-> | p0] := eqVneq p 0; first by constructor; rewrite subrr mul0r. case: ifP => /= spq. constructor=> s. apply/negP => /eqP hp. rewrite hp in spq. move: p0; rewrite hp mulf_eq0 negb_or; case/andP=> s0 q0. move: spq; rewrite (@size_proper_mul _ s q). rewrite prednK; last by rewrite addn_gt0 lt0n size_poly_eq0 s0. apply/negP; rewrite -ltnNge -{1}(add0n (size q)) ltn_add2r lt0n. by rewrite size_poly_eq0. by rewrite mulf_neq0 // lead_coef_eq0 (s0, q0). case: odivrP=> /= [x hx|hpq]; last first. constructor=> s; apply: contra (hpq (lead_coef s)) => /eqP ->. by rewrite lead_coefM. set m := _ * _. set d := odivp_rec _ _ _ _. set om := omap (+%R^~ (- (r + m))) d. move: (erefl om); rewrite /om /d; case: {2}_ / ihn. * suff H : size (p - m * q) < size p by rewrite -ltnS (leq_trans H). move: hx. rewrite -{2}[q]coefK -{2}[p]coefK !lead_coefE !poly_def. case hsp: (size p) spq => [|sp] spq. by move/eqP: hsp; rewrite size_poly_eq0 (negbTE p0). case hsq: (size q) spq => [|sq] spq. move/eqP: hsq; rewrite size_poly_eq0 => /eqP->. rewrite coef0 mulr0 => /eqP. by rewrite -hsp -lead_coefE lead_coef_eq0 (negbTE p0). move: spq; rewrite ltnS ltnNge => /negPn spq. rewrite ![_.-1]/= !big_ord_recr [_ - _]/= -!poly_def=> ->. rewrite [m * _]mulrC /m hsp hsq subSS mulrDl opprD. rewrite addrAC -!addrA [xx in _ + (_ + xx)]addrC -scalerAl. rewrite [_ ^+ _ * (_ * _)]mulrCA -exprD subnKC //. rewrite scalerAr -scalerA [_ *: _]scale_polyE subrr addr0. rewrite ltnS (leq_trans (size_add _ _)) //. rewrite geq_max (leq_trans (size_poly _ _)) //. rewrite size_opp (leq_trans (size_mul_leq _ _)) //. have [-> | x0] := eqVneq x 0. rewrite polyC0 mul0r size_poly0 addn0. rewrite -subn1 leq_subLR (leq_trans (size_poly _ _)) //. by rewrite add1n (leq_trans spq) // leqnSn. rewrite size_proper_mul ?lead_coefC ?lead_coefXn ?mulr1 //. rewrite size_polyC x0 size_polyXn /= addnS /=. by rewrite ?add0n ?addnS addnBA//= leq_subLR leq_add2r size_poly. * move=> s hs; case hpq: (odivp_rec _ _ _ _)=> [r'|] //=. case=> hm; constructor; move: hm; rewrite opprD addrA. move/eqP; rewrite (can2_eq (@addrNK _ _) (@addrK _ _)) => /eqP->. by rewrite mulrDl -hs addrNK. * move=> hpq; case hpq': (odivp_rec _ _ _ _)=> [r'|] //= _. constructor=> s; apply: contra (hpq (s - m)) => /eqP->. by rewrite mulrBl. Qed. Lemma odivpP : forall p q, div_spec p q (odivp p q). Proof. move=> p q; rewrite /odivp. case p0: (p == 0); first by constructor; rewrite mul0r (eqP p0). have := (@odivp_recP q (size p) p 0 (leqnn _)). by case: odivp_rec=> [a|] //=; rewrite subr0; apply. Qed. End PolyDvdRing. End PolyDvdRing. Definition poly_of (R : semiRingType) := {poly R}. HB.instance Definition _ (R : dvdRingType) := GRing.IntegralDomain.on (poly_of R). HB.instance Definition _ (R : dvdRingType) := Ring_hasDiv.Build (poly_of R) (@PolyDvdRing.odivpP R). Module PolyGcdDomain. Section PolyGcdDomain. (* Polyonomials over gcd rings *) Import PolyDvdRing. Variable R : gcdDomainType. Implicit Types a b : R. Implicit Types p q : poly_of R. (* Useful lemmas *) (* Double induction for polynomials *) Lemma poly_ind2 : forall P : {poly R} -> {poly R} -> Type, (forall p, P p 0) -> (forall q, P 0 q) -> (forall c p d q, P p (q * 'X + d%:P) -> P (p * 'X + c%:P) q -> P (p * 'X + c%:P) (q * 'X + d%:P)) -> forall p q, P p q. Proof. move=> P H01 H02 H. apply: (@poly_ind _)=> // p c IH1. apply: (@poly_ind _)=> // q d IH2. apply: (@H c p d q)=> //. Qed. Lemma elim_poly : forall p, exists p' c, p = p' * 'X + c%:P. Proof. elim/poly_ind; first by exists 0, 0; rewrite mul0r add0r. by move=> p c [_ [_]] _; exists p, c. Qed. Lemma polyC_inj_dvdr : forall a b, (a %| b)%R -> (a%:P : poly_of R) %| b %:P. Proof. move=> a b. case/dvdrP=> x Hx; apply/dvdrP; exists (x%:P). by rewrite -polyCM Hx. Qed. Lemma polyC_inj_eqd : forall a b, a %= b -> (a%:P : poly_of R) %= b%:P. Proof. by move=> a b; rewrite /eqd; case/andP; do 2 move/polyC_inj_dvdr=> ->. Qed. (* Properties of gcdsr *) Lemma gcdsr0 : gcdsr (0 : {poly R}) = 0. Proof. by rewrite polyseq0. Qed. Lemma gcdsr1 : gcdsr (1 : {poly R}) %= 1. Proof. by rewrite polyseqC oner_neq0 /= gcdr0. Qed. Lemma gcdsrC : forall c : R, gcdsr c%:P %= c. Proof. by move=> c; rewrite polyseqC; case c0: (c == 0); rewrite ?gcdr0 // (eqP c0). Qed. Lemma gcdsr_gcdl : forall p c, gcdsr (p * 'X + c%:P) = gcdr c (gcdsr p). Proof. move=> p c. have [-> | p0] := eqVneq p 0. rewrite mul0r add0r gcdsr0 /gcdsr polyseqC. by case: eqP => //= ->; apply/eqP; rewrite eq_sym gcdr_eq0 eqxx. by rewrite -cons_poly_def polyseq_cons /nilp size_poly_eq0 p0. Qed. Lemma gcdsr_eq0 : forall p, (gcdsr p == 0) = (p == 0). Proof. elim/poly_ind=> [|p c IH]; first by rewrite gcdsr0 !eqxx. rewrite gcdsr_gcdl gcdr_eq0 IH -[p * 'X + c%:P == 0]size_poly_eq0 size_MXaddC. rewrite andbC. by apply/idP/idP => [->|] //; case: ifP. Qed. Lemma gcdsr_mulX : forall p, gcdsr (p * 'X) %= gcdsr p. Proof. by move=> p; rewrite -[p*'X]addr0 gcdsr_gcdl gcd0r. Qed. Lemma gcdsrX : gcdsr ('X : {poly R}) %= 1. Proof. move: (gcdsr_mulX 1); rewrite mul1r=> H. exact: (eqd_trans H gcdsr1). Qed. Lemma gcdsr_mull : forall a p, gcdsr (a%:P * p) %= a * gcdsr p. Proof. move=> a. elim/poly_ind=> [|p c IH]; first by rewrite mulr0 gcdsr0 mulr0. rewrite mulrDr -polyCM mulrA [X in X %= _]gcdsr_gcdl. rewrite (eqd_trans (eqd_gcd (eqdd _) IH)) //. by rewrite (eqd_trans (gcdr_mul2l _ _ _)) // -gcdsr_gcdl. Qed. Lemma gcdsr_mulr : forall a p, gcdsr (p * a%:P) %= gcdsr p * a. Proof. by move=> a p; rewrite mulrC [_ * a]mulrC gcdsr_mull. Qed. Lemma mulr_gcdsr : forall a p, a * gcdsr p %= gcdsr (a%:P * p). Proof. by move=> a p; rewrite eqd_sym gcdsr_mull. Qed. Lemma mulr_gcdsl : forall a p, gcdsr p * a %= gcdsr (p * a %:P). Proof. by move=> a p; rewrite eqd_sym gcdsr_mulr. Qed. Lemma eq_eqdgcdsr : forall p q, p = q -> gcdsr p %= gcdsr q. Proof. by move=> p q ->. Qed. (* Key lemma in gauss lemma *) Lemma gcdr_gcdsr_muladdr : forall a p q, gcdr a (gcdsr (a%:P * p + q)) %= gcdr a (gcdsr q). Proof. move=> a. elim/poly_ind=> [|p c IH q]; first by move=> q; rewrite mulr0 add0r eqdd. rewrite mulrDr mulrA -polyCM addrC addrA -[q]polyseqK. case: q=> /= q _; case: q=> /= [|d p1]. rewrite add0r gcdsr_gcdl (eqd_trans (gcdrA a _ _)) // -[a*c]addr0. rewrite (eqd_trans (eqd_gcd (gcdr_addl_mul a 0 c) (eqdd _))) //. by rewrite (eqd_trans (eqd_gcd (gcdr0 a) (eqdd _))) // -[_ * p]addr0 (IH 0). rewrite cons_poly_def -!addrA [d%:P + _]addrCA -polyCD addrA -mulrDl. rewrite !gcdsr_gcdl [Poly p1 + _]addrC [d+_]addrC (eqd_trans (gcdrA _ _ _)) //. rewrite (eqd_trans ((eqd_gcd (gcdr_addl_mul a d c)) (eqdd _))) //. rewrite (eqd_trans (gcdrAC _ _ _)) ?(eqd_trans (eqd_gcd (IH _) (eqdd d))) //. rewrite (eqd_trans (gcdrAC _ _ _)) // eqd_sym (eqd_trans (gcdrA _ _ _)) //. Qed. (* Primitive polynomials *) (* = is too strict, consider: cont (-3%P) %= 3... *) Definition primitive p := gcdsr p %= 1. Lemma primitive0 : forall p, primitive p -> p != 0. Proof. rewrite /primitive=> p; apply: contraL => /eqP->. by rewrite gcdsr0 eqd_def dvd0r negb_and oner_neq0. Qed. (* Another key lemma *) Lemma gcdsr_primitive : forall p, exists q, p = (gcdsr p)%:P * q /\ primitive q. Proof. move=> p; rewrite /primitive. suff H: exists q, p = (gcdsr p)%:P * q. have [-> | p0] := eqVneq p 0; first by exists 1; rewrite gcdsr0 mulr1 gcdsr1. case: H=> x H; exists x; split=> //. rewrite -(@eqd_mul2l _ (gcdsr p)). by rewrite mulr1 {2}H (eqd_trans _ (mulr_gcdsr _ x)). by apply: contraPneq H => ->; apply/eqP; rewrite mul0r. elim/poly_ind: p=> /= [|p c [q IH]]; first by exists 1; rewrite gcdsr0 mul0r. case/dvdrP: (dvdr_gcdr c (gcdsr p))=> wr Hr; rewrite mulrC in Hr. case/dvdrP: (dvdr_gcdl c (gcdsr p))=> wl Hl; rewrite mulrC in Hl. exists (wr%:P * q * 'X + wl%:P). by rewrite mulrDr gcdsr_gcdl !mulrA -!polyCM -Hl -Hr -IH. Qed. Lemma gcdsr_dvdr : forall p, ((gcdsr p)%:P : poly_of R) %| p. Proof. move=> p; case: (gcdsr_primitive p)=> x [? _]; apply/dvdrP. by exists x; rewrite mulrC. Qed. Lemma gcdsr_odivp : forall p, p != 0 -> exists x, p %/? (gcdsr p)%:P = Some (x : {poly R}) /\ primitive x. Proof. move=> p p0; case: (gcdsr_primitive p)=> x [Hp primx]. exists x; split=> //. rewrite {1}Hp odivr_mulKr //. by apply: contraPneq Hp => ->; apply/eqP; rewrite mul0r. Qed. Lemma prim_mulX : forall p, primitive p -> primitive (p * 'X). Proof. rewrite /primitive=> p H; apply: (@eqd_trans _ (gcdsr p) _ 1)=> //. by rewrite -[p * _]addr0 gcdsr_gcdl (eqd_trans (gcd0r _)). Qed. Lemma gauss_lemma : forall p q, gcdsr (p * q) %= gcdsr p * gcdsr q. Proof. apply: @poly_ind2=> [p|q|p0 p1 q0 q1]; first by rewrite mulr0 !gcdsr0 mulr0. by rewrite mul0r !gcdsr0 mul0r. set p := p1 * 'X + p0%:P. set q := q1 * 'X + q0%:P. move=> IH1 IH2. case: (gcdsr_primitive p); rewrite /primitive=> p' [Hp prim_p']. case: (gcdsr_primitive q); rewrite /primitive=> q' [Hq prim_q']. case: (elim_poly p')=> p1' [p0'] Hp'. case: (elim_poly q')=> q1' [q0'] Hq'. (* First some preliminary results *) case H0p0 : (p0 == 0). rewrite /p (eqP H0p0) addr0 -mulrA ['X * _]mulrC mulrA. rewrite (eqd_trans (gcdsr_mulX _)) // (eqd_trans IH1) //. by rewrite eqd_sym (eqd_mul (gcdsr_mulX _)). case H0q0 : (q0 == 0). rewrite /q (eqP H0q0) addr0 mulrA (eqd_trans (gcdsr_mulX _)) //. by rewrite (eqd_trans IH2) // eqd_sym (eqd_mul _ (gcdsr_mulX _)). have Hp1p1' : p1 = (gcdsr p)%:P * p1'. apply/polyP=> i; move: Hp; rewrite {1}/p Hp' mulrDr mulrA -polyCM. move/polyP=> H; move: (H (i.+1)); rewrite -!cons_poly_def !coef_cons. by case i. have Hq1q1' : q1 = (gcdsr q)%:P * q1'. apply/polyP=> i; move: Hq; rewrite {1}/q Hq' mulrDr mulrA -polyCM. move/polyP=> H; move: (H (i.+1)); rewrite -!cons_poly_def !coef_cons. by case i. have Hgcdsrp0 : (gcdsr p != 0) by rewrite /p gcdsr_gcdl gcdr_eq0 H0p0. have Hgcdsrq0 : (gcdsr q != 0) by rewrite /q gcdsr_gcdl gcdr_eq0 H0q0. (* Massage induction hypotheses *) have IH1' : gcdsr (p1' * q') %= gcdsr p1'. rewrite -(@eqd_mul2r _ (gcdsr q)) ?(eqd_trans (mulr_gcdsl _ _)) // -mulrA. rewrite [q' * _]mulrC -Hq -(@eqd_mul2l _ (gcdsr p)) // mulrA. rewrite (eqd_trans (mulr_gcdsr _ _)) // mulrA -Hp1p1' eqd_sym. by rewrite (eqd_trans (eqd_mul (mulr_gcdsr _ _) (eqdd _))) // -Hp1p1' eqd_sym. have IH2' : gcdsr (p' * q1') %= gcdsr q1'. rewrite -(@eqd_mul2l _ (gcdsr p)) ?(eqd_trans (mulr_gcdsr _ _)) // mulrA. rewrite -Hp -(@eqd_mul2r _ (gcdsr q)) // (eqd_trans (mulr_gcdsl _ _)) //. rewrite -!mulrA [q1' * _]mulrC -Hq1q1' eqd_sym mulrC [gcdsr q1' * _]mulrC. by rewrite (eqd_trans (eqd_mul (mulr_gcdsr _ _) (eqdd _))) // -Hq1q1' mulrC eqd_sym. (* Simplify goal *) suff Hprim : (gcdsr (p' * q') %= 1). rewrite {1}Hp {1}Hq mulrAC mulrA -polyCM-mulrA. rewrite (eqd_trans (gcdsr_mull _ _)) // [q' * _]mulrC -{2}[gcdsr q]mulr1. rewrite mulrA (eqd_mul _ _) //. (* Simplify further *) rewrite Hp' Hq' mulrC. rewrite mulrDr !mulrDl -polyCM mulrCA [_ * p0'%:P]mulrC !mulrA. rewrite !addrA -mulrDl -mulrDl. (* Finish everything *) rewrite gcdsr_gcdl -/(coprimer _ _) coprimer_mull andbC /coprimer {1}addrC. rewrite [_ + q0'%:P * p1']addrC -addrA (eqd_trans (gcdr_gcdsr_muladdr _ _ _)). rewrite (eqd_trans (gcdr_gcdsr_muladdr _ _ _)) // -mulrA [_ * 'X]mulrC mulrA. rewrite -mulrDl -Hp' (eqd_trans (eqd_gcd (eqdd _) IH2')) // -gcdsr_gcdl. by rewrite -Hq'. rewrite [_ * p1']mulrC -mulrA -mulrDr addrC -Hq'. by rewrite (eqd_trans (eqd_gcd (eqdd _) IH1')) // -gcdsr_gcdl -Hp'. Qed. Lemma gauss_primitive : forall p q, primitive p -> primitive q -> primitive (p * q). Proof. rewrite /primitive=> p q pp pq. by rewrite (eqd_trans (gauss_lemma _ _)) // (eqd_trans (eqd_mul pp pq)) // mul1r. Qed. Lemma gcdsr_inj_dvdr : forall p q, p %| q -> gcdsr p %| gcdsr q. Proof. move=> p q; case/dvdrP=> x ->. move: (gauss_lemma x p). case/andP=> _ H. by rewrite (dvdr_trans _ H) ?dvdr_mull //. Qed. Lemma gcdsr_inj_eqd : forall p q, p %= q -> gcdsr p %= gcdsr q. Proof. move=> p q; case/andP=> pq qp. by rewrite eqd_def (gcdsr_inj_dvdr pq) (gcdsr_inj_dvdr qp). Qed. (* Primitive part, pp *) Definition pp p := odflt 1 (p %/? (gcdsr p)%:P). Lemma pp0 : pp 0 = 0. Proof. by rewrite /pp /odivr gcdsr0 /div /= /odivp eqxx. Qed. Lemma ppP : forall p, p = (gcdsr p)%:P * pp p. Proof. move=> p. have [-> | p0] := eqVneq p 0; first by rewrite pp0 mulr0. have g0 : (gcdsr p)%:P != 0 by rewrite polyC_eq0 gcdsr_eq0. case: (gcdsr_odivp p0) => x [hx px]. by rewrite /pp hx; move: (odivr_some hx)=> {1}->. Qed. Lemma pp_eq0 : forall p, (pp p == 0) = (p == 0). Proof. move=> p. rewrite {2}(ppP p) mulf_eq0. apply/idP/idP; first by move->; rewrite orbT. case/orP=> //. by rewrite polyC_eq0 gcdsr_eq0 => /eqP->; rewrite pp0. Qed. Lemma ppC : forall c, c != 0 -> pp c%:P %= 1. Proof. move=> c c0. move: (eqd_trans (polyC_inj_eqd (gcdsrC c)) (eq_eqd (ppP c%:P))). rewrite -{1}[(gcdsr c%:P)%:P]mulr1. have g0: (gcdsr c%:P)%:P != 0. by rewrite polyC_eq0 gcdsr_eq0 polyC_eq0. by rewrite eqd_mul2l// eqd_sym. Qed. Lemma pp1 : pp 1 %= 1. Proof. by rewrite ppC ?oner_neq0. Qed. Lemma ppX : pp 'X %= 'X. Proof. by rewrite {2}(ppP 'X) -{1}[pp _]mul1r eqd_mul // eqd_sym (polyC_inj_eqd gcdsrX). Qed. Lemma prim_pp : forall p, p != 0 -> primitive (pp p). Proof. by move=> p p0; rewrite /pp; case: (gcdsr_odivp p0)=> x [-> px]. Qed. Lemma pp_prim : forall p, primitive p -> (p %= pp p). Proof. rewrite /primitive=> p pp. by rewrite {1}(ppP p) -{2}[PolyGcdDomain.pp p]mul1r eqd_mul // polyC_inj_eqd. Qed. Lemma pp_dvdr : forall p, pp p %| p. Proof. by move=> p; apply/dvdrP; exists (gcdsr p)%:P; exact: ppP. Qed. Lemma pp_mul : forall p q, pp (p * q) %= pp p * pp q. Proof. move=> p q. have [-> | p0] := eqVneq p 0; first by rewrite mul0r !pp0 mul0r. have [-> | q0] := eqVneq q 0; first by rewrite mulr0 !pp0 mulr0. have h0: (gcdsr (p * q))%:P != 0. by rewrite polyC_eq0 gcdsr_eq0 mulf_eq0 negb_or p0. have h1: pp p * pp q != 0. by rewrite mulf_eq0 !pp_eq0 negb_or p0. rewrite -(@eqd_mul2l (poly_of R) (gcdsr (p * q))%:P)// -ppP. move: (polyC_inj_eqd (gauss_lemma p q)). rewrite -(eqd_mul2r _ _ h1)=> H; rewrite eqd_sym (eqd_trans H) //. by rewrite polyCM mulrCA -mulrA -ppP mulrCA mulrA -ppP. Qed. Lemma pp_mull : forall a p, a != 0 -> pp (a%:P * p) %= pp p. Proof. move=> a p a0. apply: (eqd_trans (pp_mul a%:P p)). by rewrite -{2}[pp p]mul1r eqd_mul ?ppC ?(eqP a0). Qed. Lemma pp_mulX : forall p, pp (p * 'X) %= pp p * 'X. Proof. by move=> p; rewrite (eqd_trans (pp_mul _ _)) // eqd_mul // ppX. Qed. Lemma pp_inj_dvdr : forall p q, p %| q -> pp p %| pp q. Proof. move=> p q; case/dvdrP=> x ->. by case/andP: (pp_mul x p)=>_; apply/dvdr_trans/dvdr_mull. Qed. Lemma pp_inj_eqd : forall p q, p %= q -> pp p %= pp q. Proof. move=> p q; case/andP => pq qp. by rewrite eqd_def (pp_inj_dvdr pq) (pp_inj_dvdr qp). Qed. Lemma size_pp : forall p, size p = size (pp p). Proof. move=> p. have [-> | p0] := eqVneq p 0; first by rewrite pp0. have gp0: (gcdsr p != 0) by rewrite gcdsr_eq0. apply/eqP; rewrite eqn_leq; apply/andP; split. move: (size_mul_leq (gcdsr p)%:P (pp p)). by rewrite {5}(ppP p) size_polyC gp0. rewrite {2}(ppP p). elim/poly_ind: (pp p)=> [|q c IH]; first by rewrite size_poly0 leq0n. rewrite mulrDr mulrA -polyCM !size_MXaddC. case: ifP=>[|H]; first by rewrite leq0n. case: ifP=>//. case/andP=> H1 H2. rewrite mulf_eq0 in H2. case/orP: H2 => G; first by rewrite G in gp0. case/nandP: H=> H; last by move: H; rewrite G. move: H1; rewrite mulf_eq0 -[q == 0]size_poly_eq0. case/orP; rewrite ?polyC_eq0=> H2; first by move: gp0; rewrite H2. move: H2; rewrite size_poly_eq0 => H2. by move: H; rewrite H2. Qed. Lemma dvdrp_spec : forall p q, (p %| q) = (gcdsr p %| gcdsr q) && (pp p %| pp q). Proof. move=> p q. apply/idP/idP=> [H|]; first by rewrite gcdsr_inj_dvdr ?pp_inj_dvdr. by case/andP=> ? ?; rewrite (ppP p) (ppP q) dvdr_mul // polyC_inj_dvdr. Qed. Lemma pp_prim_eq : forall p, p != 0 -> primitive p = (p %= pp p). Proof. move=> p p0. apply/idP/idP; first exact: pp_prim. case/andP=> H _. move: (prim_pp p0). rewrite /primitive eqd_def; case/andP=> gp1 _. move: H; rewrite dvdrp_spec; case/andP=> gp2 _. by apply/andP; rewrite (dvdr_trans gp2 gp1) dvd1r. Qed. Lemma dvdrp_prim_mull : forall a p q, a != 0 -> primitive q -> p %| a%:P * q = (gcdsr p %| a) && (pp p %| q). Proof. move=> a p q a0 pq; case/andP: (pq)=> pq1 pq2. rewrite dvdrp_spec. case/andP: (gcdsr_mull a q)=> Hg2 Hg3. case/andP: (pp_mul (a%:P) q)=> pp1 pp2. apply/idP/idP; case/andP=> H Hpp. move: (dvdr_mul pq1 (dvdrr a)); rewrite mulrC. move/(dvdr_trans (dvdr_trans H Hg2)); rewrite mul1r=>-> /=. rewrite (dvdr_trans _ (pp_dvdr q)) //. move: (dvdr_trans Hpp pp1)=> H'. case/andP: (ppC a0)=> H1 _. by move: (dvdr_trans H' (dvdr_mul H1 (dvdrr (pp q)))); rewrite mul1r. rewrite (dvdr_trans _ Hg3) /=; last by move: (dvdr_mul H pq2); rewrite mulr1. case/andP: (pp_prim pq)=> G1 _. by rewrite (dvdr_trans (dvdr_trans Hpp G1)); case/andP: (pp_mull q a0). Qed. Lemma dvdrpC : forall a p, (a%:P : poly_of R) %| p = (a %| gcdsr p). Proof. move=> a p. apply/idP/idP=> [|H]; last exact: (dvdr_trans (polyC_inj_dvdr H) (gcdsr_dvdr p)). rewrite dvdrp_spec; case/andP=> H _; case/andP: (gcdsrC a)=> _ G. exact: (dvdr_trans G H). Qed. Lemma dvdrp_primr : forall p q, p %| q -> primitive q -> primitive p. Proof. move=> p q. have [-> | p0] := eqVneq p 0; first by rewrite dvd0r => /eqP->. rewrite /primitive /eqd=> pq ppq; rewrite dvd1r andbT; apply/dvdrP. move: (pp_inj_dvdr pq)=> pppq; rewrite dvdrp_spec in pq. case/andP: pq; case/dvdrP=> x Hx; case/dvdrP=> y Hy. case/andP: ppq; case/dvdrP=> z Hz _. by exists (z * x); rewrite -mulrA -Hx -Hz. Qed. Lemma dvdrp_priml : forall a p q, a != 0 -> p %| a%:P * q -> primitive p -> p %| q. Proof. move=> a p q a0. rewrite dvdrp_spec; case/andP=> H1 H2. rewrite /primitive /eqd dvdrp_spec; case/andP=> H3 _. case/andP: (pp_mull q a0)=> H4 _. by rewrite (dvdr_trans H2 H4) (dvdr_trans H3 (dvd1r (gcdsr q))). Qed. (* gcdp *) Fixpoint gcdp_rec (n : nat) (p q : {poly R}) := let r := rmodp p q in if r == 0 then q else if n is n'.+1 then gcdp_rec n' q (pp r) else pp r. Definition gcdp p q := let (p1,q1) := if size p < size q then (q,p) else (p,q) in let d := (gcdr (gcdsr p1) (gcdsr q1))%:P in d * gcdp_rec (size (pp p1)) (pp p1) (pp q1). Lemma gcdp_rec0r : forall p n, gcdp_rec n 0 p = p. Proof. by move=> p n; rewrite /gcdp_rec; case: n; rewrite rmod0p eqxx. Qed. Lemma gcdp_recr0 : forall p n, primitive p -> (gcdp_rec n p 0 : poly_of R) %= p. Proof. move=> p n pp. have p0 := primitive0 pp. have Hppp : PolyGcdDomain.pp p %= p by rewrite {2}(ppP p) -{1}[PolyGcdDomain.pp p]mul1r eqd_mul // eqd_sym polyC_inj_eqd. by case: n=> /= [|n]; rewrite rmodp0 (negbTE p0) ?gcdp_rec0r Hppp. Qed. (* Show that gcdp_rec return a primitive polynomial that is the gcd of p and q *) Lemma gcdp_recP : forall n p q g, size q <= n -> q != 0 -> primitive q -> (g %| (gcdp_rec n p q : poly_of R) = (g %| p) && (g %| q)) /\ primitive (gcdp_rec n p q). Proof. elim=> /= [p q g|n IH p q g sqn q0 pq]. by rewrite leqn0 size_poly_eq0=> ->. (* Recall the specifiction of pseudo-division *) have hcomm : GRing.comm q (lead_coef q)%:P by rewrite /GRing.comm mulrC. move: (rdivp_eq hcomm p); rewrite mulrC. set lx := lead_coef q ^+ rscalp p q => Hdiv. have H0: lx != 0. by rewrite expf_eq0 lead_coef_eq0 negb_and q0 orbT. case: ifP=>[pq0|npq0]. split=> //; apply/idP/idP; last by case/andP. move=> gq; rewrite gq andbT. rewrite (eqP pq0) addr0 in Hdiv. move: (dvdr_mull (((p : poly_of R) %/ q)%P : poly_of R) gq); rewrite -Hdiv=> H. by rewrite (dvdrp_priml H0 H) // (dvdrp_primr gq). set pp_pq := pp (p %% q)%P. have s_pp_pq : (size pp_pq <= n) by rewrite -size_pp; move: (leq_trans (ltn_rmodpN0 p q0) sqn); rewrite ltnS. have p_pp_pq : primitive pp_pq by rewrite prim_pp // npq0. have pp_pq0 : pp_pq != 0 by rewrite pp_eq0 npq0. (* Apply induction hypothesis *) case: (IH q pp_pq g s_pp_pq pp_pq0 p_pp_pq)=> -> h2 /=; split=>//. apply/idP/idP. (* Case: (g %| q) && (g %| pp_pq) -> (g %| p) && (g %| q) *) case/andP=> gq gpppq; rewrite gq andbT. move: (dvdr_mull ((gcdsr (p %% q)%P)%:P : poly_of R) gpppq); rewrite -(ppP _)=> gpmq. move: (dvdr_add (dvdr_mull (((p : poly_of R) %/ q)%P : poly_of R) gq) gpmq); rewrite -Hdiv=> H. by rewrite (dvdrp_priml H0 H) // (dvdrp_primr gq). (* Case: (g %| p) && (g %| q) -> (g %| q) && (g %| pp_pq) *) (* Simplify the goal *) case/andP=> gp gq; rewrite gq /=. move: (dvdr_sub (dvdr_mull (lx%:P : poly_of R) gp) (dvdr_mull (((p : poly_of R) %/ q)%P : poly_of R) gq)). move/eqP: Hdiv; rewrite addrC -subr_eq => /eqP->; rewrite dvdrp_spec=> gpq. suff gppg : g %| pp g by rewrite (dvdr_trans gppg) //; case/andP: gpq. move: (dvdrp_primr gq pq). by rewrite (pp_prim_eq (primitive0 (dvdrp_primr gq pq))); case/andP. Qed. (* Correctness of gcdp *) Lemma gcdpP g p q : g %| (gcdp p q : poly_of R) = (g %| p) && (g %| q). Proof. rewrite /gcdp. (* Simplify the goal *) wlog sqp : p q / size q <= size p=> [H|]. case: ltnP=> spq. by move/H: (ltnW spq); rewrite ltnNge (ltnW spq) andbC. by move/H: (spq); rewrite ltnNge spq. rewrite ltnNge sqp /=. (* Cases when either input is zero *) have [p0 | p0] := eqVneq p 0. have /eqP q0: (q == 0) by rewrite p0 size_poly0 leqn0 size_poly_eq0 in sqp. by rewrite p0 q0 !pp0 size_poly0 gcdp_rec0r mulr0 andbb. have [-> | q0] := eqVneq q 0. rewrite dvdr0 andbT gcdsr0 pp0 /=. case/andP: (gcdp_recr0 (size (pp p)) (prim_pp p0))=> Hg Hpp. apply/idP/idP=> [H|]. rewrite (ppP p); case/andP: (gcdr0 (gcdsr p))=> H0 _. exact: (dvdr_trans H (dvdr_mul (polyC_inj_dvdr H0) Hg)). rewrite dvdrp_spec {3}(ppP g); case/andP=> Hgp Hppgp. case/andP: (gcdr0 (gcdsr p))=> _ H0. exact: (dvdr_mul (polyC_inj_dvdr (dvdr_trans Hgp H0)) (dvdr_trans Hppgp Hpp)). have ppq0 : pp q != 0 by rewrite pp_eq0. have spp: (size (pp q) <= size (pp p)) by rewrite -!size_pp. case: (gcdp_recP (pp p) (pp g) spp ppq0 (prim_pp q0))=> H prim. apply/idP/idP; last first. (* The easier case: g | p /\ g | q -> q | gcd (cont p) (cont q) * gcdp_rec (pp p) (pp q) *) rewrite {3}(ppP g); case/andP=> gp gq. apply/dvdr_mul; last by rewrite H (pp_inj_dvdr gp) (pp_inj_dvdr gq). by rewrite polyC_inj_dvdr // dvdr_gcd (gcdsr_inj_dvdr gp) (gcdsr_inj_dvdr gq). (* The harder case: q | gcd (cont p) (cont q) * gcdp_rec (pp p) (pp q) -> g | p /\ g | q *) have g0 : (gcdr (gcdsr p) (gcdsr q)) != 0. by rewrite gcdr_eq0 negb_and !gcdsr_eq0 p0. rewrite (dvdrp_prim_mull _ g0 prim); case/andP=> gdvd ppgdvd. have Hgg: gcdsr g %| gcdsr p /\ gcdsr g %| gcdsr q. by rewrite -dvdrpC (dvdr_trans _ (gcdsr_dvdr _)) ?polyC_inj_dvdr ?(dvdr_trans gdvd (dvdr_gcdl _ _)) ?(dvdr_trans gdvd (dvdr_gcdr _ _)). have Hppg : (pp g %| pp p) /\ (pp g %| pp q) by move: ppgdvd; rewrite H; case/andP. case: Hgg; case: Hppg=> ? ? ? ?. by rewrite (ppP g) (ppP p) (ppP q) !dvdr_mul // polyC_inj_dvdr. Qed. End PolyGcdDomain. End PolyGcdDomain. HB.instance Definition _ (R : gcdDomainType) := DvdRing_hasGcd.Build (poly_of R) (@PolyGcdDomain.gcdpP R). Module PolyPriField. Section PolyPriField. (* This section shows that the polynomial ring k[x] where k is a field is an Euclidean ring *) Variable F : fieldType. Implicit Types p q r : {poly F}. Definition ediv_rec q := let sq := size q in let lq := lead_coef q in fix loop (n : nat) (qq r : {poly F}) {struct n} := if size r < sq then (qq, r) else let m := (lead_coef r / lq)%:P * 'X^(size r - sq) in let qq1 := qq + m in let r1 := r - m * q in if n is n1.+1 then loop n1 qq1 r1 else (qq1, r1). Definition ediv p q : {poly F} * {poly F} := if q == 0 then (0, p) else ediv_rec q (size p) 0 p. Lemma ediv_recP : forall q n p qq, q != 0 -> size p <= n -> let: (qq', r) := (ediv_rec q n qq p) in edivr_spec (size : {poly F} -> nat) p q (qq' - qq, r). Proof. move=> q. elim=> [|n IHn] p qq Hq0 /=. rewrite leqn0 size_poly_eq0=> p0; rewrite (eqP p0) /=. case: ifP; first by constructor; [rewrite subrr mul0r add0r | apply/implyP]. rewrite size_poly0 lt0n size_poly_eq0=> q0. constructor; by rewrite ?q0 // sub0r [qq + _]addrC -addrA subrr addr0 subrr. case: ifP; first by constructor; [rewrite subrr mul0r add0r | apply/implyP]. move=> spq spSn. set x := (lead_coef p / lead_coef q)%:P * 'X^(size p - size q). have := IHn (p - x * q) (qq + x). case hdiv: ediv_rec=> [qq' r]. set q0 := qq' - _; move=> h. move: (erefl (q0, r)). case: {1}_ / h=> //. suff H : size (p - x * q) < size p by rewrite -ltnS (leq_trans H). rewrite -[q]coefK -{1}[p]coefK !poly_def. case hsp: (size p) spq => [|sp] spq. by move: spq; rewrite ltnNge leqn0 size_poly_eq0 Hq0. case hsq: (size q) spq => [|sq] spq. by move: Hq0; move/eqP: hsq; rewrite size_poly_eq0=>->. move: spq; rewrite ltnS ltnNge; move/negPn=> spq. rewrite !big_ord_recr [_ - _]/= -!poly_def. rewrite [x * _]mulrC /x hsp hsq subSS mulrDl opprD. rewrite addrAC -!addrA [xx in _ + (_ + xx)]addrC -scalerAl. rewrite [_ ^+ _ * (_ * _)]mulrCA -exprD subnKC //. rewrite /lead_coef hsp hsq ![_.+1.-1]/= scalerAr ![_ *: _]scale_polyE. rewrite !mulrA -polyCM -!mulrA [_ * q`_sq]mulrC divff; last first. by apply: contra Hq0; rewrite -lead_coef_eq0 /lead_coef hsq. rewrite mulr1 subrr addr0. rewrite ltnS (leq_trans (size_add _ _)) //. rewrite geq_max (leq_trans (size_poly _ _)) //. rewrite size_opp (leq_trans (size_mul_leq _ _)) //. have [-> | x0] := eqVneq (p`_sp / q`_sq) 0. rewrite polyC0 mul0r size_poly0 addn0. rewrite -subn1 leq_subLR (leq_trans (size_poly _ _)) //. by rewrite add1n (leq_trans spq) // leqnSn. rewrite size_proper_mul ?lead_coefC ?lead_coefXn ?mulr1 ?x0 //. rewrite size_polyC x0 size_polyXn /= addnS /=. by rewrite ?add0n ?addnS addnBA//= leq_subLR leq_add2r size_poly. move=> q1 r0 H G. move/eqP; rewrite xpair_eqE; case/andP; move/eqP=> q1q0; move/eqP=> r0r. constructor; last by rewrite -r0r. move/eqP: H; rewrite subr_eq; move/eqP=> ->. rewrite q1q0 /q0 r0r !mulrDl -!addrA [_ + (r + _)]addrCA opprD mulrDl. by rewrite -addrA [_ * q + _ * q]addrC !mulNr subrr addr0 [_ + r]addrC. Qed. Lemma edivP : forall p q, edivr_spec (size : {poly F} -> nat) p q (ediv p q). Proof. move=> p q; rewrite /ediv. case: (eqVneq q 0) => q0. constructor; first by rewrite mul0r add0r. by rewrite q0 eqxx. have := (@ediv_recP q (size p) p 0 q0 (leqnn _)). by case: ediv_rec=> a b; rewrite subr0. Qed. Lemma poly_size_mull : forall p q, p != (0 : {poly F}) -> (size q <= size (p * q)%R)%N. Proof. move=> p q p0. case: (eqVneq q 0)=>[->|q0]; first by rewrite mulr0 size_poly0 leqnn. rewrite size_mul // -ltnS prednK; first by rewrite -subn_gt0 addnK lt0n size_poly_eq0. by rewrite addn_gt0 lt0n size_poly_eq0 p0. Qed. HB.instance Definition _ := IntegralDomain_isEuclidean.Build (polynomial F) poly_size_mull edivP. HB.instance Definition _ := EuclideanDomain.on {poly F}. HB.instance Definition _ := BezoutDomain.on {poly F}. End PolyPriField. (****) Section PolyPriFieldTheory. Variable F : fieldType. Lemma dvdr_dvdp (p q : {poly F}) : (dvdr p q) = (dvdp p q). Proof. by apply/dvdrP/Pdiv.Field.dvdpP. Qed. End PolyPriFieldTheory. (****) End PolyPriField. coqeal-2.1.0/theory/rank.v000066400000000000000000000065201475512565300154320ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq. From mathcomp Require Import ssralg fintype fingroup perm. From mathcomp Require Import matrix bigop zmodp mxalgebra. Require Import gauss. Import GRing.Theory. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section FieldRank. Variable F : fieldType. Local Open Scope ring_scope. Fixpoint rank_elim {m n : nat} : 'M[F]_(m, n) -> nat := if n is p.+1 then fun (M : 'M_(m, 1 + p)) => if find_pivot M is Some k then let a := fun_of_matrix M k 0 in let u := rsubmx (row k M) in let R := row' k M in let v := a^-1 *: lsubmx R in let R := rsubmx R - v *m u in (1 + rank_elim R)%N else rank_elim (rsubmx M) else fun => 0%N. Lemma rank_row0mx (m n p : nat) (M : 'M[F]_(m,n)) : \rank (row_mx (0: 'M[F]_(m,p)) M) = \rank M. Proof. by rewrite -mxrank_tr tr_row_mx trmx0 -addsmxE adds0mx mxrank_tr. Qed. Lemma rank_block0dl m n a Aur (Adr : 'M[F]_(m,n)) : a != 0 -> \rank (block_mx (a%:M : 'M_1) Aur 0 Adr) = (1 + \rank Adr)%N. Proof. move=> nz_a. rewrite /block_mx -addsmxE mxrank_disjoint_sum. rewrite rank_row0mx rank_rV. have->//: row_mx a%:M Aur != 0. apply/eqP => /matrixP/(_ 0 0); rewrite !mxE. by case: splitP => // j _; rewrite ord1 !mxE; move/eqP: nz_a. apply/eqP/rowV0P => v0; rewrite sub_capmx; case/andP=> /sub_rVP [k Hv0k]. rewrite Hv0k; case/submxP => D /matrixP/(_ 0 0); rewrite !mxE. case: splitP => // j _; rewrite ord1 mxE mulr1n big1. by move/eqP; rewrite mulf_eq0 (negbTE nz_a) orbF => /eqP ->; rewrite scale0r. by move=> i _; rewrite !mxE; case: splitP=> // l _; rewrite mxE mulr0. Qed. Lemma row'_row_perm m n M k : row' k M = dsubmx (row_perm (lift_perm 0 k 1%g) M : 'M[F]_(1 + m, n)). Proof. by apply/matrixP=> i j; rewrite !mxE rshift1 lift_perm_lift perm1. Qed. Lemma row_row_perm m n (M : 'M[F]_(1 + m, n)) k : row k M = @usubmx _ 1 _ _ (row_perm (lift_perm 0 k 1%g) M). Proof. by apply/matrixP=> i j; rewrite !mxE ord1 lshift0 lift_perm_id. Qed. Lemma rank_elimP m n (M : 'M_(m, n)) : rank_elim M = \rank M. Proof. elim: n m M => [m M|n IHn m]; first by rewrite thinmx0 mxrank0. rewrite -[n.+1]/(1 + n)%N => M /=. rewrite /find_pivot. have [|nz_Mk0] /= := pickP; last first. rewrite -{2}[M]hsubmxK. suff->: lsubmx M = 0 by rewrite rank_row0mx. apply/matrixP => i j; rewrite !mxE ord1 lshift0. by have /(_ i)/negbFE/eqP -> := nz_Mk0. case: m M => [M []|m] //. rewrite -[m.+1]/(1 + m)%N => M k /= nz_Mk0; rewrite IHn. pose P : 'M[F]_(1 + m) := perm_mx (lift_perm 0 k 1%g). have->: \rank M = \rank (P *m M). by rewrite eqmxMfull // row_full_unit unitmx_perm. rewrite -row_permE. set xM : 'M[F]_(1 + m, 1 + n) := row_perm _ _. pose D : 'M[F]_(1 + m) := block_mx 1%:M 0 (- (M k 0)^-1 *: (dlsubmx xM)) 1%:M. have hD : row_full D. by rewrite row_full_unit unitmxE !det_lblock !det1 !mul1r unitr1. rewrite -(eqmxMfull xM hD) -[xM]submxK mulmx_block !mul1mx !mul0mx !addr0. rewrite scaleNr mulNmx [ulsubmx xM]mx11_scalar !mxE !lshift0 lift_perm_id. rewrite mul_mx_scalar scalerA divrr ?unitfE // scale1r addNr rank_block0dl //. rewrite {3}/xM /drsubmx /dlsubmx -row'_row_perm addrC /ursubmx -row_row_perm. by rewrite mulNmx. Qed. End FieldRank. coqeal-2.1.0/theory/similar.v000066400000000000000000000523471475512565300161470ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype fintype finfun ssrnat seq. From mathcomp Require Import choice ssralg poly polydiv mxpoly matrix bigop. From mathcomp Require Import mxalgebra perm fingroup tuple. Require Import mxstructure dvdring. (** This file contains the definitions of similarity and equivalence between two matrices, and the proofs of some properties about these notions. similar M N == The matrices M and N are similar. equivalent M N == The matrices M and N are equivalent. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section complements. Lemma seq2_ind (T1 T2 : Type) (P : seq T1 -> seq T2 -> Prop) : P [::] [::] -> (forall x1 x2 s1 s2, P s1 s2 -> P (x1 :: s1) (x2 :: s2)) -> forall s1 s2, size s1 = size s2 -> P s1 s2. Proof. move=> HP IHP. elim=> [|x1 l1 IH1]; case=> // x2 l2 /= Hs. apply: IHP; apply: IH1. by move/eqnP: Hs=> /= /eqnP. Qed. End complements. (****************************************************************************) (****************************************************************************) (************ left pseudo division, it is complement of polydiv. ************) (****************************************************************************) (****************************************************************************) Import GRing.Theory. Import Pdiv.Ring. Import Pdiv.RingMonic. Local Open Scope ring_scope. Module RPdiv. Section RingPseudoDivision. Variable R : ringType. Implicit Types d p q r : {poly R}. Definition id_converse_def := (fun x : R => x : R^c). Lemma add_id : additive id_converse_def. Proof. by []. Qed. HB.instance Definition _ := GRing.isAdditive.Build R R^c id_converse_def add_id. Definition id_converse : {additive _ -> _} := id_converse_def. Lemma expr_rev (x : R) k : (x : R^c) ^+ k = x ^+ k. Proof. by elim:k=> // k IHk; rewrite exprS exprSr IHk. Qed. Definition phi (p : {poly R}^c) := map_poly id_converse p. Fact phi_is_rmorphism : multiplicative phi. Proof. split=> [p q|]; apply/polyP=> i; last by rewrite coef_map !coef1. by rewrite coefMr coef_map coefM; apply: eq_bigr => j _; rewrite !coef_map. Qed. HB.instance Definition _ := GRing.Additive.copy phi phi. HB.instance Definition _ := GRing.isMultiplicative.Build _ _ _ phi_is_rmorphism. Definition phi_inv (p : {poly R^c}) := map_poly (fun x : R^c => x : R) p : {poly R}^c. Lemma phiK : cancel phi phi_inv. Proof. by move=> p; rewrite /phi_inv -map_poly_comp_id0 // map_poly_id. Qed. Lemma phi_invK : cancel phi_inv phi. Proof. by move=> p; rewrite /phi -map_poly_comp_id0 // map_poly_id. Qed. Lemma phi_bij : bijective phi. Proof. by exists phi_inv; first exact: phiK; exact: phi_invK. Qed. Lemma monic_map_inj (aR rR : ringType) (f : aR -> rR) (p : {poly aR}) : injective f -> f 0 = 0 -> f 1 = 1 -> map_poly f p \is monic = (p \is monic). Proof. move=> inj_f eq_f00 eq_f11; rewrite !monicE lead_coef_map_inj ?rmorph0 //. by rewrite -eq_f11 inj_eq. Qed. Definition redivp_l (p q : {poly R}) : nat * {poly R} * {poly R} := let:(d,q,p) := (redivp (phi p) (phi q)) in (d, phi_inv q, phi_inv p). Definition rdivp_l p q := ((redivp_l p q).1).2. Definition rmodp_l p q := (redivp_l p q).2. Definition rscalp_l p q := ((redivp_l p q).1).1. Definition rdvdp_l p q := rmodp_l q p == 0. Definition rmultp_l := [rel m d | rdvdp_l d m]. Lemma ltn_rmodp_l p q : (size (rmodp_l p q) < size q) = (q != 0). Proof. have := ltn_rmodp (phi p) (phi q). rewrite -(rmorph0 phi) (inj_eq (can_inj phiK)) => <-. rewrite /rmodp_l /redivp_l /rmodp; case: (redivp _ _)=> [[k q'] r'] /=. by rewrite !size_map_inj_poly. Qed. End RingPseudoDivision. Module mon. Section MonicDivisor. Variable R : ringType. Implicit Types p q r : {poly R}. Variable d : {poly R}. Hypothesis mond : d \is monic. Lemma rdivp_l_eq p : p = d * (rdivp_l p d) + (rmodp_l p d). Proof. have mon_phi_d: phi d \is monic by rewrite monic_map_inj. apply: (can_inj (@phiK R)); rewrite {1}[phi p](rdivp_eq mon_phi_d) rmorphD. rewrite rmorphM /rdivp_l /rmodp_l /redivp_l /rdivp /rmodp. by case: (redivp _ _)=> [[k q'] r'] /=; rewrite !phi_invK. Qed. End MonicDivisor. End mon. End RPdiv. (****************************************************************************) (****************************************************************************) (****************************************************************************) (****************************************************************************) Section SimilarDef. Local Open Scope ring_scope. Import GRing.Theory. Variable R : comUnitRingType. Definition similar m n (A : 'M[R]_m) (B : 'M[R]_n) := m = n /\ exists2 P, P \in unitmx & P *m A = (conform_mx P B) *m P. Lemma similar0 m (A : 'M[R]_0) (B : 'M[R]_m) : (0 = m)%N -> similar A B. Proof. move=> H; split=> //. exists 1%:M; first exact: unitmx1. by apply/matrixP; case. Qed. Lemma similar_sym m : forall n (A : 'M[R]_m) (B : 'M[R]_n), similar A B -> similar B A. Proof. case=> [A B [H1 H2]|n A B [Hmn]]. by apply: similar0; rewrite H1. move: A; rewrite Hmn => A [P HP HPA]. split=> //; exists P^-1; first by rewrite unitmx_inv. rewrite !conform_mx_id -1?[A *m _]mul1mx -?(mulVmx HP) in HPA *. by rewrite mulmxA -(mulmxA P^-1) HPA -!mulmxA mulmxV // mulmx1. Qed. Lemma similar_trans m n p (B : 'M[R]_n) (A : 'M[R]_m) (C : 'M[R]_p) : similar A B -> similar B C -> similar A C. Proof. case=> [Hmn HAB] [Hnp]. move: Hmn Hnp A B C HAB=> -> -> A B C [P HP HAB] [Q HQ HBC]. split=> //; exists (Q *m P); first by rewrite unitmx_mul HP HQ. by rewrite -mulmxA HAB !conform_mx_id !mulmxA HBC conform_mx_id. Qed. Lemma similar_refl n (A : 'M[R]_n) : similar A A. Proof. split=> //; exists 1%:M; first by rewrite unitmx1. by rewrite conform_mx_id mulmx1 mul1mx. Qed. Lemma similar_det m n (A : 'M[R]_m) (B : 'M[R]_n) : similar A B -> \det A = \det B. Proof. case=> [Hmn]; move: Hmn A B=> -> A B [P HP HAB]. apply: (@mulrI _ (\det P)); first by rewrite -unitmxE. by rewrite -det_mulmx mulrC -det_mulmx HAB conform_mx_id. Qed. Lemma similar_cast n m p (eq1 : m = p) (eq2 : m = p) (A : 'M[R]_n) (B : 'M[R]_m) : similar A (castmx (eq1,eq2) B) <-> similar A B. Proof. by case: _ /eq1 eq2=> eq2; rewrite castmx_id. Qed. Lemma similar_diag_mx_seq m n s1 s2 : m = n -> size s1 = m -> perm_eq s1 s2 -> similar (diag_mx_seq m m s1) (diag_mx_seq n n s2). Proof. move=> eq Hms Hp. have Hs12:= perm_size Hp. have Hs2: size s2 == n by rewrite -Hs12 Hms eq. pose t:= Tuple Hs2. have HE: s2 = t by []. move: Hp; rewrite HE. case/tuple_permP=> p Hp. split=> //; rewrite eq. exists (perm_mx p)^T; first by rewrite unitmx_tr unitmx_perm. apply/matrixP=> i j; rewrite conform_mx_id !mxE (bigD1 j) //= big1 ?addr0. rewrite (bigD1 i) //= big1 ?addr0. rewrite !mxE Hp -tnth_nth tnth_mktuple (tnth_nth 0) HE !eqxx. case: (p j == i) /eqP => Hij; first by rewrite Hij mulr1 mul1r. by rewrite mulr0 mul0r. by move=> k /negbTE Hk; rewrite !mxE eq_sym (inj_eq (@ord_inj _)) Hk mul0r. by move=> k /negbTE Hk; rewrite !mxE (inj_eq (@ord_inj _)) Hk mulr0. Qed. Lemma similar_ulblockmx n1 n2 n3 (Aul : 'M[R]_n1) (Adr : 'M[R]_n3) (Bul : 'M[R]_n2) : similar Aul Bul -> similar (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Adr). Proof. case=> Hn1 [P HP HAB]. have Hu : (block_mx P 0 0 1%:M) \in unitmx. by move=> n; rewrite unitmxE det_ublock det1 mulr1 -unitmxE. split; first by rewrite Hn1. move: Aul P HP HAB Hu; rewrite Hn1=> Aul P HP; rewrite conform_mx_id=> HAB Hu. exists (block_mx P 0 0 1%:M); first exact: Hu. rewrite conform_mx_id !mulmx_block !mul0mx !mulmx0. by rewrite !add0r !addr0 mulmx1 mul1mx HAB. Qed. Lemma similar_drblockmx n1 n2 n3(Aul : 'M[R]_n1) (Adr : 'M[R]_n2) (Bdr : 'M[R]_n3) : similar Adr Bdr -> similar (block_mx Aul 0 0 Adr) (block_mx Aul 0 0 Bdr). Proof. case=> Hn2 [P HP HAB]. have Hu : (block_mx 1%:M 0 0 P) \in unitmx. by move=> n; rewrite unitmxE det_ublock det1 mul1r -unitmxE. split; first by rewrite Hn2. move: Adr P HP HAB Hu; rewrite Hn2=> Adr P HP; rewrite conform_mx_id=> HAB Hu. exists (block_mx 1%:M 0 0 P); first exact: Hu. rewrite conform_mx_id !mulmx_block !mul0mx !mulmx0. by rewrite !add0r !addr0 mulmx1 mul1mx HAB. Qed. Lemma similar_dgblockmx n1 n2 n3 n4 (Aul : 'M[R]_n1) (Adr : 'M[R]_n2) (Bul : 'M[R]_n3) (Bdr : 'M[R]_n4) : similar Aul Bul -> similar Adr Bdr -> similar (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Bdr). Proof. move=> HABu HABd; apply: (similar_trans (B:= (block_mx Bul 0 0 Adr))). exact: similar_ulblockmx. exact: similar_drblockmx. Qed. Lemma similar_exp m n (A : 'M[R]_m.+1) (B : 'M_n.+1) k: similar A B -> similar (A ^+ k) (B ^+ k). Proof. case=> /eqP; rewrite eqSS=> /eqP eq [P HP]; move: B. rewrite /similar -eq=> B; rewrite conform_mx_id=> HAB. split=> //; exists P => //; rewrite conform_mx_id. elim: k=> [|k IHk]. by rewrite !expr0 mulmx1 mul1mx. by rewrite exprSr mulmxA IHk -mulmxA HAB exprSr mulmxA. Qed. Lemma similar_poly m n (A : 'M[R]_m.+1) (B : 'M_n.+1) p: similar A B -> similar (horner_mx A p) (horner_mx B p). Proof. case=> /eqP; rewrite eqSS=> /eqP eq [P HP]; move: B. rewrite /similar -eq=> B; rewrite conform_mx_id=> HAB. split=> //; exists P => //; rewrite conform_mx_id. elim/poly_ind: p=>[|p c IHp]. by rewrite !rmorph0 mulmx0 mul0mx. rewrite !rmorphD !rmorphM /= !horner_mx_X !horner_mx_C. by rewrite mulmxDr mulmxDl mulmxA IHp -mulmxA HAB mulmxA scalar_mxC. Qed. Lemma similar_horner n m (A : 'M[R]_n.+1) (B : 'M_m.+1) p : similar A B -> horner_mx A p = 0 -> horner_mx B p = 0. Proof. move/(similar_poly p)=> HAB HhA; move: HAB; rewrite HhA. case=> /eqP; rewrite eqSS=> /eqP eq [P HP]. rewrite -eq in B *; rewrite conform_mx_id mulmx0=> H. by apply: (mulIr HP); rewrite mul0r. Qed. Lemma similar_diag_block : forall l1 l2, size l1 = size l2 -> forall (F1 F2 : forall n : nat, nat -> 'M[R]_n.+1), (forall i, i < size l1 -> similar (F1 (nth 0%N l1 i) i) (F2 (nth 0%N l2 i) i)) -> similar (diag_block_mx l1 F1) (diag_block_mx l2 F2). Proof. case=>[|a l1]; case=> //=. by move=> *; apply: similar_refl. move=> b l2 /eqP; rewrite eqSS=> /eqP Hsl F1 F2 Hl. have Hab: similar (F1 a 0%N) (F2 b 0%N) by exact: (Hl 0%N). move: l1 l2 Hsl a b F1 F2 Hab Hl. apply: seq2_ind=> //= x1 x2 l1 l2 IH a b F1 F2 Hab H. apply: (similar_dgblockmx Hab). apply: IH=>[|i]; first exact: (H 1%N). exact: (H i.+1). Qed. End SimilarDef. Section EquivalentDef. Variable R : comUnitRingType. Local Open Scope ring_scope. Import GRing.Theory. Definition equivalent m1 n1 m2 n2 (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) := [/\ m1 = m2, n1 = n2 & exists M N, [/\ M \in unitmx, N \in unitmx & M *m A *m N = conform_mx A B]]. Lemma equiv0l n m p (A : 'M[R]_(0,n)) (B : 'M[R]_(m,p)) : (0 = m)%N -> (n = p)%N -> equivalent A B. Proof. move=> eq1 eq2; split=> //. exists 1%:M, 1%:M; split; try exact: unitmx1. by apply/matrixP; case. Qed. Lemma equiv0r n m p (A : 'M[R]_(n,0)) (B : 'M[R]_(m,p)) : (n = m)%N -> (0 = p)%N -> equivalent A B. Proof. move=> eq1 eq2; split=> //. exists 1%:M, 1%:M; split; try exact: unitmx1. by apply/matrixP=> i; case. Qed. Lemma similar_equiv m n (A : 'M_m) (B : 'M_n) : similar A B -> equivalent A B. Proof. case; case: m A B; case: n => //; first by move=> A B _ _; apply: equiv0r. move=> m n A B eq [P HP HAB]. split=> //; exists P, P^-1; split=> //; first by rewrite unitmx_inv. rewrite {}HAB -mulmxA mulmxV //; move: B. by rewrite -eq=> B; rewrite !conform_mx_id mulmx1. Qed. Lemma equiv_refl m n (A : 'M[R]_(m,n)) : equivalent A A. Proof. split=> //; exists 1%:M, 1%:M. by split; rewrite ?unitmx1 // conform_mx_id mulmx1 mul1mx. Qed. Lemma equiv_sym m1 n1 m2 n2 (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) : equivalent A B -> equivalent B A. Proof. case: m2 A B=> [A B [eq1 eq2 _]|]; first by apply/equiv0l/esym. case: n2=> [m2 A B [eq1 eq2 _]|]; first by apply/equiv0r/esym. case: m1=> [m2 n2 A B []|] //. case: n1=> [m1 m2 n2 A B []|n1 m1 n2 m2 A B [eq1 eq2 [M [N [HM HN HAB]]]]] //. split; try exact: esym. move: B HAB; rewrite -eq1 -eq2=> B; rewrite !conform_mx_id=> HAB. exists M^-1, N^-1; split; rewrite ?unitmx_inv //. by rewrite -HAB !mulmxA mulVmx // mul1mx -mulmxA mulmxV // mulmx1. Qed. Lemma equiv_trans m1 n1 m2 n2 m3 n3 (B : 'M[R]_(m2,n2)) (A : 'M[R]_(m1,n1)) (C : 'M[R]_(m3,n3)) : equivalent A B -> equivalent B C -> equivalent A C. Proof. case=> eqm12 eqn12 [M1 [N1 [HM1 HN1 HAB]]]. case=> eqm23 eqn23 [M2 [N2 [HM2 HN2 HBC]]]. split; [exact: (etrans eqm12) | exact: (etrans eqn12)|]. move: A B M1 N1 M2 N2 HM1 HN1 HM2 HN2 HAB HBC. rewrite eqm12 eqn12 eqm23 eqn23=> A B M1 N1 M2 N2 HM1 HN1 HM2 HN2. rewrite !conform_mx_id=> HAB HBC. exists (M2 *m M1), (N1 *m N2); split; try by rewrite unitmx_mul; apply/andP. by rewrite -!(mulmxA M2) (mulmxA (_ *m A)) HAB mulmxA. Qed. Lemma equiv_ulblockmx m1 n1 m2 n2 m3 n3 (Aul : 'M[R]_(m1,n1)) (Adr : 'M[R]_(m2,n2)) (Bul : 'M[R]_(m3,n3)) : equivalent Aul Bul -> equivalent (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Adr). Proof. case=> eqm eqn [M [N [HM HN HAB]]]. split; rewrite ?eqm ?eqn //. move: Aul M N HM HN HAB; rewrite eqm eqn => Aul M N HM HN. rewrite !conform_mx_id=> HAB. exists (block_mx M 0 0 1%:M), (block_mx N 0 0 1%:M). split; try by rewrite unitmxE det_ublock det1 mulr1 -unitmxE. by rewrite !mulmx_block !mulmx0 !mul0mx !addr0 !mul0mx !add0r mulmx1 mul1mx HAB. Qed. Lemma equiv_drblockmx m1 n1 m2 n2 m3 n3 (Aul : 'M[R]_(m1,n1)) (Adr : 'M[R]_(m2,n2)) (Bdr : 'M[R]_(m3,n3)) : equivalent Adr Bdr -> equivalent (block_mx Aul 0 0 Adr) (block_mx Aul 0 0 Bdr). Proof. case=> eqm eqn [M [N [HM HN HAB]]]. split; rewrite ?eqm ?eqn //. move: Adr M N HM HN HAB; rewrite eqm eqn=> Adr M N HM HN. rewrite !conform_mx_id=> HAB. exists (block_mx 1%:M 0 0 M), (block_mx 1%:M 0 0 N). split; try by rewrite unitmxE det_ublock det1 mul1r -unitmxE. by rewrite !mulmx_block !mulmx0 !mul0mx !addr0 !mul0mx !add0r mulmx1 mul1mx HAB. Qed. Lemma equiv_dgblockmx m1 n1 m2 n2 m3 n3 m4 n4 (Aul : 'M[R]_(m1,n1)) (Adr : 'M[R]_(m2,n2)) (Bul : 'M[R]_(m3,n3)) (Bdr : 'M[R]_(m4,n4)) : equivalent Aul Bul -> equivalent Adr Bdr -> equivalent (block_mx Aul 0 0 Adr) (block_mx Bul 0 0 Bdr). Proof. move=> HABu HABd; apply: (equiv_trans (B:=(block_mx Bul 0 0 Adr))). exact: equiv_ulblockmx. exact: equiv_drblockmx. Qed. Lemma equiv_cast m1 n1 m2 n2 m3 n3 (eqm : m2 = m3) (eqn : n2 = n3) (A : 'M[R]_(m1,n1)) (B : 'M[R]_(m2,n2)) : equivalent A (castmx (eqm,eqn) B) <-> equivalent A B. Proof. by split; case: m3 / eqm A; case: n3 / eqn B. Qed. Lemma equiv_diag_block : forall l1 l2, size l1 = size l2 -> forall (F1 F2 : forall n : nat, nat -> 'M_n.+1), (forall i, i < size l1-> equivalent (F1 (nth 0%N l1 i) i) (F2 (nth 0%N l2 i) i)) -> equivalent (diag_block_mx l1 F1) (diag_block_mx l2 F2). Proof. case=>[|a l1]; case=> //=. by move=> *; exact: equiv_refl. move=> b l2 /eqP; rewrite eqSS=> /eqP Hsl F1 F2 Hl. have Hab: equivalent (F1 a 0%N) (F2 b 0%N) by exact: (Hl 0%N). move: l1 l2 Hsl a b F1 F2 Hab Hl. apply: seq2_ind=> //= x1 x2 l1 l2 IH a b F1 F2 Hab H. apply: (equiv_dgblockmx Hab). apply: IH=>[|i]; first exact: (H 1%N). exact: (H i.+1). Qed. End EquivalentDef. Section Field. Import GRing.Theory. Import polydiv.Pdiv.Ring. Import RPdiv. Import polydiv.Pdiv.RingMonic. Import RPdiv.mon. Variables R : fieldType. Variable m n : nat. Local Open Scope ring_scope. Theorem similar_fundamental (A: 'M[R]_m) (B : 'M[R]_n) : similar A B <-> equivalent (char_poly_mx A) (char_poly_mx B). Proof. constructor. case: n B=> [B [eq _]|n' B]; first by apply/equiv_sym/equiv0l/esym. case: m A=> [A [eq _]|m' A]; first exact: equiv0l. case=> eq [P HP HPA]; split=> //. move: A P HP HPA; rewrite eq=> A P HP; rewrite !conform_mx_id=> HPA. pose M := map_mx polyC P. pose N := map_mx polyC P^-1. have HM: M \in unitmx by rewrite map_unitmx. exists M, N; split=> //; first by rewrite map_unitmx unitmx_inv. rewrite mulmxBr mulmxBl mul_mx_scalar -scalemxAl /M /N map_mx_inv. rewrite (mulmxV HM) scalemx1 -map_mxM HPA -map_mx_inv -map_mxM. by rewrite -mulmxA (mulmxV HP) mulmx1. case:n B=> [B [eq _ _]|n' B]; first by apply/similar_sym/similar0/esym. case: m A=> [A [eq _ _]|m' A]; first exact: similar0. case=> eq _ [M [N [HM HN HA]]]; split=> //. move: A M N HM HN HA; rewrite eq=> A M N HM HN; rewrite conform_mx_id=> HA. have [phi [phi_bij phiZ phiC phiG]] := mx_poly_ring_isom R n'. have: phi M * phi (char_poly_mx A) * phi N = phi (char_poly_mx B). by rewrite -!rmorphM -mulmxE HA. rewrite !{1}rmorphB phiZ !phiC map_polyX=> H. have HphiM: phi M * ('X - A%:P) = ('X - B%:P) * phi N^-1. by rewrite -H -!mulrA -rmorphM mulrV // rmorph1 mulr1. have HphiN: ('X - A%:P) * phi N = phi M^-1 * ('X - B%:P). by rewrite -H !mulrA -rmorphM -mulmxE (mulVmx HM) rmorph1 mul1r. pose M0 := rmodp_l (phi M) ('X - B%:P). pose N0 := rmodp (phi N) ('X - B%:P). pose M1 := rdivp_l (phi M) ('X - B%:P). pose N1 := rdivp (phi N) ('X - B%:P). pose R1 := M1 * phi M^-1 + phi N^-1 * N1 - M1 * ('X - A%:P) * N1. have {}H: M0 * ('X - A%:P) * N0 = (1 - ('X - B%:P) * R1) * ('X - B%:P). have HM1: ('X - B%:P) * M1 = phi M - M0. by rewrite [phi M](rdivp_l_eq (monicXsubC B)) addrK. have HN1: N1 * ('X - B%:P) = phi N - N0. by rewrite [phi N](rdivp_eq (monicXsubC B)) addrK. rewrite /R1 (mulrBr (_ - B%:P)) (mulrDr (_ - B%:P)) !mulrA HM1 mulrBl 2!mulrDl. rewrite mulNr -![_ * N1 * _]mulrA HN1 2!mulrBl. rewrite ![_ * (phi N - N0)]mulrBr ![(phi M - M0) * _]mulrBl. rewrite -[_ * _ * phi N]mulrA -!rmorphM divrr // mulVr // !rmorph1 !mulr1. rewrite mul1r [_ * phi N]mulrBl [(_ - _) * N0]mulrBl H [X in _ = _ + X]opprD. rewrite [X in _ + (X - _)]opprD [X in _ + ((X - _) - _)]opprD !opprK. rewrite !addrA addrN add0r -{1 3}H. rewrite !mulrA -[_ * _ * phi M]mulrA -[_ * _ * phi N^-1]mulrA -!rmorphM. rewrite divrr // mulVr // !rmorph1 !mulr1 opprB addrA. rewrite -{1}[_ + _ - B%:P]addrA subrK (addrC (M0 * _ * _)) addrK. by rewrite opprD opprK addrA addrN add0r. have HM0: size M0 <= 1. by rewrite -ltnS -[leqRHS](size_XsubC B) ltn_rmodp_l polyXsubC_eq0. have HN0: size N0 <= 1. by rewrite -ltnS -[leqRHS](size_XsubC B) ltn_rmodp polyXsubC_eq0. case: (eqVneq R1 0) => HR1; last first. have: size ((1 - ('X - B%:P) * R1) * ('X - B%:P)) <= 2. rewrite -H; apply:(leq_trans (size_mul_leq _ _)). rewrite (size1_polyC HN0) size_polyC -subn1 leq_subLR addnC. apply/(leq_add (leq_b1 _))/(leq_trans (size_mul_leq _ _)). by rewrite (size1_polyC HM0) size_polyC size_XsubC addnC; exact:leq_b1. have Hsize: size (1 - ('X - B%:P) * R1) = (size R1).+1. rewrite addrC size_addl size_opp (size_monicM (monicXsubC B) HR1). by rewrite {1}size_XsubC. rewrite size_polyC oner_neq0 size_XsubC. by move:(size_poly_eq0 R1); case:(size R1)=> //; rewrite (negbTE HR1). rewrite size_Mmonic. + by rewrite Hsize size_XsubC addnC !ltnS leqn0 size_poly_eq0 (negbTE HR1). + by rewrite -size_poly_eq0 Hsize. exact: monicXsubC. move:H; rewrite HR1 mulr0 subr0 mul1r (size1_polyC HM0). rewrite (size1_polyC HN0)=> /polyP H; move:(H 1%N); move:(H 0%N). rewrite !coefMC !coefCM !coefD !coefN !coefC !coefX !eqxx !sub0r subr0 mulr1. rewrite mulrN mulNr; move/eqP; rewrite eqr_opp=> /eqP HM0N0 HM0N0I. case:(mulmx1_unit HM0N0I)=> HM00 HN00. exists (M0`_0) => //; rewrite conform_mx_id -HM0N0 mulmxE -(divr1 N0`_0). by rewrite -[1]HM0N0I invrM // mulrA divrr // mul1r -!mulrA mulVr // mulr1. Qed. Lemma similar_mxminpoly m' n' (A : 'M[R]_m'.+1) (B : 'M[R]_n'.+1) : similar A B -> mxminpoly A = mxminpoly B. Proof. move=> HAB; apply/eqP; rewrite -eqp_monic //; try exact: mxminpoly_monic. apply/andP; split; apply: mxminpoly_min. by apply/(similar_horner (similar_sym HAB))/mx_root_minpoly. by apply/(similar_horner HAB)/mx_root_minpoly. Qed. Lemma similar_char_poly m' n' (A : 'M[R]_m') (B : 'M[R]_n') : similar A B -> char_poly A = char_poly B. Proof. case=> eq [P HP HAB]; rewrite /char_poly /char_poly_mx. have H: map_mx polyC P \in unitmx by rewrite map_unitmx. apply: similar_det; split=> //. rewrite -eq in B HAB *; rewrite conform_mx_id in HAB. exists (map_mx polyC P) => //; rewrite conform_mx_id. by rewrite mulmxDr mulmxDl scalar_mxC mulmxN mulNmx -!map_mxM HAB. Qed. End Field. Section DvdRing. Local Open Scope ring_scope. Import GRing.Theory. Variable R : dvdRingType. Lemma eqd_equiv n m n' m' (s1 s2 : seq R) : n = n' -> m = m' -> size s1 = size s2 -> (forall i, nth 0 s1 i %= nth 0 s2 i) -> equivalent (diag_mx_seq n m s1) (diag_mx_seq n' m' s2). Proof. move=> <- <-. case: n=> [_ _|n]; first exact: equiv0l. case: m=> [_ _|m Hs]; first exact: equiv0r. move: Hs n m. pose P := (fun (s1 s2 : seq R) => forall n m, (forall i, nth 0 s1 i %= nth 0 s2 i) -> equivalent (diag_mx_seq n.+1 m.+1 s1) (diag_mx_seq n.+1 m.+1 s2)). apply: (seq2_ind (P:=P))=> /= [n m _ | x1 x2 s0 s3 IH n m Hi]. by rewrite !diag_mx_seq_nil; apply: equiv_refl. rewrite /P !diag_mx_seq_cons. have IHi: (forall i : nat, s0`_i %= s3`_i). by move=> i; move: (Hi i.+1); rewrite -nth_behead. have Hxp : x1 %= x2 by move: (Hi 0%N); rewrite nth0. have Hx12: (@equivalent _ 1 1 1 1 x1%:M x2%:M). split=> //; case/eqdP: Hxp=> c Hc Hcx. rewrite conform_mx_id. exists c%:M; exists 1%:M; split. + by rewrite -scalemx1 unitmxZ // unitmx1. + by rewrite unitmx1. by rewrite mul_scalar_mx scale_scalar_mx mulmx1 Hcx. apply: (equiv_dgblockmx Hx12). case: n=> [|n]; first exact: equiv0l. case: m=> [|m]; first exact: equiv0r. exact: (IH n m IHi). Qed. End DvdRing. coqeal-2.1.0/theory/smith.v000066400000000000000000000317421475512565300156270ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) (* Require Import ZArith. *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg ssrint ssrnum fintype choice. From mathcomp Require Import matrix mxalgebra bigop zmodp perm. Require Import dvdring mxstructure stronglydiscrete coherent edr. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. Section smith. (* Two-steps approach: 1) Make the first column look like ___ / g \ | g | | . | | . | | g | \___/ 2) For any i j s.t. ~~ g %| M i j, xrow 0 i M, bezout step on the first row and back to 1) *) Variable E : euclidDomainType. Variable find1 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option 'I_m. Variable find2 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option ('I_(1+m) * 'I_n). Variable find_pivot : forall m n, 'M[E]_(1 + m,1 + n) -> option ('I_(1 + m) * 'I_(1 + n)). Hypothesis find1P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, pick_spec [pred i | ~~(a %| E (lift 0 i) 0)] (find1 E a). Hypothesis find2P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, pick_spec [pred ij | ~~(a %| E ij.1 (lift 0 ij.2))] (find2 E a). Hypothesis find_pivotP : forall m n (E : 'M[E]_(1 + m,1 + n)), pick_spec [pred ij | E ij.1 ij.2 != 0] (find_pivot E). Fixpoint improve_pivot_rec k {m n} : 'M[E]_(1 + m) -> 'M[E]_(1 + m, 1 + n) -> 'M[E]_(1 + n) -> 'M[E]_(1 + m) * 'M[E]_(1 + m, 1 + n) * 'M[E]_(1 + n) := if k is p.+1 then fun P M Q => let a := M 0 0 in if find1 M a is Some i then let Mi0 := M (lift 0 i) 0 in let P := Bezout_step a Mi0 P i in let M := Bezout_step a Mi0 M i in improve_pivot_rec p P M Q else let u := dlsubmx M in let vM := ursubmx M in let vP := usubmx P in let u' := map_mx (fun x => 1 - odflt 0 (x %/? a)) u in let P := col_mx (usubmx P) (u' *m vP + dsubmx P) in let M := block_mx (a%:M) vM (const_mx a) (u' *m vM + drsubmx M) in if find2 M a is Some (i,j) then let M := xrow 0 i M in let P := xrow 0 i P in let a := fun_of_matrix M 0 0 in let M0ij := fun_of_matrix M 0 (lift 0 j) in let Q := (Bezout_step a M0ij Q^T j)^T in let M := (Bezout_step a M0ij M^T j)^T in improve_pivot_rec p P M Q else (P, M, Q) else fun P M Q => (P,M,Q). Definition improve_pivot k m n (M : 'M[E]_(1 + m, 1 + n)) := improve_pivot_rec k 1 M 1. (* TODO: Why is this so slow?? *) Fixpoint Smith m n : 'M[E]_(m,n) -> 'M[E]_(m) * seq E * 'M[E]_(n) := match m, n with | _.+1, _.+1 => fun M : 'M[E]_(1 + _, 1 + _) => if find_pivot M is Some (i, j) then let a := fun_of_matrix M i j in let M := xrow i 0 (xcol j 0 M) in (* this is where Euclidean norm eases termination argument *) let: (P,M,Q) := improve_pivot (enorm a) M in let a := fun_of_matrix M 0 0 in let u := dlsubmx M in let v := ursubmx M in let v' := map_mx (fun x => odflt 0 (x %/? a)) v in let M := ((drsubmx M) - (const_mx 1 *m v)) in let: (P', d, Q') := Smith (map_mx (fun x => odflt 0 (x %/? a)) M) in ((lift0_mx P' *m block_mx 1%:M 0 (- const_mx 1) 1%:M *m (xcol i 0 P)), a :: [seq x * a | x <- d], (xrow j 0 Q *m block_mx 1 (- v') 0 1%:M *m lift0_mx Q')) else (1, [::], 1) | _, _ => fun M => (1%:M, [::], 1%:M) end. Variant improve_pivot_rec_spec m n P M Q : 'M_(1 + m) * 'M_(1 + m,1 + n) * 'M[E]_(1 + n) -> Type := ImprovePivotQecSpec P' M' Q' of P^-1 *m M *m Q^-1 = P'^-1 *m M' *m Q'^-1 & (forall i j, M' 0 0 %| M' i j) & (forall i, M' i 0 = M' 0 0) & M' 0 0 %| M 0 0 & P' \in unitmx & Q' \in unitmx : improve_pivot_rec_spec P M Q (P',M',Q'). Lemma unitrmxE k (M : 'M[E]_k.+1) : (M \is a GRing.unit) = (M \in unitmx). Proof. by []. Qed. Definition unitmxEE := (unitmx_mul, unitmx_tr, unit_Bezout_mx, unitmx_perm). Lemma improve_pivot_recP : forall k m n (P : 'M_(1 + m)) (M : 'M_(1 + m,1 + n)) Q, (enorm (M 0%R 0%R) <= k)%N -> M 0 0 != 0 -> P \in unitmx -> Q \in unitmx -> improve_pivot_rec_spec P M Q (improve_pivot_rec k P M Q). Proof. elim=> [m n L M R0|k IHk m n L M R0 Hk nzM00 unitL unitR /=]. by rewrite leqn0 => /eqP /enorm_eq0 ->; rewrite eqxx. case: find1P=> [i Hi|Hi]. have [||||L' A' R' HA' ? ? Hdiv HL' HR'] // := IHk; do ?constructor => //. + by rewrite -ltnS (leq_trans (ltn_enorm nzM00 (sdvd_Bezout_step Hi)) Hk). + by rewrite -eqdr0 (congr_eqd (Bezout_step_mx00 M) (eqdd _)) eqdr0 gcdr_eq0 (negbTE nzM00). + by rewrite Bezout_stepE !unitmxEE. + rewrite -HA' !Bezout_stepE invrM ?unit_Bezout_mx // !mulmxA. by congr (_ *m _ *m _); rewrite -mulmxA mulVmx ?unit_Bezout_mx // mulmx1. + rewrite (eqd_dvd (eqdd _) (Bezout_step_mx00 _)) in Hdiv. exact: (dvdr_trans Hdiv (dvdr_gcdl _ _)). set P := map_mx _ _. have Hblock : (matrix.block_mx 1 0 P 1%:M) *m M = matrix.block_mx (M 0 0)%:M (matrix.ursubmx M) (matrix.const_mx (M 0 0)) (P *m matrix.ursubmx M + matrix.drsubmx M). rewrite -{1}[M]submxK mulmx_block !mul0mx !mul1mx !addr0 [matrix.ulsubmx M]mx11_scalar 2!mxE !lshift0. congr matrix.block_mx; rewrite mul_mx_scalar. apply/matrixP=> p q; rewrite ord1 !mxE lshift0 mulrBr mulr1 !rshift1. case: odivrP=> [d ->|]; first by rewrite mulrC subrK. by case/dvdrP:(negbFE (Hi p))=> x -> /(_ x); rewrite eqxx. have unit_block : matrix.block_mx 1 0 P 1%:M \in unitmx by rewrite unitmxE (det_lblock 1 P) !det1 mul1r unitr1. have HblockL : (matrix.block_mx 1 0 P 1%:M) *m L = matrix.col_mx (matrix.usubmx L) (P *m matrix.usubmx L + matrix.dsubmx L) by rewrite -{1}[L]vsubmxK mul_block_col !mul1mx mul0mx addr0. case: find2P=> [[i j]|Hij] /=. set B := matrix.block_mx _ _ _ _; set A := matrix.xrow _ _ B => Hij. have HMA: M 0 0 = A^T 0 0. rewrite /A /B -{4}(lshift0 n 0) !mxE tpermL. by case: splitP=> [i' _|i' Hi']; rewrite ?ord1 row_mxEl mxE ?eqxx. rewrite HMA in nzM00 Hk Hij; rewrite -[A]trmxK [A^T^T^T]trmxK ![A^T^T _ _]mxE. case: IHk => [||||L' A' R' HA' ? ? Hdiv HL' HR']; do ?constructor=> //. + rewrite -ltnS mxE (leq_trans _ Hk) ?(ltn_enorm nzM00) ?sdvd_Bezout_step //. by rewrite {2}/A [_ (lift _ _) _]mxE [matrix.xrow _ _ _ _ _]mxE tpermL. + by rewrite mxE -eqdr0 (congr_eqd (Bezout_step_mx00 _) (eqdd _)) eqdr0 gcdr_eq0 (negbTE nzM00). + by rewrite xrowE -HblockL !unitmxEE unit_block. + by rewrite !Bezout_stepE !unitmxEE. + rewrite -HA' ![(A^T) 0 _]mxE /A /B -Hblock -HblockL !xrowE. rewrite !Bezout_stepE !trmx_mul !trmxK !invrM //. - rewrite !mulmxA -[_ / _ *m _]mulmxA mulVmx ?unitmx_perm // mulmx1. rewrite -[_ / _ *m _]mulmxA mulVmx // mulmx1 -[_ *m _^T *m _]mulmxA. by rewrite mulmxV ?unitmx_tr ?unit_Bezout_mx // mulmx1. - by rewrite unitmx_tr unit_Bezout_mx. - by rewrite unitmx_perm. by rewrite !unitmxEE unit_block. rewrite (dvdr_trans Hdiv) // mxE (eqd_dvd (Bezout_step_mx00 _) (eqdd _)) HMA. exact: dvdr_gcdl. constructor=> //; first by rewrite -HblockL -Hblock invrM // mulmxA mulmxKV. + rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => i j. rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0) block_mxEul mxE eqxx !mxE. (* Why do we have to specify all these arguments? *) case: splitP=> i' Hi'; rewrite mxE; case: splitP=> j' Hj'; rewrite ?mxE ?ord1 //=. by move: (negbFE (Hij (lshift m 0,j'))); rewrite -rshift1 block_mxEur !mxE. by move: (negbFE (Hij (lift 0 i',j'))); rewrite -!rshift1 block_mxEdr !mxE. + rewrite -[m.+1]/(1 + m)%N => i. rewrite -{5}(lshift0 m 0) -{3 6}(lshift0 n 0) (block_mxEul (M 0 0)%:M _) !mxE eqxx /=. by case: splitP=> i' _; rewrite row_mxEl !mxE // ord1. + rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0). by rewrite (block_mxEul (M 0 0)%:M (matrix.ursubmx M)) mxE dvdrr. by rewrite -HblockL unitmx_mul unitmxE (det_lblock 1 P) !det1 mulr1 unitr1. Qed. Variant improve_pivot_spec m n M : 'M[E]_(1 + m) * 'M_(1 + m,1 + n) * 'M_(1 + n) -> Type := ImprovePivotSpec L A R of L *m M *m R = A & (forall i j, A 0 0 %| A i j) & (forall i, A i 0 = A 0 0) & A 0 0 %| M 0 0 & L \in unitmx & R \in unitmx : improve_pivot_spec M (L,A,R). Lemma improve_pivotP k m n (M : 'M_(1 + m, 1 + n)) : (enorm (M 0%R 0%R) <= k)%N -> M 0 0 != 0 -> improve_pivot_spec M (improve_pivot k M). Proof. move=> ? ?; rewrite /improve_pivot. have := (@improve_pivot_recP k _ _ 1%:M M 1%:M). rewrite /improve_pivot_rec=> [[]] //; rewrite ?unitmx1 //. rewrite !invr1 mul1mx mulmx1 => ? ? ? eqM ? ? ? ? ?. by constructor=> //; rewrite eqM !mulmxA mulmxV // mul1mx mulmxKV. Qed. Lemma SmithP : forall (m n : nat) (M : 'M_(m,n)), smith_spec M (Smith M). Proof. elim=> [n M|m IHn]; first constructor; rewrite ?unitmx1 //. rewrite [M]flatmx0 mulmx1 mul1mx; apply/matrixP=> i j. by rewrite !mxE nth_nil mul0rn. case=> [M|n M /=]; first constructor; rewrite ?sorted_nil ?mxE ?unitmx1 //. rewrite [M]thinmx0 mulmx1 mul1mx; apply/matrixP=> i j. by rewrite !mxE nth_nil mul0rn. case: find_pivotP =>[[i j] HMij | H]. case: improve_pivotP; rewrite ?mxE ?tpermR ?leqnn //. rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => L A R0 HA Hdiv HAi0 HA00. set A' := map_mx _ _; set v' := map_mx _ _. case: IHn=> L' d R' Hd Hsorted HL' HR' HL HR; constructor. * rewrite xcolE xrowE -!mulmxA (mulmxA M) -xcolE (mulmxA (tperm_mx _ _)). rewrite -xrowE (mulmxA L) (mulmxA _ R0) HA mulmx_block !mulmxA mulmx_block. rewrite -{1}(submxK A) !mulmx_block. do 2! rewrite !mul0mx !mulmx0 !mulmx1 !mul1mx !addr0 ?add0r. have Hu: matrix.const_mx 1 *m matrix.ulsubmx A = matrix.dlsubmx A. rewrite [matrix.ulsubmx A]mx11_scalar mul_mx_scalar; apply/matrixP=> k l. by rewrite ord1 !mxE mulr1 !lshift0 !HAi0. have Hv': (matrix.ulsubmx A *m v') = matrix.ursubmx A. apply/matrixP=> k l. rewrite (ord1 k) !mxE big_ord_recl big_ord0 !mxE !lshift0 addr0. case: odivrP=>[x ->|H]; first by rewrite mulrC. by case/dvdrP:(Hdiv 0 (rshift 1 l))=> q /eqP; rewrite (negbTE (H q)). rewrite diag_mx_seq_cons; congr matrix.block_mx. (* Pivot *) + by apply/matrixP=> k l; rewrite !ord1 !mxE !lshift0 eqxx. (* Horizontal zeros *) + by rewrite mulNmx mulmxN mulmxA Hv' addNr. (* Vertical zeros *) + by rewrite mulmxN mulNmx -mulmxA Hu addNr. (* down-right submatrix *) + rewrite mulmxN !mulNmx -mulmxA Hu addNr mul0mx add0r addrC -mulmxA -mulmxBr. transitivity (A 0 0 *: (L' *m A' *m R')). rewrite -[_ *m A' *m _]mulmxA scalemxAr scalemxAl. have Hdiv' : forall i j, A 0 0 %| (matrix.drsubmx A - matrix.const_mx 1 *m matrix.ursubmx A) i j. by move=> k l; rewrite !mxE big_ord1 !mxE mul1r dvdr_sub ?Hdiv. have -> : A 0 0 *: A' = matrix.drsubmx A - matrix.const_mx 1 *m matrix.ursubmx A. apply/matrixP=> k l; rewrite 2!mxE. case: odivrP=>[x ->|H]; first by rewrite mulrC. by case/dvdrP:(Hdiv' k l)=> q /eqP; rewrite (negbTE (H q)). by rewrite mulmxA. rewrite Hd; apply/matrixP=> k l; rewrite !mxE. case: eqP => /=; last by rewrite mulr0. case: (ltnP k (size d)) => Hk. by rewrite (nth_map 0 _ _ Hk) mulrC. by rewrite !nth_default ?size_map ?Hk // mulr0. * have {}HA00: A 0 0 != 0. by apply/eqP=> H; move:HA00; rewrite H dvd0r (negbTE HMij). rewrite /= path_min_sorted; last by apply/allP=> a /mapP [b _ ->]; exact:dvdr_mull. case: d Hsorted {Hd} => //= a d; elim: d a=> //= a1 d IHd a0 /andP[a01 /IHd]. by rewrite dvdr_mul2r ?a01. * rewrite xcolE !unitmx_mul unitmx_perm HL !unitmxE. by rewrite !det_lblock !det1 mul1r mulr1 unitr1 -unitmxE !andbT. * rewrite xrowE !unitmx_mul unitmx_perm HR !unitmxE. by rewrite 2!det_ublock 2!det1 2!mul1r unitr1 -unitmxE. constructor =>[|||]; rewrite ?mxE ?unitmx1 //. rewrite mul1mx mulmx1; apply/matrixP=> i j; rewrite !mxE (eqP (negbFE (H (i,j)))). by case: (i == j :> nat); rewrite ?nth_nseq ?if_same nth_nil. Qed. (* Why is this so slow??? *) Lemma size_Smith m n (A : 'M_(m,n)) : let: (_, d, _) := Smith A in (size d <= minn m n)%N. Proof. elim: m n A=>[n'|m' Ih n']; first by rewrite min0n. case: n'=>[|n' A /=]; first by rewrite minn0. case: find_pivotP=> [[x1 x2] Hx|//]. case: (improve_pivot _ _); case => a b c /=; set M := map_mx _ _. case H: (Smith _) (Ih n' M) => [[i s] k] /=. by rewrite size_map minnSS ltnS. Qed. End smith. HB.factory Record hasSmith E of EuclideanDomain E := { find1 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option 'I_m; find2 : forall m n, 'M[E]_(m.+1,n.+1) -> E -> option ('I_(1+m) * 'I_n); find_pivot : forall m n, 'M[E]_(1 + m,1 + n) -> option ('I_(1 + m) * 'I_(1 + n)); find1P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, pick_spec [pred i | ~~(a %| E (lift 0 i) 0)] (find1 _ _ E a); find2P : forall m n (E : 'M[E]_(1 + m,1 + n)) a, pick_spec [pred ij | ~~(a %| E ij.1 (lift 0 ij.2))] (find2 _ _ E a); find_pivotP : forall m n (E : 'M[E]_(1 + m,1 + n)), pick_spec [pred ij | E ij.1 ij.2 != 0] (find_pivot _ _ E) }. HB.builders Context E of hasSmith E. HB.instance Definition _ := DvdRing_isEDR.Build E (SmithP find1P find2P find_pivotP). HB.end. coqeal-2.1.0/theory/smith_complements.v000066400000000000000000000354451475512565300202410ustar00rootroot00000000000000From mathcomp Require Import all_ssreflect. From mathcomp Require Import all_algebra. From mathcomp Require Import all_fingroup. From mathcomp Require Import all_real_closed. From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor. From CoqEAL Require Import smith dvdring polydvd. From CoqEAL Require Import similar perm_eq_image. (** This file is a complement of the file Smith.v of the CoqEAL library. We prove here the unicity of the Smith normal form of a matrix. The algorithm described in the file Smith.v takes a matrix M of type 'M_(m,n) and returns a triple (L,s,R) where s is the sequence such that diag_mx_seq m n s is the Smith normal form of M, and L and R are the transition matrices (i.e diag_mx_seq m n s = L * M * R). In this context we have the following definitions : Smith_seq M == The sequence s of the triple (L,s,R). Smith_form M == diag_mx_seq m n (Smith_seq M). *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Section Specification. Import GRing.Theory. Local Open Scope ring_scope. Variable E : euclidDomainType. Definition find1 m n (A : 'M[E]_(m.+1, n.+1)) (v : E) : option 'I_m := pick [pred i | ~~(v %| A (lift 0 i) 0)]. Lemma find1P m n (A : 'M[E]_(m.+1, n.+1)) (v : E) : pick_spec [pred i | ~~(v %| A (lift 0 i) 0)] (find1 A v). Proof. exact: pickP. Qed. Definition find2 m n (A : 'M[E]_(m.+1, n.+1)) (v : E) : option ('I_m.+1 * 'I_n) := pick [pred ij | ~~(v %| A ij.1 (lift 0 ij.2))] . Lemma find2P m n (A : 'M[E]_(m.+1, n.+1)) v : pick_spec [pred ij | ~~(v %| A ij.1 (lift 0 ij.2))] (find2 A v). Proof. exact: pickP. Qed. Definition find_pivot m n (A : 'M[E]_(m.+1, n.+1)) : option ('I_m.+1 * 'I_n.+1) := pick [pred ij | A ij.1 ij.2 != 0]. Lemma find_pivotP m n (A : 'M[E]_(m.+1, n.+1)) : pick_spec [pred ij | A ij.1 ij.2 != 0] (find_pivot A). Proof. exact: pickP. Qed. Definition Smith_seq n m (M: 'M[E]_(n,m)) := let: (L,d,R) := (Smith find1 find2 find_pivot M) in if d is a :: d' then (\det L)^-1 * (\det R)^-1 *a :: d' else nil. Definition Smith_form n m (M: 'M[E]_(n,m)) := diag_mx_seq n m (Smith_seq M). Lemma equiv_Smith n m (M: 'M[E]_(n,m)) : equivalent M (Smith_form M). Proof. case: n m M=>[m M|n]; first exact: equiv0l. case=>[M|m M]; first exact: equiv0r. rewrite /Smith_form /Smith_seq. case: (SmithP find1P find2P find_pivotP) => L0 d R0 H _ HL0 HR0; split=> //. exists ((@block_mx _ 1 _ 1 _ ((\det L0)^-1 / \det R0)%:M 0 0 1%:M) *m L0). exists R0; split=> //. rewrite unitmxE detM unitrM (@det_lblock _ 1 n) det_scalar1 det1 mulr1. by rewrite unitrM !unitrV -!unitmxE HL0 HR0. rewrite conform_mx_id -!mulmxA (mulmxA L0) H. case: d H =>[|a l _] ; first by rewrite !diag_mx_seq_nil mulmx0. rewrite !diag_mx_seq_cons (@mulmx_block _ 1 _ 1 _ 1). by rewrite !mulmx0 !mul0mx !add0r addr0 mul1mx -scalar_mxM. Qed. Lemma sorted_Smith n m (M: 'M[E]_(n,m)): sorted (@dvdr E) (Smith_seq M). Proof. rewrite /Smith_seq. case: (SmithP find1P find2P find_pivotP) => L0 d R0 _ H HL0 HR0. case: d H=> //= a l H. have/allP Ha: all (%|%R a) l by exact: (order_path_min (@dvdr_trans _)). rewrite path_min_sorted; [exact: (path_sorted H) | apply/allP=> x Hx]. apply/(dvdr_trans _ (Ha x Hx))/dvdrP; exists (\det R0 * \det L0). by rewrite -invrM ?mulVKr // unitrM -!unitmxE HR0. Qed. Lemma det_Smith n (M: 'M[E]_n) : \det (Smith_form M) = \det M. Proof. rewrite /Smith_form /Smith_seq. case: n M=>[M|n M]; first by rewrite !det_mx00. case: (SmithP find1P find2P find_pivotP)=> L0 d R0 H _ HL0 HR0. case: d H=>[|a l]. rewrite !diag_mx_seq_nil -{1}(mul0mx _ R0)=> /(mulIr HR0). by rewrite -{1}(mulmx0 _ L0)=> /(mulrI HL0)=> ->. rewrite !diag_mx_seq_cons (@det_ublock _ 1) scalar_mxM detM -mulrA. rewrite -(det_ublock a%:M 0)=> <-. rewrite !detM -invrM -?unitmxE // det_scalar1 (mulrC (\det L0)). rewrite -mulrA mulrC -(mulrA (\det M)) (mulrC (\det L0)) mulrV ?mulr1 //. by rewrite unitrM -!unitmxE HR0. Qed. Lemma size_Smith_seq n (M: 'M[E]_n) : \det M != 0 -> size (take n (Smith_seq M)) = n. Proof. move=> HdM0; rewrite size_take; apply: minn_idPl. apply: contra_neqT HdM0=>/negbTE H. by rewrite -det_Smith /Smith_form det_diag_mx_seq_truncated H. Qed. End Specification. Section Preunicity. Import GRing.Theory. Import PolyPriField. Variable E : euclidDomainType. Variables (s : seq E) (m n k : nat) (A : 'M[E]_(m,n)). Hypothesis (Hk : (k <= minn m n)%N) (Hs: sorted %|%R s). Hypothesis (HAs : equivalent A (diag_mx_seq m n s)). Let widen_minl i := widen_ord (geq_minl m n) i. Let widen_minr i := widen_ord (geq_minr m n) i. Lemma minor_diag_mx_seq : let l := minn m n in forall (f g : 'I_k -> 'I_l), let f' i := widen_minl (f i) in let g' i := widen_minr (g i) in injective f -> injective g -> {subset codom f <= codom g} -> minor f' g' (diag_mx_seq m n s) %= \prod_i s`_(f i). Proof. rewrite /minor. elim: k=>[f g|j IHj f g Hf Hg Hfg]; first by rewrite det_mx00 big_ord0. have := perm_eq_image Hf Hg Hfg. have Ht : size (codom g) == j.+1 by rewrite size_codom card_ord. have -> : image g 'I_j.+1 = Tuple Ht by []. case/tuple_permP=> p Hp. have Hfg0 i : g (p i) = f i. have He: (i < #|'I_j.+1|)%N by rewrite card_ord. have {2}->: i = enum_val (Ordinal He) by rewrite enum_val_ord; apply: ord_inj. rewrite -(nth_image (f ord0)) Hp -tnth_nth tnth_mktuple (tnth_nth (f ord0)). by rewrite /= codomE (nth_map ord0) ?nth_ord_enum // size_enum_ord. rewrite (expand_det_row _ ((p^-1)%g ord0)) big_ord_recl big1=>[|i _]. rewrite /cofactor !mxE. set B := diag_mx_seq _ _ _. set M := row' _ _. pose f2 x := f (lift ((p^-1)%g ord0) x). pose g2 x := g (lift ord0 x). have Hf2: injective f2. by apply/(inj_comp Hf)/lift_inj. have Hg2: injective g2. by apply/(inj_comp Hg)/lift_inj. pose f' i := widen_ord (geq_minl m n) (f2 i). pose g' i := widen_ord (geq_minr m n) (g2 i). have ->: M = submatrix f' g' B. by apply/matrixP=> r t; rewrite !mxE. have Hfg2: {subset codom f2 <= codom g2}. move=> x /codomP [y ->]. rewrite codomE /f2 /g2 -Hfg0 map_comp (mem_map Hg). set i := p _. have:= mem_ord_enum i. rewrite -enum_ord_enum enum_ordSl in_cons -(permKV p ord0). by rewrite /i (inj_eq (@perm_inj _ _)) eq_sym (negbTE (neq_lift _ _)). rewrite addr0 (bigD1 ((p^-1)%g ord0)) //= -Hfg0 permKV eqxx eqd_mull //. rewrite -[X in _ %= X]mul1r eqd_mul ?eqd1 ?unitrX ?unitrN ?unitr1 //. rewrite (eq_bigl (fun i => (p^-1)%g ord0 != i)) ?big_lift_ord /=; last first. by move=> i /=; rewrite eq_sym. exact: (IHj _ _ Hf2 Hg2 Hfg2). rewrite !mxE /= (inj_eq (@ord_inj _)) -Hfg0 (inj_eq Hg) permKV. by rewrite (negbTE (neq_lift _ _)) mul0r. Qed. Lemma prod_minor_seq : \prod_(i < k) s`_i = minor [ffun x : 'I_k => widen_minl (widen_ord Hk x)] [ffun x : 'I_k => widen_minr (widen_ord Hk x)] (diag_mx_seq m n s). Proof. rewrite /minor /submatrix. elim: k Hk=>[H|j /= IHj Hj]; first by rewrite det_mx00 big_ord0. have IH:= ltnW Hj. apply: esym; rewrite (expand_det_row _ ord_max) big_ord_recr /= big1 ?add0r. rewrite /cofactor /col' /row' !mxE !ffunE !matrix_comp. rewrite eqxx exprD -expr2 sqrr_sign mul1r. set M := matrix_of_fun _ _. have ->: M = (\matrix_(i, j) (diag_mx_seq m n s) ([ffun x => widen_minl (widen_ord IH x)] i) ([ffun x => widen_minr (widen_ord IH x)] j)). apply/matrixP=> i l; rewrite !mxE !ffunE. have Hr: forall p, widen_ord Hj (lift ord_max p) = widen_ord IH p. by move=> p; apply: ord_inj=> /=; rewrite /bump leqNgt (ltn_ord p) add0n. by rewrite !Hr. by rewrite -(IHj IH) big_ord_recr /= mulrC. move=> i _; rewrite !mxE !ffunE /=. by rewrite eqn_leq leqNgt (ltn_ord i) andFb mul0r. Qed. Lemma minor_eq0l (R : comRingType) k1 m1 n1 (s1 : seq R) x : forall (f : 'I_k1 -> 'I_m1) g, (n1 <= f x)%N -> minor f g (diag_mx_seq m1 n1 s1) = 0. Proof. move=> f g H. rewrite /minor (expand_det_row _ x) big1 // => i _. by rewrite !mxE gtn_eqF ?mul0r // (leq_trans _ H). Qed. Lemma minor_eq0r (R : comRingType) k1 m1 n1 (s1 : seq R) x : forall f (g : 'I_k1 -> 'I_n1) , (m1 <= g x)%N -> minor f g (diag_mx_seq m1 n1 s1) = 0. Proof. move=> f g H. rewrite /minor (expand_det_col _ x) big1 // => i _. by rewrite !mxE ltn_eqF ?mul0r // (leq_trans _ H). Qed. Lemma eqd_seq_gcdr : \prod_(i < k) s`_i %= \big[(@gcdr E)/0]_(f : {ffun 'I_k -> 'I_m}) (\big[(@gcdr E)/0]_(g : {ffun 'I_k -> 'I_n}) minor f g (diag_mx_seq m n s)). Proof. apply/andP; split; last first. rewrite prod_minor_seq; set j := [ffun _ => _]. by apply/(dvdr_trans (big_dvdr_gcdr _ j))/big_dvdr_gcdr. apply: big_gcdrP=> f; apply: big_gcdrP=> g. case: (injectiveb f) /injectiveP=> Hinjf; last first. by rewrite (minor_f_not_injective _ _ Hinjf) dvdr0. case: (injectiveb g) /injectiveP=> Hinjg; last first. by rewrite (minor_g_not_injective _ _ Hinjg) dvdr0. have Hmin k1 i m1 n1 (h : 'I_k1 -> 'I_m1) : (minn m1 n1 <= h i -> n1 <= h i)%N. move=> Hhi; have := (leq_ltn_trans Hhi (ltn_ord (h i))). by rewrite gtn_min ltnn=> /ltnW/minn_idPr <-. case: (altP (@forallP _ (fun i => f i < minn m n)%N))=>[Hwf|]; last first. rewrite negb_forall=> /existsP [x]; rewrite -leqNgt=> /Hmin Hx. by rewrite (minor_eq0l _ _ Hx) dvdr0. case: (altP (@forallP _ (fun i => g i < minn m n)%N))=>[Hwg|]; last first. rewrite negb_forall=> /existsP [x]; rewrite -leqNgt minnC=> /Hmin Hx. by rewrite (minor_eq0r _ _ Hx) dvdr0. pose f1 i := Ordinal (Hwf i). pose g1 i := Ordinal (Hwg i). have Hinjf1 : injective f1. by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjf. have Hinjg1 : injective g1. by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjg. case/boolP: (codom f1 \subset codom g1); last first. case/subsetPn => x /codomP [y Hy] Habs. rewrite /minor (expand_det_row _ y). rewrite [\sum_(_ <_) _](big1 _ xpredT) ?dvdr0 // => j _. rewrite !mxE -[(g j : nat)]/(g1 j : nat) -[(f y : nat)]/(f1 y : nat). suff /negbTE->: (f1 y != g1 j :> nat) by rewrite mul0r. by apply: contraNneq Habs =>/ord_inj H; rewrite Hy H codom_f. move/subsetP => Hcfg. pose f' i := widen_minl (f1 i). pose g' i := widen_minr (g1 i). have ->: minor f g (diag_mx_seq m n s) = minor f' g' (diag_mx_seq m n s). by apply: minor_eq=> i; apply: ord_inj. rewrite (eqd_dvdr _ (minor_diag_mx_seq Hinjf1 Hinjg1 Hcfg)) //. move: Hinjf1; clear -Hs; move: f1; clear -Hs. elim: k =>[?|j /= IHj g Hg]; first by rewrite big_ord0 dvd1r. rewrite big_ord_recr /=. pose max:= \max_i (g i). have [l Hl]: {j | max = g j} by apply: eq_bigmax; rewrite card_ord. pose p := tperm l ord_max. set B := \prod_(_ < _) _. rewrite (reindex_inj (@perm_inj _ p)) /= big_ord_recr /= dvdr_mul //. pose f := g \o p \o (widen_ord (leqnSn j)). have Hf: injective f. apply: inj_comp=> [|x y /eqP]. by apply: inj_comp=> //; exact: perm_inj. by rewrite -(inj_eq (@ord_inj _)) /= => H; apply/ord_inj/eqP. have Hi: injective (finfun f). by move=> x e; rewrite !ffunE; exact: Hf. set C := \prod_(_ < _) _. suff ->: C = \prod_i s`_(finfun f i) by apply: IHj. by apply: eq_bigr=> i _; rewrite ffunE. have jleg : (j <= g (p ord_max))%N. rewrite /= tpermR; case: ltngtP => // Hgm. have Habs: forall i, (g i < j)%N. move=> i; apply: (leq_ltn_trans _ Hgm). by rewrite -Hl /k; exact: (leq_bigmax i). pose f := fun x => Ordinal (Habs x). have Hf: injective f. move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP Hxy. by apply/Hg/ord_inj. have: (#|'I_j.+1| <= #|'I_j|)%N. by rewrite -(card_codom Hf); exact: max_card. by rewrite !card_ord ltnn. have [glts | sleg] := ltnP (g (p ord_max)) (size s); last first. by rewrite (nth_default 0 sleg); exact: dvdr0. apply: sorted_leq_nth=>//; first exact: dvdr_trans. by rewrite inE; apply/leq_ltn_trans/glts. Qed. Lemma Smith_gcdr_spec : \prod_(i < k) s`_i %= \big[(@gcdr E)/0]_(f : {ffun 'I_k -> 'I_m}) (\big[(@gcdr E)/0]_(g : {ffun 'I_k -> 'I_n}) minor f g A) . Proof. rewrite (eqd_ltrans eqd_seq_gcdr). have [ _ _ [M [N [_ _ Heqs]]]]:= HAs. have [ _ _ [P [Q [_ _ Hseq]]]]:= (equiv_sym HAs). rewrite conform_mx_id in Heqs. rewrite conform_mx_id in Hseq. have HdivmA p q k1 (B C : 'M[E]_(p,q)) (M1 : 'M_p) (N1 : 'M_q) : forall (H : M1 *m C *m N1 = B), forall (f : 'I_k1 -> 'I_p) (g : 'I_k1 -> 'I_q), \big[(@gcdr E)/0]_(f0 : {ffun 'I_k1 -> _}) \big[(@gcdr E)/0]_(g0 : {ffun 'I_k1 -> _}) minor f0 g0 C %| minor f g B. move=> H f g. have HBC: minor f g B = \sum_(f0 : {ffun _ -> _ } | strictf f0) ((\sum_(g0 : {ffun _ -> _ } | strictf g0) (minor id g0 (submatrix f id M1) * minor g0 f0 C)) * minor f0 id (submatrix id g N1)). rewrite -H /minor submatrix_mul BinetCauchy. apply: eq_bigr=> i _; congr GRing.mul; rewrite /minor. rewrite sub_submatrix submatrix_mul BinetCauchy. by apply: eq_bigr=> j _; rewrite /minor !sub_submatrix. rewrite HBC; apply: big_dvdr=> h; rewrite dvdr_mulr //. apply: big_dvdr=> j; rewrite dvdr_mull //. by apply: (dvdr_trans (big_dvdr_gcdr _ j)); apply: big_dvdr_gcdr. apply/andP; split; apply: big_gcdrP=> f; apply: big_gcdrP=> g. exact: (HdivmA _ _ _ _ _ _ _ Hseq). exact: (HdivmA _ _ _ _ _ _ _ Heqs). Qed. End Preunicity. Section Unicity. Import GRing.Theory. Import PolyPriField. Variable E : euclidDomainType. Lemma Smith_unicity n (A : 'M[E]_n) (s : seq E) : sorted %|%R s -> equivalent A (diag_mx_seq n n s) -> forall i, (i < n)%N -> s`_i %= (Smith_seq A)`_i. Proof. move=> Hs HAs i. have Hsmt := sorted_Smith A. have HAsmt := equiv_Smith A. elim: i {-2}i (leqnn i)=>[i|i IHi j Hji]. rewrite leqn0 -[X in (i < X)%N]minnn=> /eqP -> Hi. move: (Smith_gcdr_spec Hi Hs HAs). move: (Smith_gcdr_spec Hi Hsmt HAsmt). rewrite !big_ord_recl !big_ord0 !mulr1 eqd_sym => H1 H2. exact: (eqd_trans H2 H1). rewrite -[X in (j < X)%N]minnn=> Hj. move: (Smith_gcdr_spec Hj Hs HAs). move: (Smith_gcdr_spec Hj Hsmt HAsmt). rewrite !big_ord_recr /= eqd_sym => H1 H2. have {H1 H2} H3:= eqd_trans H2 H1. have H1: \prod_(i < j) s`_i %= \prod_(i < j) (Smith_seq A)`_i. rewrite minnn in Hj. apply: eqd_big_mul=> k _; apply: IHi. exact: (leq_trans (ltn_ord k) Hji). exact: (ltn_trans _ Hj). case: (eqVneq (\prod_(i < j) s`_i) 0) => H0; last first. by rewrite -(eqd_mul2l _ _ H0) (eqd_rtrans (eqd_mulr _ H1)). have/prodf_eq0 [k _ /eqP Hk]: (\prod_(i < j) (Smith_seq A)`_i == 0). by rewrite H0 eqd0r in H1. case/eqP/prodf_eq0: H0 => l _ /eqP Hl. have sj0 : s`_j == 0. have [ jlts | slej ] := ltnP j (size s); last first. by rewrite (nth_default 0 slej). rewrite -dvd0r -{1}Hl. apply: sorted_leq_nth => //. + exact: dvdr_trans. + by rewrite inE (ltn_trans _ jlts). + exact: ltnW. have smsj0 : (Smith_seq A)`_j == 0. have [ jlts | slej ] := ltnP j (size (Smith_seq A)); last first. by rewrite (nth_default 0 slej). rewrite -dvd0r -{1}Hk. apply: sorted_leq_nth => //. + exact: dvdr_trans. + by rewrite inE (ltn_trans _ jlts). + exact: ltnW. by rewrite (eqP sj0) (eqP smsj0). Qed. End Unicity. coqeal-2.1.0/theory/smithpid.v000066400000000000000000000331521475512565300163210ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. (* Require Import ZArith. *) From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg ssrint ssrnum fintype choice. From mathcomp Require Import matrix mxalgebra bigop zmodp perm. Require Import dvdring mxstructure stronglydiscrete coherent edr. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. (* Two-steps approach: 1) Make the first column look like ___ / g \ | g | | . | | . | | g | \___/ 2) For any i j s.t. ~~ g %| M i j, xrow 0 i M, bezout step on the first row and back to 1) *) HB.factory Record SmithPID R of PID R := { find1 : forall m n, 'M[R]_(m.+1,n.+1) -> R -> option 'I_m; find2 : forall m n, 'M[R]_(m.+1,n.+1) -> R -> option ('I_(1 + m) * 'I_n); find1P : forall m n (M : 'M[R]_(1 + m,1 + n)) a, pick_spec [pred i | ~~(a %| M (lift 0 i) 0)] (find1 _ _ M a); find2P : forall m n (M : 'M[R]_(1 + m,1 + n)) a, pick_spec [pred ij | ~~(a %| M ij.1 (lift 0 ij.2))] (find2 _ _ M a); find_pivot : forall m n, 'M[R]_(1 + m,1 + n) -> option ('I_(1 + m) * 'I_(1 + n)); find_pivotP : forall m n (M : 'M[R]_(1 + m,1 + n)), pick_spec [pred ij | M ij.1 ij.2 != 0] (find_pivot _ _ M) }. HB.builders Context R of SmithPID R. (* This lemma is used in the termination proof of improve_pivot_rec *) Lemma sdvd_Bezout_step2 m n i j u' vM (M : 'M[R]_(1 + m, 1 + n)) : let B : 'M_(1 + m, 1 + n) := block_mx (M 0 0)%:M vM (const_mx (M 0 0)) (u' *m vM + drsubmx M) in let C := xrow 0 i B in ~~ (M 0 0 %| B i (lift 0 j)) -> (Bezout_step (C 0 0) (C 0 (lift 0 j)) C^T j)^T 0 0 %<| M 0 0. Proof. set B := block_mx _ _ _ _ => /=. set C := xrow _ _ _. have ->: M 0 0 = C^T 0 0. rewrite /C /B -(lshift0 n 0) !mxE tpermL. by case: splitP=> [i' _|i' Hi']; rewrite ?ord1 row_mxEl mxE ?eqxx. move=> ndvd. rewrite mxE. rewrite -[C]trmxK [C^T^T^T]trmxK ![C^T^T _ _]mxE sdvd_Bezout_step //. by rewrite {2}/C [_ (lift _ _) _]mxE [matrix.xrow _ _ _ _ _]mxE tpermL. Qed. Fixpoint improve_pivot_rec {m n} (P : 'M[R]_(1 + m)) (M : 'M[R]_(1 + m, 1 + n)) (Q : 'M[R]_(1 + n)) (k : Acc (@sdvdr [the dvdRingType of R]) (M 0 0)) : 'M[R]_(1 + m) * 'M[R]_(1 + m, 1 + n) * 'M[R]_(1 + n) := match k with Acc_intro IHa => if find1P M (M 0 0) is Pick i Hi then let Ai0 := M (lift 0 i) 0 in let P := Bezout_step (M 0 0) Ai0 P i in improve_pivot_rec P Q (IHa _ (sdvd_Bezout_step Hi)) else let u := dlsubmx M in let vM := ursubmx M in let vP := usubmx P in let u' := map_mx (fun x => 1 - odflt 0 (x %/? M 0 0)) u in let P := col_mx (usubmx P) (u' *m vP + dsubmx P) in let A := block_mx (M 0 0)%:M vM (const_mx (M 0 0)) (u' *m vM + drsubmx M) in if find2P A (M 0 0) is Pick (i,j) Hij then let A := xrow 0 i A in let P := xrow 0 i P in let a := A 0 0 in let A0j := A 0 (lift 0 j) in let Q := (Bezout_step a A0j Q^T j)^T in improve_pivot_rec P Q (IHa _ (sdvd_Bezout_step2 Hij)) else (P, A, Q) end. Definition improve_pivot m n (M : 'M[R]_(1 + m, 1 + n)) := improve_pivot_rec 1 1 (sdvdr_wf (M 0 0)). Fixpoint Smith {m n} : 'M[R]_(m,n) -> 'M[R]_(m) * seq R * 'M[R]_(n) := match m, n return 'M[R]_(m, n) -> 'M[R]_(m) * seq R * 'M[R]_(n) with | _.+1, _.+1 => fun M : 'M[R]_(1 + _, 1 + _) => if find_pivot M is Some (i, j) then let a := fun_of_matrix M i j in let A := xrow i 0 (xcol j 0 M) in let: (P,A,Q) := improve_pivot A in let a := fun_of_matrix A 0 0 in let u := dlsubmx A in let v := ursubmx A in let v' := map_mx (fun x => odflt 0 (x %/? a)) v in let A := ((drsubmx A) - (const_mx 1 *m v)) in let: (P', d, Q') := Smith (map_mx (fun x => odflt 0 (x %/? a)) A) in ((lift0_mx P' *m block_mx 1%:M 0 (- const_mx 1) 1%:M *m (xcol i 0 P)), a :: [seq x * a | x <- d], (xrow j 0 Q *m block_mx 1 (- v') 0 1%:M *m lift0_mx Q')) else (1, [::], 1) | _, _ => fun M => (1%:M, [::], 1%:M) end. Variant improve_pivot_rec_spec m n P M Q : 'M[R]_(1 + m) * 'M[R]_(1 + m,1 + n) * 'M[R]_(1 + n) -> Type := ImprovePivotRecSpec P' A Q' of P^-1 *m M *m Q^-1 = P'^-1 *m A *m Q'^-1 & (forall i j, A 0 0 %| A i j) & (forall i, A i 0 = A 0 0) & A 0 0 %| M 0 0 & P' \in unitmx & Q' \in unitmx : improve_pivot_rec_spec P M Q (P',A,Q'). Lemma unitrmxE k (M : 'M[R]_k.+1) : (M \is a GRing.unit) = (M \in unitmx). Proof. by []. Qed. Definition unitmxEE := (unitmx_mul, unitmx_tr, unit_Bezout_mx, unitmx_perm). Scheme Acc_rect_dep := Induction for Acc Sort Type. Lemma improve_pivot_recP : forall m n (P : 'M_(1 + m)) (M : 'M_(1 + m,1 + n)) Q (k : Acc (@sdvdr [the dvdRingType of R]) (M 0 0)), M 0 0 != 0 -> P \in unitmx -> Q \in unitmx -> improve_pivot_rec_spec P M Q (improve_pivot_rec P Q k). Proof. move=> m n P M Q k. rewrite -/(ecast a (Acc (fun x y : R => x %<| y) a) (erefl (M 0 0)) k). move: (erefl _) => eq_M00; move: eq_M00 k. move: {1 3 5}(fun_of_matrix M 0 0) => a eq_a k. elim/Acc_rect_dep: k M P Q eq_a => a' Acc_a' IHa' M P Q eq_a' nzM00 unitL unitR /=. move: (eq_a') Acc_a' IHa'. rewrite eq_a' => {}eq_a' Acc_a' IHa'; rewrite {eq_a'}[eq_a']eq_axiomK /=. case: find1P=> [i Hi|Hi]. set P0 := Bezout_step _ _ P _; set M0 := Bezout_step _ _ M _. have /(_ erefl) [|||P' A' Q' HA' ? ? Hdiv HP' HQ'] // := IHa' (M0 0 0) (sdvd_Bezout_step Hi) M0 P0 Q. + by rewrite -eqdr0 (congr_eqd (Bezout_step_mx00 M) (eqdd _)) eqdr0 gcdr_eq0 (negbTE nzM00). + by rewrite /P0 Bezout_stepE !unitmxEE. + constructor=> //. rewrite -HA' /P0 /M0 !Bezout_stepE invrM ?unit_Bezout_mx // !mulmxA. by congr (_ *m _ *m _); rewrite -mulmxA mulVmx ?unit_Bezout_mx // mulmx1. + rewrite (eqd_dvd (eqdd _) (Bezout_step_mx00 _)) in Hdiv. exact: (dvdr_trans Hdiv (dvdr_gcdl _ _)). set M' := map_mx _ _. have Hblock : (matrix.block_mx 1 0 M' 1%:M) *m M = matrix.block_mx (M 0 0)%:M (matrix.ursubmx M) (matrix.const_mx (M 0 0)) (M' *m matrix.ursubmx M + matrix.drsubmx M). rewrite -{1}[M]submxK mulmx_block !mul0mx !mul1mx !addr0 [matrix.ulsubmx M]mx11_scalar 2!mxE !lshift0. congr matrix.block_mx; rewrite mul_mx_scalar. apply/matrixP=> p q; rewrite ord1 !mxE lshift0 mulrBr mulr1 !rshift1. case: odivrP=> [d ->|]; first by rewrite mulrC subrK. by case/dvdrP:(negbFE (Hi p))=> x -> /(_ x); rewrite eqxx. have unit_block : matrix.block_mx 1 0 M' 1%:M \in unitmx by rewrite unitmxE (det_lblock 1 M') !det1 mul1r unitr1. have HblockP : (matrix.block_mx 1 0 M' 1%:M) *m P = matrix.col_mx (matrix.usubmx P) (M' *m matrix.usubmx P + matrix.dsubmx P) by rewrite -{1}[P]vsubmxK mul_block_col !mul1mx mul0mx addr0. case: find2P=> [[i j]|Hij] /=. set B := matrix.block_mx _ _ _ _; set C := matrix.xrow _ _ B => Hij. have HMA: M 0 0 = C^T 0 0. rewrite /C /B -{4}(lshift0 n 0) !mxE tpermL. by case: splitP=> [i' _|i' Hi']; rewrite ?ord1 row_mxEl mxE ?eqxx. rewrite HMA in nzM00. set P0 := xrow _ _ _; set Q0 := (Bezout_step _ _ Q^T _)^T. set M0 := (Bezout_step _ _ C^T _)^T; set dvd_prf := sdvd_Bezout_step2 _. have /(_ erefl) [|||P' A' Q' HA' ? ? Hdiv HP' HQ'] // := IHa' (M0 0 0) dvd_prf M0 P0 Q0. + rewrite /M0 -[C]trmxK [C^T^T^T]trmxK ![C^T^T _ _]mxE. by rewrite mxE -eqdr0 (congr_eqd (Bezout_step_mx00 _) (eqdd _)) eqdr0 gcdr_eq0 (negbTE nzM00). + by rewrite /P0 xrowE -HblockP !unitmxEE unit_block. + by rewrite /Q0 !Bezout_stepE !unitmxEE. + constructor=> //. + rewrite -HA' /P0 /M0 /Q0 -[C]trmxK [C^T^T^T]trmxK ![C^T^T _ _]mxE. rewrite ![(C^T) 0 _]mxE /C /B -Hblock -HblockP !xrowE. rewrite !Bezout_stepE !trmx_mul !trmxK !invrM //. - rewrite !mulmxA -[_ / _ *m _]mulmxA mulVmx ?unitmx_perm // mulmx1. rewrite -[_ / _ *m _]mulmxA mulVmx // mulmx1 -[_ *m _^T *m _]mulmxA. by rewrite mulmxV ?unitmx_tr ?unit_Bezout_mx // mulmx1. - by rewrite unitmx_tr unit_Bezout_mx. - by rewrite unitmx_perm. by rewrite !unitmxEE unit_block. rewrite /M0 -[C]trmxK [C^T^T^T]trmxK ![C^T^T _ _]mxE in Hdiv. rewrite (dvdr_trans Hdiv) // mxE (eqd_dvd (Bezout_step_mx00 _) (eqdd _)) HMA. exact: dvdr_gcdl. constructor=> //; first by rewrite -HblockP -Hblock invrM // mulmxA mulmxKV. + rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => i j. rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0) block_mxEul mxE eqxx !mxE. (* Why do we have to specify all these arguments? *) case: splitP=> i' Hi'; rewrite mxE; case: splitP=> j' Hj'; rewrite ?mxE ?ord1 //. by move: (negbFE (Hij (lshift m 0,j'))); rewrite -rshift1 block_mxEur !mxE. by move: (negbFE (Hij (lift 0 i',j'))); rewrite -!rshift1 block_mxEdr !mxE. + rewrite -[m.+1]/(1 + m)%N => i. rewrite -{5}(lshift0 m 0) -{3 6}(lshift0 n 0) (block_mxEul (M 0 0)%:M _) !mxE. by case: splitP=> i' _; rewrite row_mxEl !mxE ?ord1. + rewrite -{3}(lshift0 m 0) -{3}(lshift0 n 0). by rewrite (block_mxEul (M 0 0)%:M (matrix.ursubmx M)) mxE dvdrr. by rewrite -HblockP unitmx_mul unitmxE (det_lblock 1 M') !det1 mulr1 unitr1. Qed. Variant improve_pivot_spec m n M : 'M[R]_(1 + m) * 'M[R]_(1 + m,1 + n) * 'M[R]_(1 + n) -> Type := ImprovePivotSpec P A Q of P *m M *m Q = A & (forall i j, A 0 0 %| A i j) & (forall i, A i 0 = A 0 0) & A 0 0 %| M 0 0 & P \in unitmx & Q \in unitmx : improve_pivot_spec M (P,A,Q). Lemma improve_pivotP m n (M : 'M_(1 + m, 1 + n)) : M 0 0 != 0 -> improve_pivot_spec M (improve_pivot M). Proof. move=> ?; rewrite /improve_pivot. have := (@improve_pivot_recP _ _ 1%:M M 1%:M (sdvdr_wf _)). case; rewrite ?unitmx1 // !invr1 mul1mx mulmx1 => ? ? ? eqM ? ? ? ? ?. by constructor=> //; rewrite eqM !mulmxA mulmxV // mul1mx mulmxKV. Qed. Lemma SmithP : forall (m n : nat) (M : 'M_(m,n)), smith_spec M (Smith M). Proof. elim=> [n M|m IHn]. constructor=> //; try by exact: unitmx1. rewrite [M]flatmx0 mulmx1 mul1mx; apply/matrixP => i j. by rewrite !mxE nth_nil mul0rn. case=> [M|n M /=]. constructor=> //; try by exact: unitmx1. rewrite [M]thinmx0 mulmx1 mul1mx; apply/matrixP => i j. by rewrite !mxE nth_nil mul0rn. case: find_pivotP =>[[i j] HMij | H]. case: improve_pivotP; rewrite ?mxE ?tpermR ?leqnn //. rewrite -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N => L B Q0 HB Hdiv HAi0 HA00. set A' := map_mx _ _; set v' := map_mx _ _. case: IHn=> L' d Q' Hd Hsorted HL' HQ' HL HQ; constructor. * rewrite xcolE xrowE -!mulmxA (mulmxA M) -xcolE (mulmxA (tperm_mx _ _)). rewrite -xrowE (mulmxA L) (mulmxA _ Q0) HB mulmx_block !mulmxA mulmx_block. rewrite -{1}(submxK B) !mulmx_block. do 2! rewrite !mul0mx !mulmx0 !mulmx1 !mul1mx !addr0 ?add0r. have Hu: matrix.const_mx 1 *m matrix.ulsubmx B = matrix.dlsubmx B. rewrite [matrix.ulsubmx B]mx11_scalar mul_mx_scalar; apply/matrixP=> k l. by rewrite ord1 !mxE mulr1 !lshift0 !HAi0. have Hv': (matrix.ulsubmx B *m v') = matrix.ursubmx B. apply/matrixP=> k l. rewrite (ord1 k) !mxE big_ord_recl big_ord0 !mxE !lshift0 addr0. case: odivrP=>[x ->|H]; first by rewrite mulrC. by case/dvdrP:(Hdiv 0 (rshift 1 l))=> q /eqP; rewrite (negbTE (H q)). rewrite diag_mx_seq_cons; congr matrix.block_mx. (* Pivot *) + by apply/matrixP=> k l; rewrite !ord1 !mxE !lshift0 eqxx. (* Horizontal zeros *) + by rewrite mulNmx mulmxN mulmxA Hv' addNr. (* Vertical zeros *) + by rewrite mulmxN mulNmx -mulmxA Hu addNr. (* down-right submatrix *) + rewrite mulmxN !mulNmx -mulmxA Hu addNr mul0mx add0r addrC -mulmxA -mulmxBr. transitivity (B 0 0 *: (L' *m A' *m Q')). rewrite -[_ *m A' *m _]mulmxA scalemxAr scalemxAl. have Hdiv' : forall i j, B 0 0 %| (matrix.drsubmx B - matrix.const_mx 1 *m matrix.ursubmx B) i j. by move=> k l; rewrite !mxE big_ord1 !mxE mul1r dvdr_sub ?Hdiv. have -> : B 0 0 *: A' = matrix.drsubmx B - matrix.const_mx 1 *m matrix.ursubmx B. apply/matrixP => k l; rewrite 2!mxE. case: odivrP => [x ->|H]; first by rewrite mulrC. by case/dvdrP:(Hdiv' k l)=> q /eqP; rewrite (negbTE (H q)). by rewrite mulmxA. rewrite Hd; apply/matrixP=> k l; rewrite !mxE. case: eqP => /=; last by rewrite mulr0. case: (ltnP k (size d)) => /= Hk. by rewrite (nth_map 0 _ _ Hk) mulrC. by rewrite !nth_default ?size_map ?Hk // mulr0. * have {}HA00: B 0 0 != 0. by apply/eqP=> H; move:HA00; rewrite H dvd0r (negbTE HMij). rewrite /= path_min_sorted; last by apply/allP => a /mapP [b _ ->]; exact:dvdr_mull. case: d Hsorted {Hd} => //= a d; elim: d a=> //= a1 d IHd a0 /andP[a01 /IHd]. by rewrite dvdr_mul2r ?a01. * rewrite xcolE !unitmx_mul unitmx_perm HL !unitmxE. by rewrite !det_lblock !det1 mul1r mulr1 unitr1 -unitmxE !andbT. * rewrite xrowE !unitmx_mul unitmx_perm HQ !unitmxE. by rewrite 2!det_ublock 2!det1 2!mul1r unitr1 -unitmxE. constructor =>[|||]; rewrite ?mxE ?unitmx1 //. rewrite mul1mx mulmx1; apply/matrixP=> i j; rewrite !mxE (eqP (negbFE (H (i,j)))). by case: (i == j :> nat); rewrite ?nth_nseq ?if_same nth_nil. Qed. (* Why is this so slow??? *) Lemma size_Smith m n (M : 'M_(m,n)) : let: (_, d, _) := Smith M in (size d <= minn m n)%N. Proof. elim: m n M => [n'|m' Ih n']; first by rewrite min0n. case: n' => [|n' M /=]; first by rewrite minn0. case: find_pivotP=> [[x1 x2] Hx|//]. case: (improve_pivot _); case => a b c /=. case H: (Smith _)=>[[i j] k]. rewrite /= size_map minnSS ltnS. move: (Ih n' (map_mx (fun x => odflt 0 (x %/? b 0 0)) (drsubmx b - const_mx 1 *m ursubmx b))). by rewrite H. Qed. HB.instance Definition _ := DvdRing_isEDR.Build R SmithP. HB.end. coqeal-2.1.0/theory/ssralg_ring_tac.v000066400000000000000000000030641475512565300176400ustar00rootroot00000000000000Require Import Ncring Ncring_tac. From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. From mathcomp Require Import div finfun bigop prime binomial ssralg matrix. Section ring_tac. Variable R : ringType. Import GRing.Theory. #[export] Instance Rops: @Ring_ops R 0%R 1%R (@GRing.add R) (@GRing.mul R) (fun a b : R => a - b)%R (@GRing.opp R) eq := {}. #[export] Instance R_is_ring: (@Ring _ _ _ _ _ _ _ _ Rops). constructor=> //. exact:eq_equivalence. by move=> x y H1 u v H2; rewrite H1 H2. by move=> x y H1 u v H2; rewrite H1 H2. by move=> x y H1 u v H2; rewrite H1 H2. by move=> x y H1; rewrite H1. exact:add0r. exact:addrC. exact:addrA. exact:mul1r. exact:mulr1. exact:mulrA. exact:mulrDl. by move=> M N P ; exact:mulrDr. by move=> M; rewrite /addition /add_notation (addrC M) addNr. Qed. #[export] Instance matrix_ops (n : nat) : @Ring_ops 'M[R]_n 0%R (scalar_mx 1) (@addmx R _ _) mulmx (fun M N => addmx M (oppmx N)) (@oppmx R _ _) eq := {}. #[export] Instance matrix_is_ring (n : nat) : (@Ring _ _ _ _ _ _ _ _ (matrix_ops n)). Proof. constructor=> //. + exact:eq_equivalence. + by move=> x y H1 u v H2; rewrite H1 H2. + by move=> x y H1 u v H2; rewrite H1 H2. + by move=> x y H1 u v H2; rewrite H1 H2. + by move=> x y H1; rewrite H1. + exact:add0mx. + exact:addmxC. + exact:addmxA. + exact:mul1mx. + exact:mulmx1. + exact:mulmxA. + exact:mulmxDl. + by move=> M N P ; exact:mulmxDr. + by move=> M; rewrite /addition /add_notation (addmxC M) addNmx. Qed. End ring_tac.coqeal-2.1.0/theory/ssrcomplements.v000066400000000000000000000266341475512565300175650ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype finfun perm matrix bigop zmodp mxalgebra. From mathcomp Require Import choice poly polydiv mxpoly binomial. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (** This file contains definitions and lemmas that are generic enough that we could try to integrate them in Math Components' library. Definitions and theories are gathered according to the file of the library which they could be moved to. *) (** ** Informative version of [iff] *) (** As CoqEAL now puts all relations in [Type], we define a compliant version of [iff], named [ifft], along with view declarations *) Inductive ifft (A B : Type) : Type := Ifft of (A -> B) & (B -> A). Infix "<=>" := ifft (at level 95) : type_scope. Section ApplyIfft. Variables P Q : Type. Hypothesis eqPQ : P <=> Q. Lemma ifft1 : P -> Q. Proof. by case: eqPQ. Qed. Lemma ifft2 : Q -> P. Proof. by case: eqPQ. Qed. End ApplyIfft. Hint View for move/ ifft1|2 ifft2|2. Hint View for apply/ ifft1|2 ifft2|2. Lemma ifftW (P Q : Prop) : P <=> Q -> (P <-> Q). Proof. by case. Qed. (********************* seq.v *********************) Section Seq. Variables (T1 T2 T3 : Type) (f : T1 -> T2 -> T3). Lemma seq2_ind (P : seq T1 -> seq T2 -> Prop) : P [::] [::] -> (forall x1 x2 s1 s2, P s1 s2 -> P (x1 :: s1) (x2 :: s2)) -> forall s1 s2, size s1 = size s2 -> P s1 s2. Proof. move=> Pnil Pcons. elim=> [|x1 l1 IH1]; case=> // x2 l2 /eqnP /= Hs. by apply/Pcons/IH1/eqnP. Qed. End Seq. Section Seqeqtype. Variable T : eqType. Variable leT : rel T. Hypothesis leT_tr : transitive leT. Lemma sorted_drop (s : seq T) m : sorted leT s -> sorted leT (drop m s). Proof. by elim: s m => //= a l ih [|n h] //; apply/ih/(path_sorted h). Qed. Lemma subseq_take (s : seq T) m : subseq (take m s) s. Proof. by elim: s m => // a l ih [] //= n; rewrite eqxx. Qed. Lemma sorted_take (s : seq T) m : sorted leT s -> sorted leT (take m s). Proof. move=> H; exact: (subseq_sorted leT_tr (subseq_take _ _) H). Qed. End Seqeqtype. (******************** bigop.v ********************) Section BigOp. Import GRing.Theory. Variable R : comRingType. Variable T : eqType. Open Scope ring_scope. (*** This lemma is usefull to prove that \mu_x p = count_mem x s where s is the sequence of roots of polynomial p ***) Lemma prod_seq_count (s : seq T) (F : T -> R) : \prod_(i <- s) F i = \prod_(i <- (undup s)) ((F i) ^+ (count (xpred1 i) s)). Proof. elim: s=> /= [|a l IHl]; first by rewrite !big_nil. rewrite big_cons IHl. set r:= if _ then _ else _. have ->: \big[*%R/1]_(i <- r) (F i) ^+ ((a == i) + count (eq_op^~ i) l) = \big[*%R/1]_(i <- r) (F i) ^+ (a == i) * \big[*%R/1]_(i <- r) (F i) ^+ (count (eq_op^~ i) l). by rewrite -big_split /=; apply: eq_bigr=> i _; rewrite exprD. have ->: \big[*%R/1]_(i <- r) (F i) ^+ (a == i) = F a. rewrite /r; case: ifP=>[|notal]. rewrite -mem_undup=> aundl. rewrite (bigD1_seq _ aundl (undup_uniq l)) /= eqxx big1 ?mulr1 //. by move=> i /negbTE neqai; rewrite eq_sym neqai. rewrite big_cons eqxx big1_seq ?mulr1 // => i /= iundl. case: (eqVneq a i) => //= eqai. by rewrite eqai -mem_undup iundl in notal. rewrite /r; case: ifP=> // /negbT notal. rewrite big_cons. have->: count (xpred1 a) l = 0%N. by apply/eqP; rewrite -leqn0 leqNgt -has_count has_pred1. by rewrite mul1r. Qed. End BigOp. (********************* matrix.v *********************) Section Matrix. Local Open Scope ring_scope. Import GRing.Theory. Section matrix_raw_type. Variable T : Type. Lemma row_thin_mx p q (M : 'M_(p,0)) (N : 'M[T]_(p,q)) : row_mx M N = N. Proof. apply/matrixP=> i j; rewrite mxE; case: splitP=> [|k H]; first by case. by congr fun_of_matrix; exact: val_inj. Qed. Lemma col_flat_mx p q (M : 'M[T]_(0, q)) (N : 'M_(p,q)) : col_mx M N = N. Proof. apply/matrixP=> i j; rewrite mxE; case: splitP => [|k H]; first by case. by congr fun_of_matrix; exact: val_inj. Qed. End matrix_raw_type. Section matrix_ringType. Variable R : ringType. Lemma mulmx_rsub m n p k (A : 'M[R]_(m, n)) (B : 'M[R]_(n, p + k)) : A *m rsubmx B = (rsubmx (A *m B)). Proof. by apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr => l //= _; rewrite mxE. Qed. Lemma mulmx_lsub m n p k (A : 'M[R]_(m, n)) (B : 'M[R]_(n, p + k)) : A *m lsubmx B = (lsubmx (A *m B)). Proof. by apply/matrixP=> i j; rewrite !mxE; apply: eq_bigr => l //= _; rewrite mxE. Qed. Lemma col_0mx m n (M : 'M[R]_(m, n)) : col_mx (0 :'M_(0%N, _)) M = M. Proof. apply/matrixP=> i j; rewrite !mxE. case: splitP => [[] //|k eq_i_k]; congr (M _ _). by apply: val_inj; rewrite /= eq_i_k. Qed. (* to be replaced by col1 and colE (once they are in mathcomp) *) Lemma col_id_mulmx m n (M : 'M[R]_(m,n)) i : M *m col i 1%:M = col i M. Proof. apply/matrixP=> k l; rewrite !mxE. rewrite (bigD1 i) // big1 /= ?addr0 ?mxE ?eqxx ?mulr1 // => j /negbTE neqji. by rewrite !mxE neqji mulr0. Qed. (* to be replaced by row1 and rowE *) Lemma row_id_mulmx m n (M : 'M[R]_(m,n)) i : row i 1%:M *m M = row i M. Proof. apply/matrixP=> k l; rewrite !mxE. rewrite (bigD1 i) // big1 /= ?addr0 ?mxE ?eqxx ?mul1r // => j /negbTE Hj. by rewrite !mxE eq_sym Hj mul0r. Qed. Lemma row'_col'_char_poly_mx m i (M : 'M[R]_m) : row' i (col' i (char_poly_mx M)) = char_poly_mx (row' i (col' i M)). Proof. apply/matrixP=> k l; rewrite !mxE. suff ->: (lift i k == lift i l) = (k == l) => //. by apply/inj_eq/lift_inj. Qed. Lemma exp_block_mx m n (A: 'M[R]_m.+1) (B : 'M_n.+1) k : (block_mx A 0 0 B) ^+ k = block_mx (A ^+ k) 0 0 (B ^+ k). Proof. elim: k=> [|k IHk]. by rewrite !expr0 -scalar_mx_block. rewrite !exprS IHk /GRing.mul /= (mulmx_block A 0 0 B (A ^+ k)). by rewrite !mulmx0 !mul0mx !add0r !addr0. Qed. Lemma char_block_mx m n (A : 'M[R]_m) (B : 'M[R]_n) : char_poly_mx (block_mx A 0 0 B) = block_mx (char_poly_mx A) 0 0 (char_poly_mx B). Proof. apply/matrixP=> i j; rewrite !mxE. case: splitP=> k Hk; rewrite !mxE; case: splitP=> l Hl; rewrite !mxE; rewrite -!(inj_eq (@ord_inj _)) Hk Hl ?subr0 ?eqn_add2l //. by rewrite ltn_eqF // ltn_addr. by rewrite gtn_eqF // ltn_addr. Qed. End matrix_ringType. Section matrix_comUnitRingType. Variable R : comUnitRingType. Lemma invmx_block n1 n2 (Aul : 'M[R]_n1.+1) (Adr : 'M[R]_n2.+1) : (block_mx Aul 0 0 Adr) \in unitmx -> (block_mx Aul 0 0 Adr)^-1 = block_mx Aul^-1 0 0 Adr^-1. Proof. move=> Hu. have Hu2: (block_mx Aul 0 0 Adr) \is a GRing.unit by []. rewrite unitmxE det_ublock unitrM in Hu. case/andP: Hu; rewrite -!unitmxE => HAul HAur. have H: block_mx Aul 0 0 Adr * block_mx Aul^-1 0 0 Adr^-1 = 1. rewrite /GRing.mul /= (mulmx_block Aul _ _ _ Aul^-1) !mulmxV //. by rewrite !mul0mx !mulmx0 !add0r addr0 -scalar_mx_block. by apply: (mulrI Hu2); rewrite H mulrV. Qed. End matrix_comUnitRingType. End Matrix. Section Poly. Variable R : idomainType. Import GRing.Theory. Local Open Scope ring_scope. (* use coprimep_XsubC2 *) Lemma coprimep_factor (a b : R) : (b - a)%R \is a GRing.unit -> coprimep ('X - a%:P) ('X - b%:P). Proof. move=> Hab; apply/Bezout_coprimepP. exists ((b - a)^-1%:P, -(b - a) ^-1%:P). rewrite /= !mulrBr !mulNr opprK -!addrA (addrC (- _)) !addrA addrN. by rewrite add0r -mulrBr -rmorphB -rmorphM mulVr // eqpxx. Qed. End Poly. (****************************************************************************) (****************************************************************************) (************ left pseudo division, it is complement of polydiv. ************) (****************************************************************************) (****************************************************************************) Import GRing.Theory. Import Pdiv.Ring. Import Pdiv.RingMonic. Local Open Scope ring_scope. Module RPdiv. Section RingPseudoDivision. Variable R : ringType. Implicit Types d p q r : {poly R}. Definition id_converse_def := (fun x : R => x : R^c). Lemma add_id : additive id_converse_def. Proof. by []. Qed. HB.instance Definition _ := GRing.isAdditive.Build R R^c id_converse_def add_id. Definition id_converse : {additive _ -> _} := id_converse_def. Lemma expr_rev (x : R) k : (x : R^c) ^+ k = x ^+ k. Proof. by elim:k=> // k IHk; rewrite exprS exprSr IHk. Qed. Definition phi (p : {poly R}^c) := map_poly id_converse p. Fact phi_is_rmorphism : multiplicative phi. Proof. split=> [p q|]; apply/polyP=> i; last by rewrite coef_map !coef1. by rewrite coefMr coef_map coefM; apply: eq_bigr => j _; rewrite !coef_map. Qed. HB.instance Definition _ := GRing.Additive.copy phi phi. HB.instance Definition _ := GRing.isMultiplicative.Build _ _ _ phi_is_rmorphism. Definition phi_inv (p : {poly R^c}) := map_poly (fun x : R^c => x : R) p : {poly R}^c. Lemma phiK : cancel phi phi_inv. Proof. by move=> p; rewrite /phi_inv -map_poly_comp_id0 // map_poly_id. Qed. Lemma phi_invK : cancel phi_inv phi. Proof. by move=> p; rewrite /phi -map_poly_comp_id0 // map_poly_id. Qed. Lemma phi_bij : bijective phi. Proof. by exists phi_inv; first exact: phiK; exact: phi_invK. Qed. Lemma monic_map_inj (aR rR : ringType) (f : aR -> rR) (p : {poly aR}) : injective f -> f 0 = 0 -> f 1 = 1 -> map_poly f p \is monic = (p \is monic). Proof. move=> inj_f eq_f00 eq_f11; rewrite !monicE lead_coef_map_inj ?rmorph0 //. by rewrite -eq_f11 inj_eq. Qed. Definition redivp_l (p q : {poly R}) : nat * {poly R} * {poly R} := let:(d,q,p) := redivp (phi p) (phi q) in (d, phi_inv q, phi_inv p). Definition rdivp_l p q := (redivp_l p q).1.2. Definition rmodp_l p q := (redivp_l p q).2. Definition rscalp_l p q := (redivp_l p q).1.1. Definition rdvdp_l p q := rmodp_l q p == 0. Definition rmultp_l := [rel m d | rdvdp_l d m]. Lemma ltn_rmodp_l p q : (size (rmodp_l p q) < size q) = (q != 0). Proof. have := ltn_rmodp (phi p) (phi q). rewrite -(rmorph0 phi) (inj_eq (can_inj phiK)) => <-. rewrite /rmodp_l /redivp_l /rmodp; case: (redivp _ _)=> [[k q'] r'] /=. by rewrite !size_map_inj_poly. Qed. End RingPseudoDivision. Module mon. Section MonicDivisor. Variable R : ringType. Implicit Types p q r : {poly R}. Variable d : {poly R}. Hypothesis mond : d \is monic. Lemma rdivp_l_eq p : p = d * (rdivp_l p d) + (rmodp_l p d). Proof. have mon_phi_d: phi d \is monic by rewrite monic_map_inj. apply:(can_inj (@phiK R)); rewrite {1}[phi p](rdivp_eq mon_phi_d) rmorphD. rewrite rmorphM /rdivp_l /rmodp_l /redivp_l /rdivp /rmodp. by case: (redivp _ _)=> [[k q'] r'] /=; rewrite !phi_invK. Qed. End MonicDivisor. End mon. End RPdiv. Section prelude. Variable R : comRingType. Let lreg := GRing.lreg. Let rreg := GRing.rreg. Lemma monic_lreg (p : {poly R}) : p \is monic -> lreg p. Proof. by rewrite monicE=> /eqP lp1; apply/lreg_lead; rewrite lp1; apply/lreg1. Qed. Lemma monic_rreg (p : {poly R}) : p \is monic -> rreg p. Proof. by rewrite monicE=> /eqP lp1; apply/rreg_lead; rewrite lp1; apply/rreg1. Qed. Lemma lregMl (a b: R) : lreg (a * b) -> lreg b. Proof. by move=> rab c c' eq_bc; apply/rab; rewrite -!mulrA eq_bc. Qed. Lemma rregMr (a b: R) : rreg (a * b) -> rreg a. Proof. by move=> rab c c' eq_ca; apply/rab; rewrite !mulrA eq_ca. Qed. End prelude. (****************************************************************************) (****************************************************************************) (****************************************************************************) (****************************************************************************) coqeal-2.1.0/theory/strassen.v000066400000000000000000000100711475512565300163350ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) Require Import ZArith Ncring Ncring_tac. From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg. From mathcomp Require Import perm zmodp matrix. Require Import ssralg_ring_tac. (** This file describes a formally verified implementation of Strassen's algorithm (Winograd's variant). *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope ring_scope. Section Strassen. Variable (R : ringType) (K : positive). Local Coercion nat_of_pos : positive >-> nat. Lemma addpp p : xO p = (p + p)%N :> nat. Proof. by rewrite /= NatTrec.trecE addnn. Qed. Lemma addSpp p : xI p = (p + p).+1%N :> nat. Proof. by rewrite /= NatTrec.trecE addnn. Qed. Lemma addp1 p : xI p = (xO p + 1)%N :> nat. Proof. by rewrite addn1. Qed. Lemma add1pp p : xI p = (1 + (p + p))%N :> nat. Proof. by rewrite /= NatTrec.trecE addnn. Qed. Lemma lt0p : forall p : positive, 0 < p. Proof. by elim=> // p IHp /=; rewrite NatTrec.doubleE -addnn; exact:ltn_addl. Qed. Local Open Scope ring_scope. Definition Strassen_step {p : positive} (A B : 'M[R]_(p + p, p + p)) (f : 'M[R]_(p, p) -> 'M_(p, p) -> 'M[R]_(p, p)) : 'M_(p + p, p + p) := let A11 := ulsubmx A in let A12 := ursubmx A in let A21 := dlsubmx A in let A22 := drsubmx A in let B11 := ulsubmx B in let B12 := ursubmx B in let B21 := dlsubmx B in let B22 := drsubmx B in let X := A11 - A21 in let Y := B22 - B12 in let C21 := f X Y in let X := A21 + A22 in let Y := B12 - B11 in let C22 := f X Y in let X := X - A11 in let Y := B22 - Y in let C12 := f X Y in let X := A12 - X in let C11 := f X B22 in let X := f A11 B11 in let C12 := X + C12 in let C21 := C12 + C21 in let C12 := C12 + C22 in let C22 := C21 + C22 in let C12 := C12 + C11 in let Y := Y - B21 in let C11 := f A22 Y in let C21 := C21 - C11 in let C11 := f A12 B21 in let C11 := X + C11 in block_mx C11 C12 C21 C22. Definition Strassen_xO {p : positive} Strassen_p := fun A B => if p <= K then A *m B else let A := castmx (addpp p,addpp p) A in let B := castmx (addpp p,addpp p) B in castmx (esym (addpp p), esym (addpp p)) (Strassen_step A B Strassen_p). Definition Strassen_xI {p : positive} Strassen_p := fun M N => if p <= K then M *m N else let M := castmx (add1pp p, add1pp p) M in let N := castmx (add1pp p, add1pp p) N in let M11 := ulsubmx M in let M12 := ursubmx M in let M21 := dlsubmx M in let M22 := drsubmx M in let N11 := ulsubmx N in let N12 := ursubmx N in let N21 := dlsubmx N in let N22 := drsubmx N in let R11 := (M11 *m N11) + (M12 *m N21) in let R12 := (M11 *m N12) + (M12 *m N22) in let R21 := (M21 *m N11) + (M22 *m N21) in let R22 := (M21 *m N12) + (Strassen_step M22 N22 Strassen_p) in castmx (esym (add1pp p), esym (add1pp p)) (block_mx R11 R12 R21 R22). Definition Strassen := positive_rect (fun p => ('M_(p, p) -> 'M_(p, p) -> 'M_(p, p))) (@Strassen_xI) (@Strassen_xO) (fun M N => M *m N). Lemma Strassen_stepP (p : positive) (A B : 'M[R]_(p + p)) f : f =2 mulmx -> Strassen_step A B f = A *m B. Proof. move=> Hf; rewrite -{2}[A]submxK -{2}[B]submxK mulmx_block /Strassen_step !Hf. rewrite /GRing.add /= /GRing.opp /=. by congr block_mx; non_commutative_ring. Qed. Lemma mulmx_cast {R' : ringType} {m n p m' n' p'} {M:'M[R']_(m,p)} {N:'M_(p,n)} {eqm : m = m'} (eqp : p = p') {eqn : n = n'} : matrix.castmx (eqm,eqn) (M *m N) = matrix.castmx (eqm,eqp) M *m matrix.castmx (eqp,eqn) N. Proof. by case eqm; case eqn; case eqp. Qed. Lemma StrassenP p : mulmx =2 (Strassen (p := p)). Proof. elim: p => // [p IHp|p IHp] M N. rewrite /= /Strassen_xI; case:ifP=> // _. by rewrite Strassen_stepP // -mulmx_block !submxK -mulmx_cast castmxK. rewrite /= /Strassen_xO; case:ifP=> // _. by rewrite Strassen_stepP // -mulmx_cast castmxK. Qed. End Strassen. coqeal-2.1.0/theory/stronglydiscrete.v000066400000000000000000000542361475512565300201120ustar00rootroot00000000000000(** This file is part of CoqEAL, the Coq Effective Algebra Library. (c) Copyright INRIA and University of Gothenburg, see LICENSE *) From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path. From mathcomp Require Import ssralg fintype perm choice fingroup. From mathcomp Require Import matrix bigop zmodp mxalgebra poly. Require Import ssrcomplements. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Local Open Scope ring_scope. (** Strongly discrete rings *) Variant member_spec (R : ringType) n (x : R) (I : 'cV[R]_n) : option 'rV[R]_n -> Type := | Member J of x%:M = J *m I : member_spec x I (Some J) | NMember of (forall J, x%:M != J *m I) : member_spec x I None. HB.mixin Record Ring_isStronglyDiscrete R of GRing.Ring R := { member : forall n, R -> 'cV_n -> option 'rV_n; member_specP : forall n (x : R) (I : 'cV_n), member_spec x I (member n x I) }. HB.structure Definition StronglyDiscrete := { R of Ring_isStronglyDiscrete R & GRing.IntegralDomain R }. Bind Scope ring_scope with StronglyDiscrete.sort. Notation stronglyDiscreteType := StronglyDiscrete.type. Notation "[ 'stronglyDiscreteType' 'of' T 'for' cT ]" := (StronglyDiscrete.clone T cT) (at level 0, format "[ 'stronglyDiscreteType' 'of' T 'for' cT ]") : form_scope. Notation "[ 'stronglyDiscreteType' 'of' T ]" := (StronglyDiscrete.clone T _) (at level 0, format "[ 'stronglyDiscreteType' 'of' T ]") : form_scope. Arguments member {_} [_]. Declare Scope ideal_scope. Delimit Scope ideal_scope with IS. Section StronglyDiscreteTheory. Variable R : stronglyDiscreteType. Implicit Types a b c : R. Lemma memberP n (x : R) (I : 'cV[R]_n) : reflect (exists J, x%:M = J *m I) (member x I). Proof. case: member_specP => /= [J ->|h]; constructor; first by exists J. by case=> J hJ; move: (h J); rewrite hJ eqxx. Qed. (** Ideal theory of strongly discrete rings *) Section IdealTheory. (** The sub-ideal membership function *) Definition subid m n (I : 'cV[R]_m) (J : 'cV[R]_n) : bool := [forall i, member (I i 0) J]. Arguments subid m%nat_scope n%nat_scope I%ideal_scope J%ideal_scope. Prenex Implicits subid. Local Notation "A <= B" := (subid A B) : ideal_scope. Local Notation "A <= B <= C" := ((A <= B) && (B <= C))%IS : ideal_scope. Local Notation "A == B" := (A <= B <= A)%IS : ideal_scope. Lemma subidP m n (I : 'cV[R]_m) (J : 'cV[R]_n) : reflect (exists D, I = D *m J) (I <= J)%IS. Proof. apply: (iffP ('forall_(memberP _ _))); last first. move=> [D ->] i; exists (row i D). apply/matrixP => i' j'; rewrite !ord1 {i' j'} !mxE /=. by apply: eq_bigr => l _; rewrite !mxE. move=> HJ; pose M i j := projT1 (sig_eqW (HJ i)) 0 j. exists (\matrix_(i,j) M i j); apply/colP => i; rewrite mxE. transitivity (\sum_j M i j * J j 0); last first. by apply: eq_bigr => j _ /=; rewrite mxE. rewrite /M {M}; case: sig_eqW => //= K. by move=> /matrixP /(_ 0 0); rewrite !mxE eqxx mulr1n. Qed. Definition divid m n (I : 'cV[R]_m) (J : 'cV[R]_n) : 'M_(m, n):= if subidP I J is ReflectT P then projT1 (sig_eqW P) else 0. Lemma dividK m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I <= J)%IS -> divid I J *m J = I. Proof. by rewrite /divid; case: subidP => //= p; case: sig_eqW. Qed. Lemma memberE m (I : 'cV[R]_m) (a : R) : member a I = (a%:M <= I)%IS :> bool. Proof. by apply/memberP/subidP. Qed. Lemma subid_colP m n (I : 'cV[R]_m) (J : 'cV[R]_n) : reflect (forall i, (I i 0)%:M <= J)%IS (I <= J)%IS. Proof. by apply: (iffP forallP) => H i; rewrite (=^~memberE, memberE). Qed. Lemma subid_refl m (I : 'cV[R]_m) : (I <= I)%IS. Proof. by apply/subidP; exists 1%:M; rewrite mul1mx. Qed. Hint Resolve subid_refl : core. Lemma subrid m i (I : 'cV[R]_m) : ((I i 0)%:M <= I)%IS. Proof. apply/subidP; exists (delta_mx 0 i); rewrite -rowE. by apply/colP=> j; rewrite !mxE ord1 mulr1n. Qed. Hint Resolve subrid : core. (** Obsolete *) Remark member_in m x (I : 'cV[R]_m) : (exists i, I i 0 = x) -> member x I. Proof. by case=> i <-; rewrite memberE subrid. Qed. Lemma sub0id n m (I : 'cV[R]_m) : ((0 : 'cV_n) <= I)%IS. Proof. by apply/subidP; exists 0; rewrite mul0mx. Qed. Hint Resolve sub0id : core. Lemma subid1 m (I : 'cV[R]_m) : (I <= 1)%IS. Proof. by apply/subidP; exists I; rewrite mulmx1. Qed. Hint Resolve subid1 : core. Lemma subidMl m n p (I : 'cV[R]_m) (J : 'cV[R]_n) (D : 'M_(p, _)) : (I <= J)%IS -> (D *m I <= J)%IS. Proof. by move=> /subidP [I' ->]; apply/subidP; exists (D *m I'); rewrite mulmxA. Qed. Lemma subid_trans n m p (J : 'cV[R]_n) (I : 'cV[R]_m) (K : 'cV[R]_p) : (I <= J)%IS -> (J <= K)%IS -> (I <= K)%IS. Proof. by move=> /subidP [I' ->] /subidP [J' ->]; rewrite mulmxA subidMl. Qed. Lemma subid_le0 m n (I : 'cV[R]_n) : (I <= (0 : 'cV_m))%IS = (I == 0). Proof. apply/subidP/eqP => [[D ->]|->]; first by rewrite mulmx0. by exists 0; rewrite mul0mx. Qed. Lemma eqid_eq0 m n (I : 'cV[R]_n) : (I == (0 : 'cV_m))%IS = (I == 0). Proof. by rewrite subid_le0 sub0id andbT. Qed. (* Obsolete *) Remark member_subid m n x (I : 'cV[R]_m) (J : 'cV[R]_n) : member x I -> (I <= J)%IS -> member x J. Proof. by rewrite !memberE; apply: subid_trans. Qed. Remark subid_memberP m n (I : 'cV[R]_m) (J : 'cV[R]_n) : reflect (forall x, member x I -> member x J) (I <= J)%IS. Proof. apply: (iffP idP); first by move=> leIJ i; rewrite !memberE => /subid_trans ->. move=> HIJ; apply/subid_colP => i. by move: (HIJ (I i 0)); rewrite !memberE; apply. Qed. (** Theory of subid and eqid *) Definition eqid m n (I : 'cV[R]_m) (J : 'cV[R]_n) := forall p (K : 'cV[R]_p), (((I <= K)%IS = (J <= K)%IS) * ((K <= I)%IS = (K <= J)%IS))%type. Local Notation "I :=: J" := (eqid I J)%IS : ideal_scope. Lemma eqidP m n (I : 'cV[R]_m) (J : 'cV[R]_n) : reflect (I :=: J)%IS (I == J)%IS. Proof. apply: (iffP andP) => [[sIJ sJI] p K | eqIJ]; last by rewrite !eqIJ. by split; apply/idP/idP; by [move/subid_trans->|move/(subid_trans _)->]. Qed. Lemma subeqid_refl m (I : 'cV[R]_m) : (I == I)%IS. Proof. by rewrite !subid_refl. Qed. Hint Resolve subeqid_refl : core. Lemma eqid_refl m (I : 'cV[R]_m) : (I :=: I)%IS. Proof. exact/eqidP. Qed. Hint Resolve eqid_refl : core. Lemma eqid_sym m n (I: 'cV[R]_n) (J: 'cV[R]_m) : (I :=: J)%IS -> (J :=: I)%IS. Proof. by move=> /eqidP; rewrite andbC => /eqidP. Qed. Lemma eqid_trans m n k (J : 'cV_n) (I : 'cV[R]_m) (K : 'cV_k) : (I :=: J -> J :=: K -> I :=: K)%IS. Proof. by move=> IJ JK; apply/eqidP; rewrite !IJ !JK. Qed. Lemma subid_castmxl m n p (I : 'cV[R]_m) (J : 'cV[R]_n) (h : m = p): ((castmx (h,erefl _) I) <= J)%IS = (I <= J)%IS. Proof. by case: _ / h. Qed. Lemma subid_castmxr m n p (I : 'cV[R]_m) (J : 'cV[R]_n) (h : n = p): (I <= (castmx (h,erefl _) J))%IS = (I <= J)%IS. Proof. by case: _ / h. Qed. (** Ideal addition *) Definition addid m n (I : 'cV[R]_m) (J : 'cV[R]_n) := col_mx I J. Local Notation "I +i J" := (addid I J) (at level 30). Lemma sub_add0rid m n (I : 'cV[R]_m) : (I +i (0 : 'cV[R]_n) <= I)%IS. Proof. apply/subidP; exists (pid_mx m). by rewrite pid_mx_col mul_col_mx mul1mx mul0mx. Qed. Lemma sub_addid0r m n (I : 'cV[R]_m) : (I <= I +i (0 : 'cV[R]_n))%IS. Proof. apply/subidP; exists (pid_mx m). by rewrite pid_mx_row mul_row_col mul1mx mulmx0 addr0. Qed. Lemma subid_addC m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I +i J <= J +i I)%IS. Proof. apply/subidP; exists (block_mx 0 1%:M 1%:M 0). by rewrite mul_block_col !(mul0mx,mul1mx) addr0 add0r. Qed. Lemma subid_addAl m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) : (I +i (J +i K) <= (I +i J) +i K)%IS. Proof. apply/subidP. exists (block_mx (row_mx 1%:M 0) 0 (block_mx 0 1%:M 0 0) (col_mx 0 1%:M)). rewrite !mul_block_col mul_row_col mul_col_mx add_col_mx. by rewrite !(mul0mx,mul1mx,add0r,addr0). Qed. Lemma subid_addAr m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) : ((I +i J) +i K <= I +i (J +i K))%IS. Proof. apply/subidP. exists (block_mx (col_mx 1%:M 0) (block_mx 0 0 1%:M 0) 0 (row_mx 0 1%:M)). rewrite !mul_block_col mul_row_col mul_col_mx add_col_mx. by rewrite !(mul0mx,mul1mx,add0r,addr0). Qed. Lemma sub_add0lid m n (I : 'cV[R]_n) : ((0 : 'cV[R]_m) +i I <= I)%IS. Proof. exact: (subid_trans (subid_addC 0 I) (sub_add0rid m I)). Qed. Lemma sub_addid0l m n (I : 'cV[R]_n) : (I <= (0 : 'cV[R]_m) +i I)%IS. Proof. exact: (subid_trans (sub_addid0r _ _) (subid_addC I 0)). Qed. Lemma addid0 m n (I : 'cV[R]_m) : (I +i (0 : 'cV[R]_n) :=: I)%IS. Proof. by apply/eqidP; rewrite sub_addid0r sub_add0rid. Qed. Lemma add0id m n (I : 'cV[R]_m) : ((0 : 'cV[R]_n) +i I :=: I)%IS. Proof. by apply/eqidP; rewrite sub_addid0l sub_add0lid. Qed. Lemma addidC m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I +i J :=: J +i I)%IS. Proof. by apply/eqidP; rewrite !subid_addC. Qed. Lemma addid_addA m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p): (I +i (J +i K) :=: (I +i J) +i K)%IS. Proof. by apply/eqidP; rewrite subid_addAl subid_addAr. Qed. Lemma sub_addidl m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p): (J <= K)%IS -> (I +i J <= I +i K)%IS. Proof. case/subidP => D hD; apply/subidP. exists (block_mx 1%:M 0 0 D). by rewrite hD mul_block_col mul1mx !mul0mx addr0 add0r. Qed. Lemma sub_addidr m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p): (J <= K)%IS -> (J +i I <= K +i I)%IS. Proof. case/subidP => D hD; apply/subidP. exists (block_mx D 0 0 1%:M). by rewrite hD mul_block_col mul1mx !mul0mx addr0 add0r. Qed. Lemma add_addil m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) : (J :=: K)%IS -> (I +i J :=: I +i K)%IS. Proof. by move=> eqJK; apply/eqidP; rewrite ?sub_addidl ?eqJK. Qed. Lemma add_addir m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) : (J :=: K)%IS -> (J +i I :=: K +i I)%IS. Proof. by move=> eqJK; apply/eqidP; rewrite ?sub_addidr ?eqJK. Qed. Lemma subid_addid_congr m n p (I : 'cV[R]_n) (J : 'cV[R]_m) (K : 'cV[R]_p) : (I <= K)%IS -> (J <= K)%IS -> (I +i J <= K)%IS. Proof. case/subidP => C hC /subidP [D hD]; apply/subidP. by exists (col_mx C D); rewrite mul_col_mx -hC -hD. Qed. Lemma addid_congr m n p o (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) (L : 'cV_o) : (I <= K -> J <= L -> I +i J <= K +i L)%IS. Proof. case/subidP => X hX; case/subidP => Y hY; apply/subidP. exists (block_mx X 0 0 Y). by rewrite mul_block_col !mul0mx addr0 add0r hX hY. Qed. Lemma scale_addid (x: R) m n (I : 'cV[R]_m) (J: 'cV[R]_n): x *: (I +i J) = (x *: I) +i (x *: J). Proof. by rewrite /addid -scale_col_mx. Qed. Lemma subid_scaleid (x: R) m n (I: 'cV[R]_m) (J: 'cV[R]_n): x != 0 -> (I <= J)%IS = (x *: I <= x *: J)%IS. Proof. move=> x0. apply/idP/idP; case/subidP => D hD; apply/subidP; exists D. by rewrite hD scalemxAr. by apply/eqP; rewrite -(inj_eq (scalemx_inj x0)) scalemxAr hD. Qed. Lemma eqid_scaleid (x: R) m n (I: 'cV[R]_m) (J: 'cV[R]_n): x != 0 -> (I == J)%IS = (x *: I == x *: J)%IS. Proof. move=> x0; apply/idP/andP=> [|[]]. by rewrite (@subid_scaleid x) //; case/andP=> ->; rewrite (@subid_scaleid x). by rewrite -(@subid_scaleid x) // => ->; rewrite -(@subid_scaleid x) // => ->. Qed. (** Ideal multiplication *) (* This is a bit problematic as mxvec gives a row vector... *) Definition mulid m n (I : 'cV[R]_m) (J : 'cV[R]_n) : 'cV[R]_(m * n) := (mxvec (I *m J^T))^T. Local Notation "I *i J" := (mulid I J) (at level 50). Lemma subid_tr_mxvec m n (I : 'M[R]_(m,n)) : ((mxvec I)^T <= (mxvec I^T)^T)%IS. Proof. apply/subid_colP => i /=; case: (mxvec_indexP i) => {}i j. by rewrite (subid_trans _ (subrid (mxvec_index j i) _)) // !(mxE, mxvecE). Qed. Lemma eqid_tr_mxvec m n (I : 'M[R]_(m,n)) : ((mxvec I)^T :=: (mxvec I^T)^T)%IS. Proof. by apply/eqidP; rewrite -[I in X in _ && (_ <= X)%IS]trmxK !subid_tr_mxvec. Qed. (* Lemma mxvec_r1l m (I: 'cV[R]_m) : (mxvec I <= I)%IS. *) (* Proof. *) (* apply/subid_in => i. *) (* case/mxvec_indexP : i => i j; rewrite !ord1 {i}. *) (* rewrite mxvecE. *) (* by exists j. *) (* Qed. *) (* Lemma mxvec_r1r m (I: 'cV[R]_m) : (I <= mxvec I)%IS. *) (* Proof. *) (* apply/subid_in => i. *) (* exists (mxvec_index 0 i). *) (* by rewrite mxvecE. *) (* Qed. *) Lemma mxvec0 (V : zmodType) (m n : nat) : mxvec (0 : 'M[V]_(m, n)) = 0. Proof. by apply/eqP; rewrite mxvec_eq0. Qed. Lemma trmx_eq0 (V : zmodType) (m n : nat) (A : 'M[V]_(m, n)) : (A^T == 0) = (A == 0). Proof. by rewrite -trmx0 (inj_eq (can_inj (@trmxK _ _ _))). Qed. Lemma mulid0 m n (I : 'cV[R]_m) : I *i (0 : 'cV[R]_n) = 0. Proof. by rewrite /mulid trmx0 mulmx0 mxvec0 trmx0. Qed. Lemma mul0id m n (I : 'cV[R]_n) : (0 : 'cV[R]_m) *i I = 0. Proof. by rewrite /mulid mul0mx mxvec0 trmx0. Qed. Lemma subid_mulC m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I *i J <= J *i I)%IS. Proof. by rewrite (subid_trans (subid_tr_mxvec _)) // trmx_mul trmxK. Qed. Lemma mulidC m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I *i J :=: J *i I)%IS. Proof. by apply/eqidP; rewrite !subid_mulC. Qed. Lemma sub_mulidl m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p): (J <= K -> I *i J <= I *i K)%IS. Proof. case/subidP => D hD; apply/subidP; exists (lin_mulmxr D^T)^T. rewrite -trmx_mul; apply: (canLR (@trmxK _ _ _)); apply: (canLR vec_mxK). by rewrite trmxK mx_vec_lin /= hD trmx_mul mulmxA. Qed. Lemma sub_mulidr m n p (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) : (J <= K -> J *i I <= K *i I)%IS. Proof. by move=> h; rewrite mulidC (mulidC _ _ _).2 sub_mulidl. Qed. Lemma eqid_mulidAl l m n (K : 'cV[R]_l) (I : 'cV[R]_m) (J : 'cV[R]_n) : (I *i (J *i K) :=: (I *i J) *i K)%IS. Proof. rewrite /mulid; apply/eqidP/andP; split; apply/subid_colP => i; case/mxvec_indexP : i => i j; rewrite !(mxE, mxvecE, big_ord1). case/mxvec_indexP : j => j k; rewrite !(mxE, mxvecE, big_ord1). rewrite (subid_trans _ (subrid (mxvec_index (mxvec_index i j) k) _)) //. by rewrite !(mxE, mxvecE, big_ord1) mulrA. case/mxvec_indexP : i => i k; rewrite !(mxE, mxvecE, big_ord1). rewrite (subid_trans _ (subrid (mxvec_index i (mxvec_index k j)) _)) //. by rewrite !(mxE, mxvecE, big_ord1) mulrA. Qed. Lemma mulid_addidr m n k (I : 'cV[R]_m) (J : 'cV[R]_n) (K : 'cV[R]_k) : (I *i (J +i K) <= (I *i J) +i (I *i K))%IS. Proof. apply/forallP=> /= i. apply: member_in. case/mxvec_indexP: i => i x. rewrite mxE mxvecE !mxE big_ord1 !mxE. case: splitP => j hj. exists (lshift (m*k)%nat (mxvec_index i j)). rewrite !mxE. case: splitP => ij /= hij. case/mxvec_indexP : ij hij => a b /= hab. have : enum_rank (i,j) = enum_rank (a,b) by apply/ord_inj. case/enum_rank_inj => -> ->. by rewrite mxE mxvecE !mxE big_ord_recl big_ord0 addr0 !mxE. case/mxvec_indexP : ij hij => a b /= hab. have : m * n <= enum_rank (i, j). by rewrite hab -{1}[(m * n)%nat]addn0 leq_add2l. rewrite leqNgt => /negP; case. by apply (leq_trans (ltn_ord _)); rewrite /= eq_card_prod // !card_ord. exists (rshift (m*n)%nat (mxvec_index i j)). rewrite !mxE. case: splitP => ij /= hij. case/mxvec_indexP : ij hij => a b /= hab. have : m * n <= enum_rank (a, b) by rewrite -hab -{1}[(m * n)%nat]addn0 leq_add2l. rewrite leqNgt => /negP; case. by apply (leq_trans (ltn_ord _)); rewrite /= eq_card_prod // !card_ord. case/mxvec_indexP : ij hij => a b /= hab. have : enum_rank (i,j) = enum_rank (a,b). apply/ord_inj/eqP. by rewrite -(eqn_add2l (m * n)%nat) hab. case/enum_rank_inj => -> ->. by rewrite mxE mxvecE !mxE big_ord_recl big_ord0 addr0 !mxE. Qed. Lemma scale_mxvec a m n (M : 'M[R]_(m,n)) : a *: mxvec M = mxvec (a *: M). Proof. apply/matrixP=> i j; rewrite mxE ord1 {i}. by case/mxvec_indexP: j=> i j; rewrite !mxvecE mxE. Qed. Lemma scale_trmx a m n (M : 'M[R]_(m,n)) : a *: M^T = (a *: M)^T. Proof. by apply/matrixP=> i j; rewrite !mxE. Qed. Lemma scale_mulidr a n m (I : 'cV[R]_n) (J : 'cV[R]_m) : (a *: (I *i J) :=: (a *: I) *i J)%IS. Proof. by rewrite scale_trmx scale_mxvec -!mul_scalar_mx /mulid -mulmxA. Qed. Lemma subid_mulid_congr m n p o (I : 'cV[R]_m) (J : 'cV[R]_n) (K : 'cV[R]_p) (L : 'cV_o) : (I <= K)%IS -> (J <= L)%IS -> (I *i J <= K *i L)%IS. Proof. move => h1 h2. by apply/(subid_trans (sub_mulidl _ h2))/(sub_mulidr _ h1). Qed. Lemma mulid_congr m n p q (I: 'cV[R]_m) (J: 'cV[R]_n) (K: 'cV[R]_p) (L: 'cV[R]_q) : (I :=: K)%IS -> (J :=: L)%IS -> (I *i J :=: K *i L)%IS. Proof. case/eqidP/andP=> h1 h2 /eqidP /andP [h3 h4]; apply/eqidP/andP; split. by apply/(subid_trans (sub_mulidl _ h3))/(sub_mulidr _ h1). by apply/(subid_trans (sub_mulidl _ h4))/(sub_mulidr _ h2). Qed. (* Lemma scaleidE m a (I: 'cV[R]_m) : (a *: I == (a%:M : 'M[R]_1) *i I)%IS. *) (* Proof. *) (* rewrite /mulid tr_scalar_mx mul_scalar_mx scale_mxvec. *) (* case ha : (a == 0). *) (* - rewrite (eqP ha) !scale0r. *) (* by apply/andP; split; apply/subidP; exists 0; rewrite mul0mx. *) (* by rewrite -eqid_scaleid ?mxvec_r1l ?mxvec_r1r // ha. *) (* Qed. *) (* (** A version of mxvec and ideal multiplication that is more suitable for *) (* implementation as a computable version *) *) (* Fixpoint flattenmx m n : 'M[R]_(m,n) -> 'cV[R]_(m * n) := *) (* match m return 'M[R]_(m,n) -> 'cV[R]_(m * n) with *) (* | O => fun _ => 0 *) (* | S p => fun (M : 'M[R]_(1 + p,n)) => row_mx (usubmx M) (flattenmx (dsubmx M)) *) (* end. *) (* (** Every element in flattenmx is in mxvec *) *) (* Lemma flattenmx_in_mxvec : forall m n (M : 'M[R]_(m,n)) i, *) (* exists j, ((mxvec M) 0 j = (flattenmx M) 0 i). *) (* Proof. *) (* elim => [n M []|m ih n] //. *) (* rewrite [m.+1]/(1 + m)%N => M i /=. *) (* rewrite !mxE. *) (* case: splitP => j hj. *) (* exists (mxvec_index 0 j). *) (* by rewrite mxvecE !mxE lshift0. *) (* case: (ih _ (dsubmx M) j) => k hk. *) (* case/mxvec_indexP: k hk => a b. *) (* rewrite mxvecE !mxE rshift1 => hh. *) (* exists (mxvec_index (lift 0 a) b). *) (* by rewrite mxvecE. *) (* Qed. *) (* Lemma flattenmx_mxvec m n (M : 'M[R]_(m,n)) : (flattenmx M <= mxvec M)%IS. *) (* Proof. by apply/subid_in/flattenmx_in_mxvec. Qed. *) (* (** Build the correct index in flattenmx *) *) (* Lemma flattenmx_index_proof (m n : nat) : forall (i : 'I_m) (j : 'I_n), *) (* (i * n + j < m * n)%N. *) (* Proof. *) (* move=> [i hi] [j hj] /=. *) (* case: m hi => //= m; rewrite ltnS => hi. *) (* case: n hj => //= n; rewrite ltnS => hj. *) (* rewrite !mulSn !mulnS addSn ltnS -addnA [(n + _)%N]addnCA. *) (* apply: leq_add => //; rewrite addnC. *) (* by apply: leq_add => //; rewrite leq_mul2r hi orbT. *) (* Qed. *) (* Definition flattenmx_index (m n : nat) (i : 'I_m) (j : 'I_n) := *) (* Ordinal (flattenmx_index_proof i j). *) (* Lemma flattenmx_indexE : forall m n (M : 'M[R]_(m,n)) (i : 'I_m) (j : 'I_n), *) (* (flattenmx M) 0 (flattenmx_index i j) = M i j. *) (* Proof. *) (* elim => [m M []|] //. *) (* rewrite /flattenmx_index /= => m ih n. *) (* rewrite [m.+1]/(1 + m)%N => M i j. *) (* rewrite -{3}[M]vsubmxK !mxE. *) (* case: splitP => /= k hk. *) (* case: splitP => /= l hl. *) (* rewrite ord1 !mxE lshift0. *) (* move: hk. *) (* by rewrite hl ord1 mul0n add0n => /ord_inj ->. *) (* case: k hk => /= k hk h. *) (* suff hnk : n <= k by move: (leq_ltn_trans hnk hk); rewrite ltnn. *) (* move: h. *) (* by rewrite hl mulnDl mul1n => <-; rewrite -{1}[n]addn0 -addnA leq_add2l. *) (* case: splitP => l hl. *) (* rewrite hl !ord1 mul0n add0n in hk. *) (* case: j hk => /= j hj hk. *) (* move: hj; rewrite hk => hj. *) (* suff : (n + k < n) -> false by move => /(_ hj). *) (* by rewrite -ltn_subRL subnn. *) (* move: (ih _ (dsubmx M) l j); rewrite !mxE => <-. *) (* f_equal; apply/ord_inj => /=. *) (* move: hk; rewrite hl mulnDl mul1n -addnA => /eqP. *) (* by rewrite eqn_add2l => /eqP ->. *) (* Qed. *) (* (** Every element in mxvec is in flattenmx *) *) (* Lemma mxvec_in_flattenmx m n (M : 'M[R]_(m,n)) i : *) (* exists j, ((flattenmx M) 0 j = (mxvec M) 0 i). *) (* Proof. *) (* case/mxvec_indexP: i => i j; rewrite mxvecE. *) (* exists (flattenmx_index i j). *) (* by rewrite flattenmx_indexE. *) (* Qed. *) (* Lemma mxvec_flattenmx m n (M : 'M[R]_(m,n)) : (mxvec M <= flattenmx M)%IS. *) (* Proof. by apply/subid_in/mxvec_in_flattenmx. Qed. *) (* (** The inverse of flattenmx_index *) *) (* Lemma flattenmx_indexP m n (k : 'I_(m * n)) : exists i j, *) (* k = flattenmx_index i j. *) (* Proof. *) (* have n0 : 0 < n by case: n k => // [[l]]; rewrite muln0. *) (* have h1 : (k %/ n < m) by rewrite ltn_divLR. *) (* have h2 : (k %% n < n) by rewrite ltn_mod. *) (* exists (Ordinal h1); exists (Ordinal h2). *) (* apply/ord_inj => /=. *) (* exact: (divn_eq k n). *) (* Qed. *) (* (** Alternative version of ideal multiplication that is more suitable *) (* for computation as the behavior is more predictable than the one *) (* based on mxvec *) *) (* Definition mulidc m n (I : 'cV[R]_m) (J : 'cV[R]_n) := flattenmx (I^T *m J). *) (* Lemma mulidcP m n (I : 'cV[R]_m) (J : 'cV[R]_n) : (I *i J == mulidc I J)%IS. *) (* Proof. *) (* by apply/andP; split; rewrite /mulid /mulidc ?mxvec_flattenmx ?flattenmx_mxvec. *) (* Qed. *) (* (** Every element in mulidc is in mulid *) *) (* Lemma mulidc_in_mulid m n (I : 'cV[R]_m) (J : 'cV[R]_n) i : *) (* exists j, ((I *i J) 0 j = (mulidc I J) 0 i). *) (* Proof. by rewrite /mulid /mulidc; apply/flattenmx_in_mxvec. Qed. *) (* (* Special lemma that is just here for the computable version of ideal *) (* intersection in prufer domains... *) *) (* Lemma mulidc_in_mulid2 : forall m n l (I : 'cV[R]_m) (J : 'cV[R]_n) (K : 'cV[R]_l) i, *) (* exists j, (((I *i J) *i K) 0 j = (mulidc (mulidc I J) K) 0 i). *) (* Proof. *) (* have temp : forall m n l (I : 'cV[R]_m) (J : 'cV[R]_n) (K : 'cV[R]_l) i, *) (* (forall i, exists j, I 0 j = K 0 i) -> *) (* exists j, ((I *i J) 0 j = (mulidc K J) 0 i). *) (* move=> m n l I J K i. *) (* case: (flattenmx_indexP i) => a [b ->] /(_ a) [x hx]. *) (* exists (mxvec_index x b). *) (* rewrite /mulidc flattenmx_indexE mxvecE !mxE. *) (* apply: eq_big => // c _. *) (* by rewrite !mxE ord1 hx. *) (* move=> m n l I J K i. *) (* apply: temp => j. *) (* case: (mulidc_in_mulid I J j) => k hk. *) (* by exists k; rewrite hk. *) (* Qed. *) (** Ideal intersection *) Section IdealIntersection. Variable cap_size : forall n m, 'cV[R]_n -> 'cV[R]_m -> nat. Variant int_spec m n (I : 'cV[R]_m) (J : 'cV[R]_n) : 'cV[R]_(cap_size I J).+1 -> Type := IntSpec cap of (cap <= I)%IS & (cap <= J)%IS & (forall x, member x I -> member x J -> member x cap) : int_spec cap. End IdealIntersection. End IdealTheory. End StronglyDiscreteTheory. Notation "A <= B" := (subid A B) : ideal_scope. Notation "A <= B <= C" := ((subid A B) && (subid B C)) : ideal_scope. Notation "A == B" := ((subid A B) && (subid B A)) : ideal_scope. Notation "I +i J" := (addid I J) (at level 30). Notation "I *i J" := (mulid I J) (at level 50). #[export] Hint Resolve subid_refl sub0id subid1 : core. coqeal-2.1.0/theory/toomcook.v000066400000000000000000000077531475512565300163420ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype tuple. From mathcomp Require Import finfun bigop fingroup perm ssralg zmodp matrix mxalgebra. From mathcomp Require Import poly polydiv mxpoly. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Import GRing.Theory. Open Scope ring_scope. Section split_poly. Variable R : ringType. Implicit Types p : {poly R}. (* Split a polynomial into n pieces of size b *) Definition split_poly n b p := \poly_(i < n) \poly_(j < b) p`_(i * b + j). Lemma recompose_split : forall n b p, size p <= b * n -> (split_poly n b p).['X^b] = p. Proof. rewrite /split_poly => [[b p|n b p hs]]; rewrite horner_poly ?big_ord_recr /=. by rewrite muln0 leqn0 size_poly_eq0 => /eqP ->; rewrite big_ord0. suff -> : \big[+%R/0]_(i < n) (\poly_(j < b) p`_(i * b + j) * 'X^b ^+ i) = \poly_(i < n * b) p`_i. apply/polyP=> i; rewrite -exprM coefD coefMXn coef_poly mulnC. have [_|hbni] := ltnP; rewrite ?addr0 // add0r coef_poly. have [_|hsub] := ltnP; rewrite ?subnKC // ?nth_default //. rewrite -ltnS -subSn // ltn_subRL ltnS addnC -mulnS in hsub. exact: (leq_trans hs hsub). elim: n {hs} => [|n ih]; first by rewrite mul0n poly_def !big_ord0. apply/polyP=> i. rewrite big_ord_recr /= ih -exprM coefD !coef_poly coefMXn mulSn mulnC. have [h1|hbni] := ltnP; first by rewrite addr0 (ltn_addl b h1). by rewrite add0r coef_poly subnKC // -(ltn_add2r (b * n)) subnK. Qed. End split_poly. Section ToomCook. (* Necessary to interpolate... *) Variable R : idomainType. (* Toom-n *) Variable n : nat. (* Need d = 2 * n - 1 pairs of points *) Let d : nat := n.*2.-1. Variable points : d.-tuple {poly R}. (* Vandermonde matrix *) Definition vandmx m : 'M[{poly R}]_(m,d) := \matrix_(i < m,j < d) (points`_j ^+ i). (* Evaluation *) Definition evaluate p := poly_rV p *m vandmx (size p). Lemma evaluateE p : evaluate p = \row_(i < d) p.[points`_i]. Proof. apply/rowP => i; rewrite !mxE horner_coef /=. by apply: eq_big => // j _; rewrite !mxE. Qed. (* Interpolation *) Definition interpolate (p : 'rV[{poly R}]_d) := rVpoly (p *m invmx (vandmx d)). (* TODO: Express using determinant? *) Hypothesis hU : vandmx d \in unitmx. Lemma interpolateE (p : {poly {poly R}}) : size p <= d -> interpolate (\row_i p.[points`_i]) = p. Proof. rewrite /interpolate => hsp; rewrite -[RHS](poly_rV_K hsp); congr rVpoly. apply/(canLR (mulmxK hU))/rowP=> i; rewrite !mxE (horner_coef_wide _ hsp). by apply: eq_bigr=> j _ ; rewrite !mxE. Qed. Fixpoint toom_rec m p q : {poly R} := if m is m'.+1 then (* if (size p <= 2) || (size q <= 2) then p * q else *) let: b := (maxn (divn (size p) n) (divn (size q) n)).+1 in let: sp := split_poly n b p in let: sq := split_poly n b q in let: ep := evaluate sp in let: eq := evaluate sq in let: r := \row_i (toom_rec m' (ep 0 i) (eq 0 i)) in let: w := interpolate r in w.['X^b] else p * q. Definition toom_cook (p q : {poly R}) := if 0 < n then toom_rec (maxn (size p) (size q)) p q else p * q. Lemma basisE (p q : {poly R}) : 0 < n -> size p <= (maxn (size p %/ n) (size q %/ n)).+1 * n. Proof. move=> Hn0; move: (leq_maxl (size p %/ n).+1 (size q %/ n).+1). by rewrite -(leq_pmul2r Hn0) maxnSS; apply/leq_trans/ltnW; rewrite ltn_ceil. Qed. Lemma toom_recE (Hn0 : 0 < n) : forall m p q, toom_rec m p q = p * q. Proof. elim=> //= m ih p q. (* ; case: ifP=> // h. *) set sp := split_poly _ _ p; set sq := split_poly _ _ q. set ep := evaluate sp; set eq := evaluate sq. have hspq : size (sp * sq) <= d. rewrite (leq_trans (size_mul_leq _ _)) // /d -!subn1 leq_sub2r // -addnn. by apply/leq_add; rewrite size_poly. have -> : \row_i toom_rec m (ep 0 i) (eq 0 i) = \row_i (sp * sq).[points`_i]. by apply/rowP=> i; rewrite mxE ih /ep /eq !evaluateE !mxE hornerM. by rewrite (interpolateE hspq) hornerM !recompose_split ?basisE // maxnC basisE. Qed. Lemma toom_cookE p q : toom_cook p q = p * q. Proof. rewrite /toom_cook; case: (ltnP 0 n)=> // hn0; exact: toom_recE. Qed. End ToomCook.