Repository: leanprover/std4 Branch: main Commit: 48ff08a0e30a Files: 270 Total size: 1.2 MB Directory structure: gitextract_6ram4obd/ ├── .docker/ │ └── gitpod/ │ └── Dockerfile ├── .github/ │ └── workflows/ │ ├── build.yml │ ├── docs-deploy.yml │ ├── docs-release.yml │ ├── labels-from-comments.yml │ ├── labels-from-status.yml │ ├── merge_conflicts.yml │ ├── nightly_bump_and_merge.yml │ ├── nightly_detect_failure.yml │ ├── nightly_merge_master.yml │ └── test_mathlib.yml ├── .gitignore ├── .gitpod.yml ├── .vscode/ │ ├── copyright.code-snippets │ └── settings.json ├── Batteries/ │ ├── Classes/ │ │ ├── Cast.lean │ │ ├── Deprecated.lean │ │ ├── Order.lean │ │ ├── RatCast.lean │ │ └── SatisfiesM.lean │ ├── CodeAction/ │ │ ├── Attr.lean │ │ ├── Basic.lean │ │ ├── Deprecated.lean │ │ ├── Match.lean │ │ └── Misc.lean │ ├── CodeAction.lean │ ├── Control/ │ │ ├── AlternativeMonad.lean │ │ ├── ForInStep/ │ │ │ ├── Basic.lean │ │ │ └── Lemmas.lean │ │ ├── ForInStep.lean │ │ ├── LawfulMonadState.lean │ │ ├── Lemmas.lean │ │ ├── Monad.lean │ │ ├── Nondet/ │ │ │ └── Basic.lean │ │ └── OptionT.lean │ ├── Data/ │ │ ├── Array/ │ │ │ ├── Basic.lean │ │ │ ├── Init/ │ │ │ │ └── Lemmas.lean │ │ │ ├── Lemmas.lean │ │ │ ├── Match.lean │ │ │ ├── Merge.lean │ │ │ ├── Monadic.lean │ │ │ ├── Pairwise.lean │ │ │ └── Scan.lean │ │ ├── Array.lean │ │ ├── AssocList.lean │ │ ├── BinaryHeap/ │ │ │ └── Basic.lean │ │ ├── BinaryHeap.lean │ │ ├── BinomialHeap/ │ │ │ ├── Basic.lean │ │ │ └── Lemmas.lean │ │ ├── BinomialHeap.lean │ │ ├── BitVec/ │ │ │ ├── Basic.lean │ │ │ └── Lemmas.lean │ │ ├── BitVec.lean │ │ ├── Bool.lean │ │ ├── ByteArray.lean │ │ ├── ByteSlice.lean │ │ ├── Char/ │ │ │ ├── AsciiCasing.lean │ │ │ └── Basic.lean │ │ ├── Char.lean │ │ ├── DList/ │ │ │ ├── Basic.lean │ │ │ └── Lemmas.lean │ │ ├── DList.lean │ │ ├── Fin/ │ │ │ ├── Basic.lean │ │ │ ├── Fold.lean │ │ │ ├── Lemmas.lean │ │ │ └── OfBits.lean │ │ ├── Fin.lean │ │ ├── FloatArray.lean │ │ ├── HashMap/ │ │ │ └── Basic.lean │ │ ├── HashMap.lean │ │ ├── Int.lean │ │ ├── List/ │ │ │ ├── ArrayMap.lean │ │ │ ├── Basic.lean │ │ │ ├── Count.lean │ │ │ ├── Init/ │ │ │ │ └── Lemmas.lean │ │ │ ├── Lemmas.lean │ │ │ ├── Matcher.lean │ │ │ ├── Monadic.lean │ │ │ ├── Pairwise.lean │ │ │ ├── Perm.lean │ │ │ └── Scan.lean │ │ ├── List.lean │ │ ├── MLList/ │ │ │ ├── Basic.lean │ │ │ ├── Heartbeats.lean │ │ │ └── IO.lean │ │ ├── MLList.lean │ │ ├── NameSet.lean │ │ ├── Nat/ │ │ │ ├── Basic.lean │ │ │ ├── Bisect.lean │ │ │ ├── Bitwise/ │ │ │ │ └── Lemmas.lean │ │ │ ├── Bitwise.lean │ │ │ ├── Gcd.lean │ │ │ └── Lemmas.lean │ │ ├── Nat.lean │ │ ├── PairingHeap.lean │ │ ├── RBMap/ │ │ │ ├── Alter.lean │ │ │ ├── Basic.lean │ │ │ ├── Depth.lean │ │ │ ├── Lemmas.lean │ │ │ └── WF.lean │ │ ├── RBMap.lean │ │ ├── Random/ │ │ │ └── MersenneTwister.lean │ │ ├── Random.lean │ │ ├── Range/ │ │ │ └── Lemmas.lean │ │ ├── Range.lean │ │ ├── Rat/ │ │ │ └── Float.lean │ │ ├── Rat.lean │ │ ├── RunningStats.lean │ │ ├── Stream.lean │ │ ├── String/ │ │ │ ├── AsciiCasing.lean │ │ │ ├── Basic.lean │ │ │ ├── Legacy.lean │ │ │ ├── Lemmas.lean │ │ │ └── Matcher.lean │ │ ├── String.lean │ │ ├── UInt.lean │ │ ├── UnionFind/ │ │ │ ├── Basic.lean │ │ │ └── Lemmas.lean │ │ ├── UnionFind.lean │ │ ├── Vector/ │ │ │ ├── Basic.lean │ │ │ ├── Lemmas.lean │ │ │ └── Monadic.lean │ │ └── Vector.lean │ ├── Lean/ │ │ ├── AttributeExtra.lean │ │ ├── EStateM.lean │ │ ├── Except.lean │ │ ├── Expr.lean │ │ ├── Float.lean │ │ ├── HashMap.lean │ │ ├── HashSet.lean │ │ ├── IO/ │ │ │ └── Process.lean │ │ ├── Json.lean │ │ ├── LawfulMonad.lean │ │ ├── LawfulMonadLift.lean │ │ ├── Meta/ │ │ │ ├── Basic.lean │ │ │ ├── DiscrTree.lean │ │ │ ├── Expr.lean │ │ │ ├── Inaccessible.lean │ │ │ ├── InstantiateMVars.lean │ │ │ ├── SavedState.lean │ │ │ ├── Simp.lean │ │ │ └── UnusedNames.lean │ │ ├── MonadBacktrack.lean │ │ ├── NameMapAttribute.lean │ │ ├── PersistentHashMap.lean │ │ ├── PersistentHashSet.lean │ │ ├── Position.lean │ │ ├── SatisfiesM.lean │ │ ├── Syntax.lean │ │ ├── System/ │ │ │ └── IO.lean │ │ ├── TagAttribute.lean │ │ └── Util/ │ │ └── EnvSearch.lean │ ├── Linter/ │ │ ├── UnnecessarySeqFocus.lean │ │ └── UnreachableTactic.lean │ ├── Linter.lean │ ├── Logic.lean │ ├── Tactic/ │ │ ├── Alias.lean │ │ ├── Basic.lean │ │ ├── Case.lean │ │ ├── Congr.lean │ │ ├── Exact.lean │ │ ├── GeneralizeProofs.lean │ │ ├── HelpCmd.lean │ │ ├── Init.lean │ │ ├── Instances.lean │ │ ├── Lemma.lean │ │ ├── Lint/ │ │ │ ├── Basic.lean │ │ │ ├── Frontend.lean │ │ │ ├── Misc.lean │ │ │ ├── Simp.lean │ │ │ └── TypeClass.lean │ │ ├── Lint.lean │ │ ├── NoMatch.lean │ │ ├── OpenPrivate.lean │ │ ├── PermuteGoals.lean │ │ ├── PrintDependents.lean │ │ ├── PrintOpaques.lean │ │ ├── PrintPrefix.lean │ │ ├── SeqFocus.lean │ │ ├── ShowUnused.lean │ │ ├── SqueezeScope.lean │ │ ├── Trans.lean │ │ └── Unreachable.lean │ └── Util/ │ ├── Cache.lean │ ├── ExtendedBinder.lean │ ├── LibraryNote.lean │ ├── Panic.lean │ ├── Pickle.lean │ └── ProofWanted.lean ├── Batteries.lean ├── BatteriesTest/ │ ├── ArrayMap.lean │ ├── Char.lean │ ├── GeneralizeProofs.lean │ ├── Internal/ │ │ ├── DummyLabelAttr.lean │ │ ├── DummyLibraryNote.lean │ │ └── DummyLibraryNote2.lean │ ├── MLList.lean │ ├── OpenPrivateDefs.lean │ ├── String.lean │ ├── absurd.lean │ ├── alias.lean │ ├── array.lean │ ├── array_scan.lean │ ├── by_contra.lean │ ├── case.lean │ ├── congr.lean │ ├── conv_equals.lean │ ├── except.lean │ ├── exfalso.lean │ ├── float.lean │ ├── help_cmd.lean │ ├── import_lean.lean │ ├── instances.lean │ ├── isIndependentOf.lean │ ├── kmp_matcher.lean │ ├── lemma_cmd.lean │ ├── library_note.lean │ ├── lintTC.lean │ ├── lintTrace.lean │ ├── lint_coinductive.lean │ ├── lint_docBlame.lean │ ├── lint_docBlameThm.lean │ ├── lint_dupNamespace.lean │ ├── lint_lean.lean │ ├── lint_simpNF.lean │ ├── lint_simpNF_respectTransparency.lean │ ├── lint_unreachableTactic.lean │ ├── linterVisibility.lean │ ├── lintsimp.lean │ ├── lintunused.lean │ ├── list_enumeration.lean │ ├── list_sublists.lean │ ├── mersenne_twister.lean │ ├── nondet.lean │ ├── norm_cast.lean │ ├── omega/ │ │ └── benchmark.lean │ ├── on_goal.lean │ ├── openPrivate.lean │ ├── print_opaques.lean │ ├── print_prefix.lean │ ├── proof_wanted.lean │ ├── register_label_attr.lean │ ├── rfl.lean │ ├── satisfying.lean │ ├── seq_focus.lean │ ├── show_term.lean │ ├── show_unused.lean │ ├── simp_trace.lean │ ├── simpa.lean │ ├── solve_by_elim.lean │ ├── trans.lean │ ├── tryThis.lean │ ├── vector.lean │ └── where.lean ├── LICENSE ├── README.md ├── Shake/ │ └── Main.lean ├── bors.toml ├── docs/ │ └── lakefile.toml ├── lake-manifest.json ├── lakefile.toml ├── lean-toolchain └── scripts/ ├── check_imports.lean ├── create-adaptation-pr.sh ├── lintWhitespace.sh ├── merge-lean-testing-pr.sh ├── nolints.json ├── noshake.json ├── runLinter.lean └── updateBatteries.sh ================================================ FILE CONTENTS ================================================ ================================================ FILE: .docker/gitpod/Dockerfile ================================================ # This is the Dockerfile for leanprover-community/batteries # This file is mostly copied from [mathlib4](https://github.com/leanprover-community/mathlib4/blob/master/.docker/gitpod/Dockerfile) # gitpod doesn't support multiple FROM statements, (or rather, you can't copy from one to another) # so we just install everything in one go FROM ubuntu:jammy USER root RUN apt-get update && apt-get install sudo git curl bash-completion python3-requests gcc make -y && apt-get clean RUN useradd -l -u 33333 -G sudo -md /home/gitpod -s /bin/bash -p gitpod gitpod \ # passwordless sudo for users in the 'sudo' group && sed -i.bkp -e 's/%sudo\s\+ALL=(ALL\(:ALL\)\?)\s\+ALL/%sudo ALL=NOPASSWD:ALL/g' /etc/sudoers USER gitpod WORKDIR /home/gitpod SHELL ["/bin/bash", "-c"] # gitpod bash prompt RUN { echo && echo "PS1='\[\033[01;32m\]\u\[\033[00m\] \[\033[01;34m\]\w\[\033[00m\]\$(__git_ps1 \" (%s)\") $ '" ; } >> .bashrc # install elan RUN curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh -s -- -y --default-toolchain none # install whichever toolchain batteries is currently using RUN . ~/.profile && elan toolchain install $(curl https://raw.githubusercontent.com/leanprover-community/batteries/main/lean-toolchain) # install neovim (for any lean.nvim user), via tarball since the appimage doesn't work for some reason, and jammy's version is ancient RUN curl -s -L https://github.com/neovim/neovim/releases/download/stable/nvim-linux64.tar.gz | tar xzf - && sudo mv nvim-linux64 /opt/nvim ENV PATH="/home/gitpod/.local/bin:/home/gitpod/.elan/bin:/opt/nvim/bin:${PATH}" # fix the infoview when the container is used on gitpod: ENV VSCODE_API_VERSION="1.50.0" # ssh to github once to bypass the unknown fingerprint warning RUN ssh -o StrictHostKeyChecking=no github.com || true # run sudo once to suppress usage info RUN sudo echo finished ================================================ FILE: .github/workflows/build.yml ================================================ on: push: branches-ignore: # ignore tmp branches used by bors - 'staging.tmp*' - 'trying.tmp*' - 'staging*.tmp' pull_request: name: ci concurrency: group: build-${{ github.sha }} cancel-in-progress: true jobs: build: name: Build runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - id: lean-action name: build, test, and lint batteries uses: leanprover/lean-action@v1 with: build-args: '--wfail' - name: Check that all files are imported run: lake env lean scripts/check_imports.lean - name: Check for forbidden character ↦ if: always() run: | if grep -r -n --include=\*.lean -e '↦' . ; then echo "Error: Found forbidden character ↦" exit 1 fi - name: Check for 'namespace Mathlib' if: always() run: | if grep -r -n --include=\*.lean -e 'namespace Mathlib' . ; then echo "Error: Found 'namespace Mathlib'" exit 1 fi - name: Check for long lines if: always() run: | ! (find Batteries -name "*.lean" -type f -exec grep -E -H -n '^.{101,}$' {} \; | grep -v -E 'https?://') - name: Check for trailing whitespace if: always() run: | scripts/lintWhitespace.sh - name: Don't 'import Lean', use precise imports if: always() run: | ! (find . -name "*.lean" ! -path "./BatteriesTest/import_lean.lean" -type f -print0 | xargs -0 grep -E -n '^import Lean$') ================================================ FILE: .github/workflows/docs-deploy.yml ================================================ name: Deploy Docs on: workflow_dispatch: schedule: - cron: '0 10 * * *' # daily (UTC 10:00) permissions: contents: write jobs: deploy-docs: runs-on: ubuntu-latest if: github.repository_owner == 'leanprover-community' steps: - name: Checkout uses: actions/checkout@v4 - name: Install Lean uses: leanprover/lean-action@v1 with: test: false lint: false use-github-cache: true - name: Build Docs working-directory: docs run: lake build --keep-toolchain -q Batteries:docs - name: Deploy Docs run: | git config user.name "leanprover-community-batteries-bot" git config user.email "leanprover-community-batteries-bot@users.noreply.github.com" git checkout -b docs git add docs/doc docs/doc-data git commit -m "chore: generate docs" git push origin docs --force ================================================ FILE: .github/workflows/docs-release.yml ================================================ name: Release Docs on: push: tags: - "v[0-9]+.[0-9]+.[0-9]+" - "v[0-9]+.[0-9]+.[0-9]+-rc[0-9]+" permissions: contents: write jobs: build-docs: runs-on: ubuntu-latest if: github.repository_owner == 'leanprover-community' steps: - name: Checkout uses: actions/checkout@v4 - name: Install Lean uses: leanprover/lean-action@v1 with: test: false lint: false use-github-cache: true - name: Build Docs working-directory: docs run: lake build --keep-toolchain -q Batteries:docs - name: Compress Docs working-directory: docs env: TAG_NAME: ${{ github.ref_name }} run: | tar -czf docs-${TAG_NAME}.tar.gz doc doc-data zip -rq docs-${TAG_NAME}.zip doc doc-data - name: Release Docs uses: softprops/action-gh-release@v2 with: prerelease: ${{ contains(github.ref, 'rc') }} make_latest: ${{ !contains(github.ref, 'rc') }} files: | docs/docs-${{ github.ref_name }}.tar.gz docs/docs-${{ github.ref_name }}.zip fail_on_unmatched_files: true ================================================ FILE: .github/workflows/labels-from-comments.yml ================================================ # This workflow allows any user to add one of the `awaiting-review`, `awaiting-author`, or `WIP` labels, # by commenting on the PR or issue. # Other labels from this set are removed automatically at the same time. name: Label PR based on Comment on: issue_comment: types: [created] jobs: update-label: if: github.event.issue.pull_request != null && (github.event.comment.body == 'awaiting-review' || github.event.comment.body == 'awaiting-author' || github.event.comment.body == 'WIP') runs-on: ubuntu-latest steps: - name: Remove all relevant labels uses: actions/github-script@v6 with: github-token: ${{ secrets.GITHUB_TOKEN }} script: | const { owner, repo, number: issue_number } = context.issue; // Remove the labels if they exist await github.rest.issues.removeLabel({ owner, repo, issue_number, name: 'awaiting-review' }).catch(() => {}); await github.rest.issues.removeLabel({ owner, repo, issue_number, name: 'awaiting-author' }).catch(() => {}); await github.rest.issues.removeLabel({ owner, repo, issue_number, name: 'WIP' }).catch(() => {}); - name: Add label based on comment uses: actions/github-script@v6 with: github-token: ${{ secrets.GITHUB_TOKEN }} script: | const { owner, repo, number: issue_number } = context.issue; const commentBody = context.payload.comment.body; if (commentBody == 'awaiting-review') { await github.rest.issues.addLabels({ owner, repo, issue_number, labels: ['awaiting-review'] }); } else if (commentBody == 'awaiting-author') { await github.rest.issues.addLabels({ owner, repo, issue_number, labels: ['awaiting-author'] }); } else if (commentBody == 'WIP') { await github.rest.issues.addLabels({ owner, repo, issue_number, labels: ['WIP'] }); } # - name: Delete the comment # uses: actions/github-script@v6 # with: # github-token: ${{ secrets.GITHUB_TOKEN }} # script: | # const { owner, repo } = context.repo; # await github.rest.issues.deleteComment({ owner, repo, comment_id: context.payload.comment.id }); ================================================ FILE: .github/workflows/labels-from-status.yml ================================================ # This workflow assigns `awaiting-review` or `WIP` labels to new PRs, and it removes # `awaiting-review`, `awaiting-author`, or `WIP` label from closed PRs. # It does not modify labels for open PRs that already have one of the `awaiting-review`, # `awaiting-author`, or `WIP` labels. name: Label PR from status change permissions: contents: read pull-requests: write on: pull_request_target: types: - closed - opened - reopened - converted_to_draft - ready_for_review branches: - main jobs: auto-label: if: github.repository_owner == 'leanprover-community' runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 with: fetch-depth: 0 - name: Unlabel closed PR if: github.event.pull_request.state == 'closed' uses: actions-ecosystem/action-remove-labels@v1 with: github_token: ${{ secrets.GITHUB_TOKEN }} labels: | WIP awaiting-author awaiting-review - name: Label unlabeled draft PR as WIP if: | github.event.pull_request.state == 'open' && github.event.pull_request.draft && ! contains(github.event.pull_request.labels.*.name, 'awaiting-author') && ! contains(github.event.pull_request.labels.*.name, 'awaiting-review') && ! contains(github.event.pull_request.labels.*.name, 'WIP') uses: actions-ecosystem/action-add-labels@v1 with: github_token: ${{ secrets.GITHUB_TOKEN }} labels: WIP - name: Label unlabeled other PR as awaiting-review if: | github.event.pull_request.state == 'open' && ! github.event.pull_request.draft && ! contains(github.event.pull_request.labels.*.name, 'awaiting-author') && ! contains(github.event.pull_request.labels.*.name, 'awaiting-review') && ! contains(github.event.pull_request.labels.*.name, 'WIP') uses: actions-ecosystem/action-add-labels@v1 with: github_token: ${{ secrets.GITHUB_TOKEN }} labels: awaiting-review ================================================ FILE: .github/workflows/merge_conflicts.yml ================================================ name: Merge conflicts on: schedule: - cron: '*/60 * * * *' # run every 60 minutes jobs: main: if: github.repository_owner == 'leanprover-community' runs-on: ubuntu-latest steps: - name: Generate app token id: app-token uses: actions/create-github-app-token@29824e69f54612133e76f7eaac726eef6c875baf # v2.2.1 with: app-id: ${{ secrets.MATHLIB_MERGE_CONFLICTS_APP_ID }} private-key: ${{ secrets.MATHLIB_MERGE_CONFLICTS_PRIVATE_KEY }} # The create-github-app-token README states that this token is masked and will not be logged accidentally. - name: check if prs are dirty uses: eps1lon/actions-label-merge-conflict@1df065ebe6e3310545d4f4c4e862e43bdca146f0 # v3.0.3 with: dirtyLabel: "merge-conflict" repoToken: ${{ steps.app-token.outputs.token }} ================================================ FILE: .github/workflows/nightly_bump_and_merge.yml ================================================ name: Bump toolchain and merge pr-testing branches # This workflow combines the former `nightly_bump_toolchain.yml` and `discover-lean-pr-testing.yml` # into a single workflow. This ensures that when the toolchain is bumped, any relevant # lean-pr-testing branches are merged in the same push, avoiding spurious CI failures # on the intermediate state (bumped toolchain without the adaptations). on: schedule: - cron: '45 9/3 * * *' # 10:45AM CET/1:45AM PT (and then every 3 hours thereafter), # This should be 2 hours and 45 minutes after lean4 starts building the nightly. # Mathlib's `nightly-testing` branch is bumped 15 minutes later. workflow_dispatch: jobs: bump-and-merge: runs-on: ubuntu-latest if: github.repository_owner == 'leanprover-community' steps: - name: Generate app token id: app-token uses: actions/create-github-app-token@29824e69f54612133e76f7eaac726eef6c875baf # v2.2.1 with: app-id: ${{ secrets.MATHLIB_NIGHTLY_TESTING_APP_ID }} private-key: ${{ secrets.MATHLIB_NIGHTLY_TESTING_PRIVATE_KEY }} # The create-github-app-token README states that this token is masked and will not be logged accidentally. - name: Checkout nightly-testing branch uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 with: ref: nightly-testing fetch-depth: 0 # Fetch all branches and history token: ${{ steps.app-token.outputs.token }} - name: Set up Git run: | git config --global user.name "mathlib-nightly-testing[bot]" git config --global user.email "mathlib-nightly-testing[bot]@users.noreply.github.com" - name: Configure Lean uses: leanprover/lean-action@f807b338d95de7813c5c50d018f1c23c9b93b4ec # 2025-04-24 with: auto-config: false use-github-cache: false use-mathlib-cache: false # ============================================================================ # Phase 1: Bump the toolchain (commit locally, don't push yet) # ============================================================================ - name: Get old toolchain version id: old-toolchain run: | # Capture the current toolchain BEFORE we modify anything OLD=$(cut -f2 -d: lean-toolchain) echo "old=$OLD" echo "old=$OLD" >> "$GITHUB_OUTPUT" - name: Get latest release tag from leanprover/lean4-nightly id: get-latest-release env: GH_TOKEN: ${{ steps.app-token.outputs.token }} run: | RELEASE_TAG=$(gh api -X GET repos/leanprover/lean4-nightly/releases \ -f per_page=1 --jq '.[0].tag_name') if [ -z "$RELEASE_TAG" ] || [ "$RELEASE_TAG" = "null" ]; then echo "::error::Could not determine latest lean4-nightly release" exit 1 fi echo "RELEASE_TAG=$RELEASE_TAG" echo "RELEASE_TAG=$RELEASE_TAG" >> "$GITHUB_ENV" echo "new=$RELEASE_TAG" >> "$GITHUB_OUTPUT" - name: Update lean-toolchain file run: | echo "leanprover/lean4:${RELEASE_TAG}" > lean-toolchain - name: Commit toolchain bump (without pushing) id: commit-bump run: | git add lean-toolchain # Don't fail if there's nothing to commit (toolchain already up to date) if git commit -m "chore: bump to ${RELEASE_TAG}"; then echo "bumped=true" >> "$GITHUB_OUTPUT" else echo "bumped=false" >> "$GITHUB_OUTPUT" echo "Toolchain already at ${RELEASE_TAG}, no bump needed" fi # ============================================================================ # Phase 2: Find and merge pr-testing branches # ============================================================================ - name: Clone lean4-nightly and get PRs id: get-prs if: steps.commit-bump.outputs.bumped == 'true' run: | OLD="${{ steps.old-toolchain.outputs.old }}" NEW="${{ steps.get-latest-release.outputs.new }}" echo "Finding PRs between $OLD and $NEW" NIGHTLY_URL="https://github.com/leanprover/lean4-nightly.git" # Create a temporary directory for cloning cd "$(mktemp -d)" || exit 1 # Clone the repository with a depth of 1 git clone --depth 1 "$NIGHTLY_URL" # Navigate to the cloned repository cd lean4-nightly || exit 1 # Fetch the $OLD tag git fetch --depth=1 origin tag "$OLD" --no-tags # Fetch the $NEW tag git fetch origin tag "$NEW" --no-tags # Get all commit SHAs between the $OLD and $NEW toolchains COMMIT_SHAS=$(git log --format="%H" "$OLD..$NEW") # Initialize an empty string to collect PR numbers PRS="" # For each commit, query the GitHub API to get associated PRs for commit_sha in $COMMIT_SHAS; do echo "Checking commit $commit_sha for associated PRs..." # Query GitHub API for PRs associated with this commit pr_numbers=$(curl -s -H "Accept: application/vnd.github.v3+json" \ "https://api.github.com/repos/leanprover/lean4/commits/$commit_sha/pulls" | \ jq -r '.[] | select(.merged_at != null) | .number | tostring' 2>/dev/null || echo "") # Add each PR number to our list (duplicates will be handled later) for pr_num in $pr_numbers; do if [[ "$pr_num" =~ ^[0-9]+$ ]]; then PRS="$PRS $pr_num" echo "Found PR #$pr_num associated with commit $commit_sha" fi done done # Remove duplicates and trim whitespace PRS=$(echo "$PRS" | tr ' ' '\n' | sort -u | tr '\n' ' ' | xargs) # Output the PRs echo "Found PRs: $PRS" printf "prs<> "$GITHUB_OUTPUT" - name: Find matching pr-testing branches id: find-branches if: steps.commit-bump.outputs.bumped == 'true' run: | PRS="${{ steps.get-prs.outputs.prs }}" echo "=== PRS =========================" echo "$PRS" # CRITICAL: If no PRs were found, skip branch matching entirely. if [ -z "$PRS" ]; then echo "No PRs found between old and new nightlies. Skipping branch discovery." echo "branches_exist=false" >> "$GITHUB_ENV" printf "branches<> "$GITHUB_OUTPUT" exit 0 fi echo "$PRS" | tr ' ' '\n' > prs.txt echo "=== prs.txt =====================" cat prs.txt MATCHING_BRANCHES=$(git branch -r | grep -f prs.txt | grep "lean-pr-testing" || true) echo "=== MATCHING_BRANCHES ===========" echo "$MATCHING_BRANCHES" echo "=================================" # Initialize an empty variable to store branches with relevant diffs RELEVANT_BRANCHES="" # Loop through each matching branch for BRANCH in $MATCHING_BRANCHES; do echo " === Testing $BRANCH for relevance." # Get the diff filenames DIFF_FILES=$(git diff --name-only "origin/nightly-testing...$BRANCH") # Check if the diff contains files other than the specified ones # Note: Batteries uses lakefile.toml, not lakefile.lean if echo "$DIFF_FILES" | grep -v -e 'lake-manifest.json' -e 'lakefile.toml' -e 'lean-toolchain'; then # Extract the actual branch name ACTUAL_BRANCH=${BRANCH#origin/} # Append the branch details to RELEVANT_BRANCHES RELEVANT_BRANCHES="$RELEVANT_BRANCHES""$ACTUAL_BRANCH"$' ' fi done # Output the relevant branches echo "=== RELEVANT_BRANCHES ===========" echo "'$RELEVANT_BRANCHES'" printf "branches<> "$GITHUB_OUTPUT" # Check if there are relevant branches if [ -z "${RELEVANT_BRANCHES}" ]; then echo "branches_exist=false" >> "$GITHUB_ENV" else echo "branches_exist=true" >> "$GITHUB_ENV" fi - name: Execute merge script for each branch id: execute-merges if: steps.commit-bump.outputs.bumped == 'true' && env.branches_exist == 'true' run: | BRANCHES="${{ steps.find-branches.outputs.branches }}" # Initialize arrays to track results SUCCESSFUL_MERGES="" FAILED_MERGES="" # Ensure the merge script is executable chmod +x scripts/merge-lean-testing-pr.sh # Process each branch for BRANCH in $BRANCHES; do # Extract PR number from branch name PR_NUMBER=$(echo "$BRANCH" | grep -oP '\d+$') # Make sure we're on nightly-testing branch before doing fetch operations git checkout nightly-testing # Fetch all tags in the repository git fetch --tags # Fetch the PR branch git fetch origin "$BRANCH" # Find the most recent nightly-testing-YYYY-MM-DD tag that is an ancestor of the branch git checkout origin/"$BRANCH" || { echo "Failed to checkout branch origin/$BRANCH, skipping" continue } # Find tags that are ancestors of this branch with the right format LATEST_TAG=$(git tag --merged HEAD | grep "nightly-testing-[0-9]\{4\}-[0-9]\{2\}-[0-9]\{2\}" | sort -r | head -n 1) echo "Latest tag found for $BRANCH: ${LATEST_TAG:-none}" # Return to nightly-testing branch git checkout nightly-testing # Default to nightly-testing if no tag is found if [ -z "$LATEST_TAG" ]; then COMPARE_BASE="nightly-testing" else COMPARE_BASE="$LATEST_TAG" fi GITHUB_DIFF="https://github.com/leanprover-community/batteries/compare/$COMPARE_BASE...lean-pr-testing-$PR_NUMBER" echo "Attempting to merge branch: $BRANCH (PR #$PR_NUMBER)" echo "Using diff URL: $GITHUB_DIFF (comparing with $COMPARE_BASE)" # Reset to a clean state before running merge script git reset --hard HEAD # Run the merge script and capture exit code # Note: The merge script does its own commit but NOT push if ./scripts/merge-lean-testing-pr.sh "$PR_NUMBER"; then echo "Successfully merged $BRANCH" SUCCESSFUL_MERGES="$SUCCESSFUL_MERGES$PR_NUMBER|$GITHUB_DIFF|$BRANCH " else echo "Failed to merge $BRANCH" FAILED_MERGES="$FAILED_MERGES$PR_NUMBER|$GITHUB_DIFF|$BRANCH " # Clean up - reset to a clean state git reset --hard HEAD git checkout nightly-testing fi done # Output the results echo "successful_merges=$SUCCESSFUL_MERGES" >> "$GITHUB_OUTPUT" echo "failed_merges=$FAILED_MERGES" >> "$GITHUB_OUTPUT" # ============================================================================ # Phase 3: Push everything and notify # ============================================================================ - name: Push all changes if: steps.commit-bump.outputs.bumped == 'true' run: | # This pushes the toolchain bump commit plus any successful merge commits git push origin nightly-testing - name: Prepare Zulip message id: zulip-message if: steps.commit-bump.outputs.bumped == 'true' && env.branches_exist == 'true' run: | SUCCESSFUL_MERGES="${{ steps.execute-merges.outputs.successful_merges }}" FAILED_MERGES="${{ steps.execute-merges.outputs.failed_merges }}" # Start building the message MESSAGE="" # Report successful merges if [ -n "$SUCCESSFUL_MERGES" ]; then MESSAGE+=$'### Successfully merged branches into Batteries\' \'nightly-testing\':\n\n' for MERGE_INFO in $SUCCESSFUL_MERGES; do IFS='|' read -r PR_NUMBER GITHUB_DIFF _ <<< "$MERGE_INFO" MESSAGE+=$(printf -- '- [lean-pr-testing-%s](%s) (adaptations for lean#%s)' "$PR_NUMBER" "$GITHUB_DIFF" "$PR_NUMBER")$'\n\n' done MESSAGE+=$'\n' else MESSAGE+=$'No branches were successfully merged into Batteries\' \'nightly-testing\'. \n\n' fi # Report failed merges if [ -n "$FAILED_MERGES" ]; then MESSAGE+=$'### Failed merges:\n\nThe following branches need to be merged manually into Batteries\' \'nightly-testing\':\n\n' for MERGE_INFO in $FAILED_MERGES; do IFS='|' read -r PR_NUMBER GITHUB_DIFF _ <<< "$MERGE_INFO" MESSAGE+=$(printf '- [lean-pr-testing-%s](%s) (adaptations for lean#%s)' "$PR_NUMBER" "$GITHUB_DIFF" "$PR_NUMBER")$'\n\n' MESSAGE+=$'```bash\n' MESSAGE+=$(printf 'scripts/merge-lean-testing-pr.sh %s' "$PR_NUMBER")$'\n' MESSAGE+=$'```\n\n' done else MESSAGE+=$'All branches were successfully merged!\n' fi # Output the message using the correct GitHub Actions syntax printf 'msg<> "${GITHUB_ENV}" # Check if the remote tag exists if git ls-remote --tags --exit-code origin "nightly-testing-$version" >/dev/null; then printf 'Tag nightly-testing-%s already exists on the remote.' "${version}" else # If the tag does not exist, create and push the tag to remote printf 'Creating tag %s from the current state of the nightly-testing branch.' "nightly-testing-${version}" git tag "nightly-testing-${version}" git push origin "nightly-testing-${version}" fi hash="$(git rev-parse "nightly-testing-${version}")" printf 'SHA=%s\n' "${hash}" >> "${GITHUB_ENV}" else echo "Error: The file lean-toolchain does not contain the expected pattern." exit 1 fi # Now post a success message to zulip, if the last message there is not a success message. # https://chat.openai.com/share/87656d2c-c804-4583-91aa-426d4f1537b3 - name: Install Zulip API client run: pip install zulip - name: Check last message and post if necessary env: ZULIP_EMAIL: 'github-mathlib4-bot@leanprover.zulipchat.com' ZULIP_API_KEY: ${{ secrets.ZULIP_API_KEY }} ZULIP_SITE: 'https://leanprover.zulipchat.com' SHA: ${{ env.SHA }} run: | import os import zulip client = zulip.Client(email=os.getenv('ZULIP_EMAIL'), api_key=os.getenv('ZULIP_API_KEY'), site=os.getenv('ZULIP_SITE')) # Get the last message from the bot in the 'status updates' topic. # We narrow by sender to ignore human replies in between. bot_email = 'github-mathlib4-bot@leanprover.zulipchat.com' request = { 'anchor': 'newest', 'num_before': 1, 'num_after': 0, 'narrow': [ {'operator': 'stream', 'operand': 'nightly-testing-batteries'}, {'operator': 'topic', 'operand': 'Batteries status updates'}, {'operator': 'sender', 'operand': bot_email} ], 'apply_markdown': False # Otherwise the content test below fails. } response = client.get_messages(request) messages = response['messages'] if not messages or messages[0]['content'] != f"✅ The latest CI for Batteries' [nightly-testing branch](https://github.com/${{ github.repository }}/tree/nightly-testing) has succeeded! ([{os.getenv('SHA')}](https://github.com/${{ github.repository }}/commit/{os.getenv('SHA')}))": # Post the success message request = { 'type': 'stream', 'to': 'nightly-testing-batteries', 'topic': 'Batteries status updates', 'content': f"✅ The latest CI for Batteries' [nightly-testing branch](https://github.com/${{ github.repository }}/tree/nightly-testing) has succeeded! ([{os.getenv('SHA')}](https://github.com/${{ github.repository }}/commit/{os.getenv('SHA')}))" } result = client.send_message(request) print(result) shell: python # Next, determine if we should remind the humans to create a new PR to the `bump/v4.X.0` branch. - name: Check for matching bump/nightly-YYYY-MM-DD branch id: check_branch uses: actions/github-script@60a0d83039c74a4aee543508d2ffcb1c3799cdea # v7.0.1 with: script: | const branchName = `bump/nightly-${process.env.NIGHTLY}`; console.log(`Looking for branch: ${branchName}`); // Use paginate to get all branches const branches = await github.paginate(github.rest.repos.listBranches, { owner: context.repo.owner, repo: context.repo.repo }); const exists = branches.some(branch => branch.name === branchName); if (exists) { console.log(`Branch ${branchName} exists.`); return true; } else { console.log(`Branch ${branchName} does not exist.`); return false; } result-encoding: string - name: Exit if matching branch exists if: steps.check_branch.outputs.result == 'true' run: | echo "Matching bump/nightly-YYYY-MM-DD branch found, no further action needed." exit 0 - name: Fetch latest bump branch name id: latest_bump_branch uses: actions/github-script@60a0d83039c74a4aee543508d2ffcb1c3799cdea # v7.0.1 with: result-encoding: string script: | const branches = await github.paginate(github.rest.repos.listBranches, { owner: context.repo.owner, repo: context.repo.repo }); const bumpBranches = branches .map(branch => branch.name) .filter(name => name.match(/^bump\/v4\.\d+\.0$/)) .sort((a, b) => b.localeCompare(a, undefined, {numeric: true, sensitivity: 'base'})); if (!bumpBranches.length) { throw new Exception("Did not find any bump/v4.x.0 branch") } const latestBranch = bumpBranches[0]; return latestBranch; - name: Fetch lean-toolchain from latest bump branch id: bump_version uses: actions/github-script@60a0d83039c74a4aee543508d2ffcb1c3799cdea # v7.0.1 with: script: | try { const response = await github.rest.repos.getContent({ owner: context.repo.owner, repo: context.repo.repo, path: 'lean-toolchain', ref: '${{ steps.latest_bump_branch.outputs.result }}' }); const content = Buffer.from(response.data.content, 'base64').toString(); const match = content.match(/leanprover\/lean4:nightly-(\d{4}-\d{2}-\d{2})/); if (!match) { core.setFailed('Toolchain pattern did not match'); core.setOutput('toolchain_content', content); return null; } return match[1]; } catch (error) { core.setFailed(error.message); return null; } - name: Send warning message on Zulip if pattern doesn't match if: failure() uses: zulip/github-actions-zulip/send-message@e4c8f27c732ba9bd98ac6be0583096dea82feea5 # v1.0.2 with: api-key: ${{ secrets.ZULIP_API_KEY }} email: 'github-mathlib4-bot@leanprover.zulipchat.com' organization-url: 'https://leanprover.zulipchat.com' to: 'nightly-testing-batteries' type: 'stream' topic: 'Batteries status updates' content: | ⚠️ Warning: The lean-toolchain file in the latest bump branch does not match the expected pattern 'leanprover/lean4:nightly-YYYY-MM-DD'. Current content: ${{ steps.bump_version.outputs.toolchain_content }} This needs to be fixed for the nightly testing process to work correctly. - name: Setup for automatic PR creation if: steps.check_branch.outputs.result == 'false' env: BUMP_VERSION: ${{ steps.bump_version.outputs.result }} BUMP_BRANCH: ${{ steps.latest_bump_branch.outputs.result }} SHA: ${{ env.SHA }} run: | echo "Installing zulip CLI..." pip install zulip echo "Configuring git identity for mathlib4-bot..." git config --global user.name "mathlib4-bot" git config --global user.email "github-mathlib4-bot@leanprover.zulipchat.com" echo "Setting up zulip credentials..." { echo "[api]" echo "email=github-mathlib4-bot@leanprover.zulipchat.com" echo "key=${{ secrets.ZULIP_API_KEY }}" echo "site=https://leanprover.zulipchat.com" } > ~/.zuliprc chmod 600 ~/.zuliprc echo "Setup complete" - name: Clean workspace and checkout Batteries if: steps.check_branch.outputs.result == 'false' run: | sudo rm -rf -- * # Regenerate the app token just before use. # GitHub App tokens expire after 1 hour, and the preceding steps can take longer than that. - name: Regenerate app token for Batteries checkout if: steps.check_branch.outputs.result == 'false' id: app-token-2 uses: actions/create-github-app-token@29824e69f54612133e76f7eaac726eef6c875baf # v2.2.1 with: app-id: ${{ secrets.MATHLIB_NIGHTLY_TESTING_APP_ID }} private-key: ${{ secrets.MATHLIB_NIGHTLY_TESTING_PRIVATE_KEY }} - name: Checkout Batteries repository uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 if: steps.check_branch.outputs.result == 'false' with: ref: nightly-testing # checkout nightly-testing branch (shouldn't matter which) fetch-depth: 0 # checkout all branches token: ${{ steps.app-token-2.outputs.token }} - name: Attempt automatic PR creation id: auto_pr if: steps.check_branch.outputs.result == 'false' continue-on-error: true env: BUMP_VERSION: ${{ steps.bump_version.outputs.result }} BUMP_BRANCH: ${{ steps.latest_bump_branch.outputs.result }} SHA: ${{ env.SHA }} GH_TOKEN: ${{ steps.app-token-2.outputs.token }} ZULIP_API_KEY: ${{ secrets.ZULIP_API_KEY }} run: | echo "Current version: ${NIGHTLY}" echo "Target bump branch: ${BUMP_BRANCH}" echo "Using commit SHA: ${SHA}" current_version="${NIGHTLY}" bump_branch_suffix="${BUMP_BRANCH#bump/}" echo "Running create-adaptation-pr.sh with:" echo " bumpversion: ${bump_branch_suffix}" echo " nightlydate: ${current_version}" echo " nightlysha: ${SHA}" ./scripts/create-adaptation-pr.sh --bumpversion="${bump_branch_suffix}" --nightlydate="${current_version}" --nightlysha="${SHA}" --auto=yes - name: Fallback to manual instructions if: steps.auto_pr.outcome == 'failure' && steps.check_branch.outputs.result == 'false' env: BUMP_VERSION: ${{ steps.bump_version.outputs.result }} BUMP_BRANCH: ${{ steps.latest_bump_branch.outputs.result }} SHA: ${{ env.SHA }} ZULIP_API_KEY: ${{ secrets.ZULIP_API_KEY }} REPOSITORY: ${{ github.repository }} CURRENT_RUN_ID: ${{ github.run_id }} shell: python run: | import os import re import zulip client = zulip.Client(config_file="~/.zuliprc") current_version = os.getenv('NIGHTLY') bump_version = os.getenv('BUMP_VERSION') bump_branch = os.getenv('BUMP_BRANCH') sha = os.getenv('SHA') repository = os.getenv('REPOSITORY') current_run_id = os.getenv('CURRENT_RUN_ID') print(f'Current version: {current_version}, Bump version: {bump_version}, SHA: {sha}') if current_version > bump_version: print('Lean toolchain in `nightly-testing` is ahead of the bump branch.') # Get the last message from the bot in the 'Batteries bump branch reminders' topic. # We narrow by sender to ignore human replies in between. bot_email = 'github-mathlib4-bot@leanprover.zulipchat.com' request = { 'anchor': 'newest', 'num_before': 1, 'num_after': 0, 'narrow': [ {'operator': 'stream', 'operand': 'nightly-testing-batteries'}, {'operator': 'topic', 'operand': 'Batteries bump branch reminders'}, {'operator': 'sender', 'operand': bot_email} ], 'apply_markdown': False # Otherwise the content test below fails. } response = client.get_messages(request) messages = response['messages'] last_bot_message = messages[0] if messages else None bump_branch_suffix = bump_branch.replace('bump/', '') failed_link = f"https://github.com/{repository}/actions/runs/{current_run_id}" payload = f"🛠️: Automatic PR creation [failed]({failed_link}). Please create a new bump/nightly-{current_version} branch from nightly-testing (specifically {sha}), and then PR that to {bump_branch}. " payload += "To do so semi-automatically, run the following script from Batteries root:\n\n" payload += f"```bash\n./scripts/create-adaptation-pr.sh --bumpversion={bump_branch_suffix} --nightlydate={current_version} --nightlysha={sha}\n```\n" # Check if we already posted a message for this nightly date and bump branch. # We extract these fields from the last bot message rather than comparing substrings, # since the message also contains a run ID that differs between workflow runs. should_post = True if last_bot_message: last_content = last_bot_message['content'] # Extract nightly date and bump branch from last bot message date_match = re.search(r'bump/nightly-(\d{4}-\d{2}-\d{2})', last_content) branch_match = re.search(r'PR that to (bump/v[\d.]+)', last_content) if date_match and branch_match: last_date = date_match.group(1) last_branch = branch_match.group(1) if last_date == current_version and last_branch == bump_branch: should_post = False print(f'Already posted for nightly {current_version} and {bump_branch}') if should_post: if last_bot_message: print("###### Last bot message:") print(last_bot_message['content']) print("###### Current message:") print(payload) # Post the reminder message request = { 'type': 'stream', 'to': 'nightly-testing-batteries', 'topic': 'Batteries bump branch reminders', 'content': payload } result = client.send_message(request) print(result) else: print('No action needed.') ================================================ FILE: .github/workflows/nightly_merge_master.yml ================================================ # This job merges every commit to `main` into `nightly-testing`, resolving merge conflicts in favor of `nightly-testing`. name: Merge main to nightly on: push: branches: - main jobs: merge-to-nightly: if: github.repository_owner == 'leanprover-community' runs-on: ubuntu-latest steps: - name: Generate app token id: app-token uses: actions/create-github-app-token@29824e69f54612133e76f7eaac726eef6c875baf # v2.2.1 with: app-id: ${{ secrets.MATHLIB_NIGHTLY_TESTING_APP_ID }} private-key: ${{ secrets.MATHLIB_NIGHTLY_TESTING_PRIVATE_KEY }} # The create-github-app-token README states that this token is masked and will not be logged accidentally. - name: Checkout repository uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 with: fetch-depth: 0 token: ${{ steps.app-token.outputs.token }} - name: Configure Git User run: | git config user.name "mathlib-nightly-testing[bot]" git config user.email "mathlib-nightly-testing[bot]@users.noreply.github.com" - name: Merge main to nightly favoring nightly changes run: | git checkout nightly-testing git merge main --strategy-option ours --no-commit --allow-unrelated-histories git commit -m "Merge main into nightly-testing" git push origin nightly-testing ================================================ FILE: .github/workflows/test_mathlib.yml ================================================ # Test Mathlib against a Batteries PR name: Test Mathlib on: workflow_run: workflows: [ci] types: [completed] jobs: on-success: runs-on: ubuntu-latest if: github.event.workflow_run.conclusion == 'success' && github.event.workflow_run.event == 'pull_request' && github.repository == 'leanprover-community/batteries' steps: - name: Checkout PR uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 with: fetch-depth: 0 - name: Get PR info id: pr-info run: | echo "pullRequestNumber=$(gh pr list --search $SHA --json number -q '.[0].number' || echo '')" >> $GITHUB_OUTPUT echo "targetBranch=$(gh pr list --search $SHA --json baseRefName -q '.[0].baseRefName' || echo '')" >> $GITHUB_OUTPUT env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} SHA: ${{ github.event.workflow_run.head_sha }} - name: Generate app token if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' id: app-token uses: actions/create-github-app-token@29824e69f54612133e76f7eaac726eef6c875baf # v2.2.1 with: app-id: ${{ secrets.MATHLIB_NIGHTLY_TESTING_APP_ID }} private-key: ${{ secrets.MATHLIB_NIGHTLY_TESTING_PRIVATE_KEY }} owner: leanprover-community repositories: mathlib4,mathlib4-nightly-testing - name: Checkout mathlib4 repository if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 with: repository: leanprover-community/mathlib4 token: ${{ steps.app-token.outputs.token }} ref: master fetch-depth: 0 - name: Add nightly-testing remote if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' run: | git remote add nightly-testing https://github.com/leanprover-community/mathlib4-nightly-testing.git git fetch nightly-testing - name: Install elan if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' run: | set -o pipefail curl -sSfL https://github.com/leanprover/elan/releases/download/v3.0.0/elan-x86_64-unknown-linux-gnu.tar.gz | tar xz ./elan-init -y --default-toolchain none echo "$HOME/.elan/bin" >> "${GITHUB_PATH}" - name: Check if branch exists if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' id: check_mathlib_tag env: PR_NUMBER: ${{ steps.pr-info.outputs.pullRequestNumber }} HEAD_REPO: ${{ github.event.workflow_run.head_repository.full_name }} HEAD_BRANCH: ${{ github.event.workflow_run.head_branch }} run: | git config user.name "mathlib-nightly-testing[bot]" git config user.email "mathlib-nightly-testing[bot]@users.noreply.github.com" echo "PR info: $HEAD_REPO $HEAD_BRANCH" BASE=master echo "Using base tag: $BASE" EXISTS="$(git ls-remote --heads nightly-testing batteries-pr-testing-$PR_NUMBER | wc -l)" echo "Branch exists: $EXISTS" if [ "$EXISTS" = "0" ]; then echo "Branch does not exist, creating it." git switch -c batteries-pr-testing-$PR_NUMBER "$BASE" # Modify the lakefile.lean with the fork and branch name sed -i "s,require \"leanprover-community\" / \"batteries\" @ git \".\+\",require \"leanprover-community\" / \"batteries\" from git \"https://github.com/$HEAD_REPO\" @ \"$HEAD_BRANCH\",g" lakefile.lean lake update batteries git add lakefile.lean lake-manifest.json git commit -m "Update Batteries branch for testing https://github.com/leanprover-community/batteries/pull/$PR_NUMBER" else echo "Branch already exists, merging $BASE and bumping Batteries." git switch batteries-pr-testing-$PR_NUMBER git merge "$BASE" --strategy-option ours --no-commit --allow-unrelated-histories lake update batteries git add lake-manifest.json git commit --allow-empty -m "Trigger CI for https://github.com/leanprover-community/batteries/pull/$PR_NUMBER" fi - name: Push changes if: steps.pr-info.outputs.pullRequestNumber != '' && steps.pr-info.outputs.targetBranch == 'main' env: PR_NUMBER: ${{ steps.pr-info.outputs.pullRequestNumber }} run: | git push nightly-testing batteries-pr-testing-$PR_NUMBER ================================================ FILE: .gitignore ================================================ # Prior to v4.3.0-rc2 lake stored files in these locations. # We'll leave them in the `.gitignore` for a while for users switching between toolchains. /build/ /lake-packages/ /lakefile.olean # After v4.3.0-rc2 lake stores its files here: /.lake/ ================================================ FILE: .gitpod.yml ================================================ image: file: .docker/gitpod/Dockerfile vscode: extensions: - leanprover.lean4 tasks: - init: | elan self update lake build ================================================ FILE: .vscode/copyright.code-snippets ================================================ { "Copyright header for batteries": { "scope": "lean4", "prefix": "copyright", "body": [ "/-", "Copyright (c) ${CURRENT_YEAR} $1. All rights reserved.", "Released under Apache 2.0 license as described in the file LICENSE.", "Authors: $1", "-/" ] } } ================================================ FILE: .vscode/settings.json ================================================ { "editor.insertSpaces": true, "editor.tabSize": 2, "editor.rulers" : [100], "files.encoding": "utf8", "files.eol": "\n", "files.insertFinalNewline": true, "files.trimFinalNewlines": true, "files.trimTrailingWhitespace": true, "search.usePCRE2": true } ================================================ FILE: Batteries/Classes/Cast.lean ================================================ /- Copyright (c) 2014 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Gabriel Ebner -/ module public import Batteries.Util.LibraryNote @[expose] public section library_note «coercion into rings» /-- Coercions such as `Nat.castCoe` that go from a concrete structure such as `Nat` to an arbitrary ring `R` should be set up as follows: ```lean instance : CoeTail Nat R where coe := ... instance : CoeHTCT Nat R where coe := ... ``` It needs to be `CoeTail` instead of `Coe` because otherwise type-class inference would loop when constructing the transitive coercion `Nat → Nat → Nat → ...`. Sometimes we also need to declare the `CoeHTCT` instance if we need to shadow another coercion (e.g. `Nat.cast` should be used over `Int.ofNat`). -/ ================================================ FILE: Batteries/Classes/Deprecated.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Classes.Order @[expose] public section /-! Deprecated Batteries comparison classes Examples are to ensure that old instances have equivalent new instances. -/ set_option linter.deprecated false namespace Batteries /-- `OrientedCmp cmp` asserts that `cmp` is determined by the relation `cmp x y = .lt`. -/ @[deprecated Std.OrientedCmp (since := "2025-07-01")] class OrientedCmp (cmp : α → α → Ordering) : Prop where /-- The comparator operation is symmetric, in the sense that if `cmp x y` equals `.lt` then `cmp y x = .gt` and vice versa. -/ symm (x y) : (cmp x y).swap = cmp y x attribute [deprecated Std.OrientedOrd.eq_swap (since := "2025-07-01")] OrientedCmp.symm namespace OrientedCmp @[deprecated Std.OrientedCmp.gt_iff_lt (since := "2025-07-01")] theorem cmp_eq_gt [OrientedCmp cmp] : cmp x y = .gt ↔ cmp y x = .lt := by rw [← Ordering.swap_inj, symm]; exact .rfl @[deprecated Std.OrientedCmp.le_iff_ge (since := "2025-07-01")] theorem cmp_ne_gt [OrientedCmp cmp] : cmp x y ≠ .gt ↔ cmp y x ≠ .lt := not_congr cmp_eq_gt @[deprecated Std.OrientedCmp.eq_comm (since := "2025-07-01")] theorem cmp_eq_eq_symm [OrientedCmp cmp] : cmp x y = .eq ↔ cmp y x = .eq := by rw [← Ordering.swap_inj, symm]; exact .rfl @[deprecated Std.ReflCmp.compare_self (since := "2025-07-01")] theorem cmp_refl [OrientedCmp cmp] : cmp x x = .eq := match e : cmp x x with | .lt => nomatch e.symm.trans (cmp_eq_gt.2 e) | .eq => rfl | .gt => nomatch (cmp_eq_gt.1 e).symm.trans e @[deprecated Std.OrientedCmp.not_lt_of_lt (since := "2025-07-01")] theorem lt_asymm [OrientedCmp cmp] (h : cmp x y = .lt) : cmp y x ≠ .lt := fun h' => nomatch h.symm.trans (cmp_eq_gt.2 h') @[deprecated Std.OrientedCmp.not_gt_of_gt (since := "2025-07-01")] theorem gt_asymm [OrientedCmp cmp] (h : cmp x y = .gt) : cmp y x ≠ .gt := mt cmp_eq_gt.1 <| lt_asymm <| cmp_eq_gt.1 h end OrientedCmp /-- `TransCmp cmp` asserts that `cmp` induces a transitive relation. -/ @[deprecated Std.TransCmp (since := "2025-07-01")] class TransCmp (cmp : α → α → Ordering) : Prop extends OrientedCmp cmp where /-- The comparator operation is transitive. -/ le_trans : cmp x y ≠ .gt → cmp y z ≠ .gt → cmp x z ≠ .gt attribute [deprecated Std.TransCmp.le_trans (since := "2025-07-01")] TransCmp.le_trans namespace TransCmp variable [TransCmp cmp] open OrientedCmp Decidable @[deprecated Std.TransCmp.ge_trans (since := "2025-07-01")] theorem ge_trans (h₁ : cmp x y ≠ .lt) (h₂ : cmp y z ≠ .lt) : cmp x z ≠ .lt := by have := @TransCmp.le_trans _ cmp _ z y x simp [cmp_eq_gt] at *; exact this h₂ h₁ @[deprecated Std.TransCmp.lt_of_le_of_lt (since := "2025-07-01")] theorem le_lt_trans (h₁ : cmp x y ≠ .gt) (h₂ : cmp y z = .lt) : cmp x z = .lt := byContradiction fun h₃ => ge_trans (mt cmp_eq_gt.2 h₁) h₃ h₂ @[deprecated Std.TransCmp.lt_of_lt_of_le (since := "2025-07-01")] theorem lt_le_trans (h₁ : cmp x y = .lt) (h₂ : cmp y z ≠ .gt) : cmp x z = .lt := byContradiction fun h₃ => ge_trans h₃ (mt cmp_eq_gt.2 h₂) h₁ @[deprecated Std.TransCmp.lt_trans (since := "2025-07-01")] theorem lt_trans (h₁ : cmp x y = .lt) (h₂ : cmp y z = .lt) : cmp x z = .lt := le_lt_trans (gt_asymm <| cmp_eq_gt.2 h₁) h₂ @[deprecated Std.TransCmp.gt_trans (since := "2025-07-01")] theorem gt_trans (h₁ : cmp x y = .gt) (h₂ : cmp y z = .gt) : cmp x z = .gt := by rw [cmp_eq_gt] at h₁ h₂ ⊢; exact lt_trans h₂ h₁ @[deprecated Std.TransCmp.congr_left (since := "2025-07-01")] theorem cmp_congr_left (xy : cmp x y = .eq) : cmp x z = cmp y z := match yz : cmp y z with | .lt => byContradiction (ge_trans (nomatch ·.symm.trans (cmp_eq_eq_symm.1 xy)) · yz) | .gt => byContradiction (le_trans (nomatch ·.symm.trans (cmp_eq_eq_symm.1 xy)) · yz) | .eq => match xz : cmp x z with | .lt => nomatch ge_trans (nomatch ·.symm.trans xy) (nomatch ·.symm.trans yz) xz | .gt => nomatch le_trans (nomatch ·.symm.trans xy) (nomatch ·.symm.trans yz) xz | .eq => rfl @[deprecated Std.TransCmp.congr_left (since := "2025-07-01")] theorem cmp_congr_left' (xy : cmp x y = .eq) : cmp x = cmp y := funext fun _ => cmp_congr_left xy @[deprecated Std.TransCmp.congr_right (since := "2025-07-01")] theorem cmp_congr_right (yz : cmp y z = .eq) : cmp x y = cmp x z := by rw [← Ordering.swap_inj, symm, symm, cmp_congr_left yz] end TransCmp instance [inst : OrientedCmp cmp] : OrientedCmp (flip cmp) where symm _ _ := inst.symm .. example [inst : Std.OrientedCmp cmp] : Std.OrientedCmp (flip cmp) := inferInstance instance [inst : TransCmp cmp] : TransCmp (flip cmp) where le_trans h1 h2 := inst.le_trans h2 h1 example [inst : Std.TransCmp cmp] : Std.TransCmp (flip cmp) := inferInstance /-- `BEqCmp cmp` asserts that `cmp x y = .eq` and `x == y` coincide. -/ @[deprecated Std.LawfulBEqCmp (since := "2025-07-01")] class BEqCmp [BEq α] (cmp : α → α → Ordering) : Prop where /-- `cmp x y = .eq` holds iff `x == y` is true. -/ cmp_iff_beq : cmp x y = .eq ↔ x == y attribute [deprecated Std.LawfulBEqCmp.compare_eq_iff_beq (since := "2025-07-01")] BEqCmp.cmp_iff_beq @[deprecated Std.LawfulEqCmp.compare_eq_iff_eq (since := "2025-07-01")] theorem BEqCmp.cmp_iff_eq [BEq α] [LawfulBEq α] [BEqCmp (α := α) cmp] : cmp x y = .eq ↔ x = y := by simp [BEqCmp.cmp_iff_beq] /-- `LTCmp cmp` asserts that `cmp x y = .lt` and `x < y` coincide. -/ @[deprecated Std.LawfulLTCmp (since := "2025-07-01")] class LTCmp [LT α] (cmp : α → α → Ordering) : Prop extends OrientedCmp cmp where /-- `cmp x y = .lt` holds iff `x < y` is true. -/ cmp_iff_lt : cmp x y = .lt ↔ x < y attribute [deprecated Std.LawfulLTCmp.eq_lt_iff_lt (since := "2025-07-01")] LTCmp.cmp_iff_lt @[deprecated Std.LawfulLTCmp.eq_gt_iff_gt (since := "2025-07-01")] theorem LTCmp.cmp_iff_gt [LT α] [LTCmp (α := α) cmp] : cmp x y = .gt ↔ y < x := by rw [OrientedCmp.cmp_eq_gt, LTCmp.cmp_iff_lt] /-- `LECmp cmp` asserts that `cmp x y ≠ .gt` and `x ≤ y` coincide. -/ @[deprecated Std.LawfulLECmp (since := "2025-07-01")] class LECmp [LE α] (cmp : α → α → Ordering) : Prop extends OrientedCmp cmp where /-- `cmp x y ≠ .gt` holds iff `x ≤ y` is true. -/ cmp_iff_le : cmp x y ≠ .gt ↔ x ≤ y attribute [deprecated Std.LawfulLECmp.ne_gt_iff_le (since := "2025-07-01")] LECmp.cmp_iff_le @[deprecated Std.LawfulLECmp.ne_lt_iff_ge (since := "2025-07-01")] theorem LECmp.cmp_iff_ge [LE α] [LECmp (α := α) cmp] : cmp x y ≠ .lt ↔ y ≤ x := by rw [← OrientedCmp.cmp_ne_gt, LECmp.cmp_iff_le] /-- `LawfulCmp cmp` asserts that the `LE`, `LT`, `BEq` instances are all coherent with each other and with `cmp`, describing a strict weak order (a linear order except for antisymmetry). -/ @[deprecated Std.LawfulBCmp (since := "2025-07-01")] class LawfulCmp [LE α] [LT α] [BEq α] (cmp : α → α → Ordering) : Prop extends TransCmp cmp, BEqCmp cmp, LTCmp cmp, LECmp cmp /-- `OrientedOrd α` asserts that the `Ord` instance satisfies `OrientedCmp`. -/ @[deprecated Std.OrientedOrd (since := "2025-07-01")] abbrev OrientedOrd (α) [Ord α] := OrientedCmp (α := α) compare /-- `TransOrd α` asserts that the `Ord` instance satisfies `TransCmp`. -/ @[deprecated Std.TransOrd (since := "2025-07-01")] abbrev TransOrd (α) [Ord α] := TransCmp (α := α) compare /-- `BEqOrd α` asserts that the `Ord` and `BEq` instances are coherent via `BEqCmp`. -/ @[deprecated Std.LawfulBEqOrd (since := "2025-07-01")] abbrev BEqOrd (α) [BEq α] [Ord α] := BEqCmp (α := α) compare /-- `LTOrd α` asserts that the `Ord` instance satisfies `LTCmp`. -/ @[deprecated Std.LawfulLTOrd (since := "2025-07-01")] abbrev LTOrd (α) [LT α] [Ord α] := LTCmp (α := α) compare /-- `LEOrd α` asserts that the `Ord` instance satisfies `LECmp`. -/ @[deprecated Std.LawfulLEOrd (since := "2025-07-01")] abbrev LEOrd (α) [LE α] [Ord α] := LECmp (α := α) compare /-- `LawfulOrd α` asserts that the `Ord` instance satisfies `LawfulCmp`. -/ @[deprecated Std.LawfulBOrd (since := "2025-07-01")] abbrev LawfulOrd (α) [LE α] [LT α] [BEq α] [Ord α] := LawfulCmp (α := α) compare @[deprecated Std.TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_antisymm (since := "2025-07-01")] protected theorem TransCmp.compareOfLessAndEq [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (lt_antisymm : ∀ {x y : α}, ¬x < y → ¬y < x → x = y) : TransCmp (α := α) (compareOfLessAndEq · ·) := by have : OrientedCmp (α := α) (compareOfLessAndEq · ·) := by refine { symm := fun x y => ?_ } simp [compareOfLessAndEq]; split <;> [rename_i xy; split <;> [subst y; rename_i xy ne]] · rw [if_neg, if_neg]; rfl · rintro rfl; exact lt_irrefl _ xy · exact fun yx => lt_irrefl _ (lt_trans xy yx) · rw [if_neg ‹_›, if_pos rfl]; rfl · split <;> [rfl; rename_i yx] cases ne (lt_antisymm xy yx) refine { this with le_trans := fun {x y z} yx zy => ?_ } rw [Ne, this.cmp_eq_gt, compareOfLessAndEq_eq_lt] at yx zy ⊢ intro zx if xy : x < y then exact zy (lt_trans zx xy) else exact zy (lt_antisymm yx xy ▸ zx) @[deprecated Std.TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (since := "2025-07-01")] theorem TransCmp.compareOfLessAndEq_of_le [LT α] [LE α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y → y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : TransCmp (α := α) (compareOfLessAndEq · ·) := .compareOfLessAndEq lt_irrefl lt_trans fun xy yx => le_antisymm (not_lt yx) (not_lt xy) @[deprecated Std.LawfulBEqCmp.compareOfLessAndEq_of_lt_irrefl (since := "2025-07-01")] protected theorem BEqCmp.compareOfLessAndEq [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] [BEq α] [LawfulBEq α] (lt_irrefl : ∀ x : α, ¬x < x) : BEqCmp (α := α) (compareOfLessAndEq · ·) where cmp_iff_beq {x y} := by simp [compareOfLessAndEq] split <;> [skip; split] <;> simp [*] rintro rfl; exact lt_irrefl _ ‹_› @[deprecated Std.LawfulLTCmp.compareOfLessAndEq_of_irrefl_of_trans_of_antisymm (since := "2025-07-01")] protected theorem LTCmp.compareOfLessAndEq [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (lt_antisymm : ∀ {x y : α}, ¬x < y → ¬y < x → x = y) : LTCmp (α := α) (compareOfLessAndEq · ·) := { TransCmp.compareOfLessAndEq lt_irrefl lt_trans lt_antisymm with cmp_iff_lt := compareOfLessAndEq_eq_lt } @[deprecated Std.LawfulLTCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (since := "2025-07-01")] protected theorem LTCmp.compareOfLessAndEq_of_le [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] [LE α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y → y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LTCmp (α := α) (compareOfLessAndEq · ·) := { TransCmp.compareOfLessAndEq_of_le lt_irrefl lt_trans not_lt le_antisymm with cmp_iff_lt := compareOfLessAndEq_eq_lt } @[deprecated Std.LawfulLECmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (since := "2025-07-01")] protected theorem LECmp.compareOfLessAndEq [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] [LE α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y ↔ y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LECmp (α := α) (compareOfLessAndEq · ·) := have := TransCmp.compareOfLessAndEq_of_le lt_irrefl lt_trans not_lt.1 le_antisymm { this with cmp_iff_le := (this.cmp_ne_gt).trans <| (not_congr compareOfLessAndEq_eq_lt).trans not_lt } @[deprecated Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (since := "2025-07-01")] protected theorem LawfulCmp.compareOfLessAndEq [LT α] [DecidableRel (LT.lt (α := α))] [DecidableEq α] [BEq α] [LawfulBEq α] [LE α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y ↔ y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LawfulCmp (α := α) (compareOfLessAndEq · ·) := { TransCmp.compareOfLessAndEq_of_le lt_irrefl lt_trans not_lt.1 le_antisymm, LTCmp.compareOfLessAndEq_of_le lt_irrefl lt_trans not_lt.1 le_antisymm, LECmp.compareOfLessAndEq lt_irrefl lt_trans not_lt le_antisymm, BEqCmp.compareOfLessAndEq lt_irrefl with } @[deprecated Std.LawfulLTCmp.eq_compareOfLessAndEq (since := "2025-07-01")] theorem LTCmp.eq_compareOfLessAndEq [LT α] [DecidableEq α] [BEq α] [LawfulBEq α] [BEqCmp cmp] [LTCmp cmp] (x y : α) [Decidable (x < y)] : cmp x y = compareOfLessAndEq x y := by simp [compareOfLessAndEq] split <;> rename_i h1 <;> [skip; split <;> rename_i h2] · exact LTCmp.cmp_iff_lt.2 h1 · exact BEqCmp.cmp_iff_eq.2 h2 · cases e : cmp x y · cases h1 (LTCmp.cmp_iff_lt.1 e) · cases h2 (BEqCmp.cmp_iff_eq.1 e) · rfl instance [inst₁ : OrientedCmp cmp₁] [inst₂ : OrientedCmp cmp₂] : OrientedCmp (compareLex cmp₁ cmp₂) where symm _ _ := by simp [compareLex, Ordering.swap_then]; rw [inst₁.symm, inst₂.symm] example [inst₁ : Std.OrientedCmp cmp₁] [inst₂ : Std.OrientedCmp cmp₂] : Std.OrientedCmp (compareLex cmp₁ cmp₂) := inferInstance instance [inst₁ : TransCmp cmp₁] [inst₂ : TransCmp cmp₂] : TransCmp (compareLex cmp₁ cmp₂) where le_trans {a b c} h1 h2 := by simp only [compareLex, ne_eq, Ordering.then_eq_gt, not_or, not_and] at h1 h2 ⊢ refine ⟨inst₁.le_trans h1.1 h2.1, fun e1 e2 => ?_⟩ match ab : cmp₁ a b with | .gt => exact h1.1 ab | .eq => exact inst₂.le_trans (h1.2 ab) (h2.2 (inst₁.cmp_congr_left ab ▸ e1)) e2 | .lt => exact h2.1 <| (inst₁.cmp_eq_gt).2 (inst₁.cmp_congr_left e1 ▸ ab) example [inst₁ : Std.TransCmp cmp₁] [inst₂ : Std.TransCmp cmp₂] : Std.TransCmp (compareLex cmp₁ cmp₂) := inferInstance instance [Ord β] [OrientedOrd β] (f : α → β) : OrientedCmp (compareOn f) where symm _ _ := OrientedCmp.symm (α := β) .. example [Ord β] [Std.OrientedOrd β] (f : α → β) : Std.OrientedCmp (compareOn f) := inferInstance instance [Ord β] [TransOrd β] (f : α → β) : TransCmp (compareOn f) where le_trans := TransCmp.le_trans (α := β) example [Ord β] [Std.TransOrd β] (f : α → β) : Std.TransCmp (compareOn f) := inferInstance section «non-canonical instances» -- Note: the following instances seem to cause lean to fail, see: -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Typeclass.20inference.20crashes/near/432836360 /-- Local instance for `OrientedOrd lexOrd`. -/ @[deprecated "instance exists" (since := "2025-07-01")] theorem OrientedOrd.instLexOrd [Ord α] [Ord β] [OrientedOrd α] [OrientedOrd β] : @OrientedOrd (α × β) lexOrd := by rw [OrientedOrd, lexOrd_def]; infer_instance /-- Local instance for `TransOrd lexOrd`. -/ @[deprecated "instance exists" (since := "2025-07-01")] theorem TransOrd.instLexOrd [Ord α] [Ord β] [TransOrd α] [TransOrd β] : @TransOrd (α × β) lexOrd := by rw [TransOrd, lexOrd_def]; infer_instance /-- Local instance for `OrientedOrd ord.opposite`. -/ @[deprecated Std.OrientedOrd.opposite (since := "2025-07-01")] theorem OrientedOrd.instOpposite [ord : Ord α] [inst : OrientedOrd α] : @OrientedOrd _ ord.opposite where symm _ _ := inst.symm .. /-- Local instance for `TransOrd ord.opposite`. -/ @[deprecated Std.TransOrd.opposite (since := "2025-07-01")] theorem TransOrd.instOpposite [ord : Ord α] [inst : TransOrd α] : @TransOrd _ ord.opposite := { OrientedOrd.instOpposite with le_trans := fun h1 h2 => inst.le_trans h2 h1 } /-- Local instance for `OrientedOrd (ord.on f)`. -/ @[deprecated Std.OrientedOrd.instOn (since := "2025-07-01")] theorem OrientedOrd.instOn [ord : Ord β] [OrientedOrd β] (f : α → β) : @OrientedOrd _ (ord.on f) := inferInstanceAs (@OrientedCmp _ (compareOn f)) /-- Local instance for `TransOrd (ord.on f)`. -/ @[deprecated Std.TransOrd.instOn (since := "2025-07-01")] theorem TransOrd.instOn [ord : Ord β] [TransOrd β] (f : α → β) : @TransOrd _ (ord.on f) := inferInstanceAs (@TransCmp _ (compareOn f)) /-- Local instance for `OrientedOrd (oα.lex oβ)`. -/ @[deprecated "instance exists" (since := "2025-07-01")] theorem OrientedOrd.instOrdLex [oα : Ord α] [oβ : Ord β] [OrientedOrd α] [OrientedOrd β] : @OrientedOrd _ (oα.lex oβ) := OrientedOrd.instLexOrd /-- Local instance for `TransOrd (oα.lex oβ)`. -/ @[deprecated "instance exists" (since := "2025-07-01")] theorem TransOrd.instOrdLex [oα : Ord α] [oβ : Ord β] [TransOrd α] [TransOrd β] : @TransOrd _ (oα.lex oβ) := TransOrd.instLexOrd /-- Local instance for `OrientedOrd (oα.lex' oβ)`. -/ @[deprecated Std.OrientedOrd.instOrdLex' (since := "2025-07-01")] theorem OrientedOrd.instOrdLex' (ord₁ ord₂ : Ord α) [@OrientedOrd _ ord₁] [@OrientedOrd _ ord₂] : @OrientedOrd _ (ord₁.lex' ord₂) := inferInstanceAs (OrientedCmp (compareLex ord₁.compare ord₂.compare)) /-- Local instance for `TransOrd (oα.lex' oβ)`. -/ @[deprecated Std.TransOrd.instOrdLex' (since := "2025-07-01")] theorem TransOrd.instOrdLex' (ord₁ ord₂ : Ord α) [@TransOrd _ ord₁] [@TransOrd _ ord₂] : @TransOrd _ (ord₁.lex' ord₂) := inferInstanceAs (TransCmp (compareLex ord₁.compare ord₂.compare)) end «non-canonical instances» ================================================ FILE: Batteries/Classes/Order.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Tactic.Basic public import Batteries.Tactic.SeqFocus @[expose] public section theorem lexOrd_def [Ord α] [Ord β] : (lexOrd : Ord (α × β)).compare = compareLex (compareOn (·.1)) (compareOn (·.2)) := rfl /-- Pull back a comparator by a function `f`, by applying the comparator to both arguments. -/ @[inline] def Ordering.byKey (f : α → β) (cmp : β → β → Ordering) (a b : α) : Ordering := cmp (f a) (f b) namespace Batteries /-- `TotalBLE le` asserts that `le` has a total order, that is, `le a b ∨ le b a`. -/ class TotalBLE (le : α → α → Bool) : Prop where /-- `le` is total: either `le a b` or `le b a`. -/ total : le a b ∨ le b a theorem compareOfLessAndEq_eq_lt {x y : α} [LT α] [Decidable (x < y)] [DecidableEq α] : compareOfLessAndEq x y = .lt ↔ x < y := by simp [compareOfLessAndEq] split <;> simp end Batteries /-! Batteries features not in core Std -/ namespace Std open Batteries (compareOfLessAndEq_eq_lt) namespace OrientedCmp variable {cmp : α → α → Ordering} [OrientedCmp cmp] theorem le_iff_ge : cmp x y ≠ .gt ↔ cmp y x ≠ .lt := not_congr OrientedCmp.gt_iff_lt end OrientedCmp namespace TransCmp variable {cmp : α → α → Ordering} [TransCmp cmp] theorem le_trans : cmp x y ≠ .gt → cmp y z ≠ .gt → cmp x z ≠ .gt := by simp only [ne_eq, ← Ordering.isLE_iff_ne_gt]; exact isLE_trans theorem lt_of_lt_of_le : cmp x y = .lt → cmp y z ≠ .gt → cmp x z = .lt := by simp only [ne_eq, ← Ordering.isLE_iff_ne_gt]; exact lt_of_lt_of_isLE theorem lt_of_le_of_lt : cmp x y ≠ .gt → cmp y z = .lt → cmp x z = .lt := by simp only [ne_eq, ← Ordering.isLE_iff_ne_gt]; exact lt_of_isLE_of_lt theorem ge_trans : cmp x y ≠ .lt → cmp y z ≠ .lt → cmp x z ≠ .lt := by simp only [ne_eq, ← Ordering.isGE_iff_ne_lt]; exact isGE_trans theorem gt_of_gt_of_ge : cmp x y = .gt → cmp y z ≠ .lt → cmp x z = .gt := by simp only [ne_eq, ← Ordering.isGE_iff_ne_lt]; exact gt_of_gt_of_isGE theorem gt_of_ge_of_gt : cmp x y ≠ .lt → cmp y z = .gt → cmp x z = .gt := by simp only [ne_eq, ← Ordering.isGE_iff_ne_lt]; exact gt_of_isGE_of_gt end TransCmp /-- `LawfulLTCmp cmp` asserts that `cmp x y = .lt` and `x < y` coincide. -/ class LawfulLTCmp [LT α] (cmp : α → α → Ordering) : Prop extends OrientedCmp cmp where /-- `cmp x y = .lt` holds iff `x < y` is true. -/ eq_lt_iff_lt : cmp x y = .lt ↔ x < y theorem LawfulLTCmp.eq_gt_iff_gt [LT α] [LawfulLTCmp (α := α) cmp] : cmp x y = .gt ↔ y < x := by rw [OrientedCmp.gt_iff_lt, eq_lt_iff_lt] /-- `LawfulLECmp cmp` asserts that `(cmp x y).isLE` and `x ≤ y` coincide. -/ class LawfulLECmp [LE α] (cmp : α → α → Ordering) : Prop extends OrientedCmp cmp where /-- `cmp x y ≠ .gt` holds iff `x ≤ y` is true. -/ isLE_iff_le : (cmp x y).isLE ↔ x ≤ y theorem LawfulLECmp.isGE_iff_ge [LE α] [LawfulLECmp (α := α) cmp] : (cmp x y).isGE ↔ y ≤ x := by rw [← Ordering.isLE_swap, ← OrientedCmp.eq_swap, isLE_iff_le] theorem LawfulLECmp.ne_gt_iff_le [LE α] [LawfulLECmp (α := α) cmp] : cmp x y ≠ .gt ↔ x ≤ y := by rw [← isLE_iff_le (cmp := cmp), Ordering.isLE_iff_ne_gt] theorem LawfulLECmp.ne_lt_iff_ge [LE α] [LawfulLECmp (α := α) cmp] : cmp x y ≠ .lt ↔ y ≤ x := by rw [← isGE_iff_ge (cmp := cmp), Ordering.isGE_iff_ne_lt] /-- `LawfulBCmp cmp` asserts that the `LE`, `LT`, `BEq` are all coherent with each other and with `cmp`, describing a strict weak order (a linear order except for antisymmetry). -/ class LawfulBCmp [LE α] [LT α] [BEq α] (cmp : α → α → Ordering) : Prop extends TransCmp cmp, LawfulBEqCmp cmp, LawfulLTCmp cmp, LawfulLECmp cmp /-- `LawfulBCmp cmp` asserts that the `LE`, `LT`, `Eq` are all coherent with each other and with `cmp`, describing a linear order. -/ class LawfulCmp [LE α] [LT α] (cmp : α → α → Ordering) : Prop extends TransCmp cmp, LawfulEqCmp cmp, LawfulLTCmp cmp, LawfulLECmp cmp /-- Class for types where the ordering function is compatible with the `LT`. -/ abbrev LawfulLTOrd (α) [LT α] [Ord α] := LawfulLTCmp (α := α) compare /-- Class for types where the ordering function is compatible with the `LE`. -/ abbrev LawfulLEOrd (α) [LE α] [Ord α] := LawfulLECmp (α := α) compare /-- Class for types where the ordering function is compatible with the `LE`, `LT` and `BEq`. -/ abbrev LawfulBOrd (α) [LE α] [LT α] [BEq α] [Ord α] := LawfulBCmp (α := α) compare /-- Class for types where the ordering function is compatible with the `LE`, `LT` and `Eq`. -/ abbrev LawfulOrd (α) [LE α] [LT α] [Ord α] := LawfulCmp (α := α) compare instance [inst : Std.OrientedCmp cmp] : Std.OrientedCmp (flip cmp) where eq_swap := inst.eq_swap instance [inst : Std.TransCmp cmp] : Std.TransCmp (flip cmp) where isLE_trans h1 h2 := inst.isLE_trans h2 h1 instance (f : α → β) (cmp : β → β → Ordering) [Std.OrientedCmp cmp] : Std.OrientedCmp (Ordering.byKey f cmp) where eq_swap {a b} := Std.OrientedCmp.eq_swap (a := f a) (b := f b) instance (f : α → β) (cmp : β → β → Ordering) [Std.TransCmp cmp] : Std.TransCmp (Ordering.byKey f cmp) where isLE_trans h₁ h₂ := Std.TransCmp.isLE_trans (α := β) h₁ h₂ instance [inst₁ : OrientedCmp cmp₁] [inst₂ : OrientedCmp cmp₂] : OrientedCmp (compareLex cmp₁ cmp₂) := inferInstance instance [inst₁ : TransCmp cmp₁] [inst₂ : TransCmp cmp₂] : TransCmp (compareLex cmp₁ cmp₂) := inferInstance instance [Ord β] [OrientedOrd β] (f : α → β) : OrientedCmp (compareOn f) := inferInstance instance [Ord β] [TransOrd β] (f : α → β) : TransCmp (compareOn f) := inferInstance theorem OrientedOrd.instOn [ord : Ord β] [OrientedOrd β] (f : α → β) : @OrientedOrd _ (ord.on f) := inferInstanceAs (@OrientedCmp _ (compareOn f)) theorem TransOrd.instOn [ord : Ord β] [TransOrd β] (f : α → β) : @TransOrd _ (ord.on f) := inferInstanceAs (@TransCmp _ (compareOn f)) theorem OrientedOrd.instOrdLex' (ord₁ ord₂ : Ord α) [@OrientedOrd _ ord₁] [@OrientedOrd _ ord₂] : @OrientedOrd _ (ord₁.lex' ord₂) := inferInstanceAs (OrientedCmp (compareLex ord₁.compare ord₂.compare)) theorem TransOrd.instOrdLex' (ord₁ ord₂ : Ord α) [@TransOrd _ ord₁] [@TransOrd _ ord₂] : @TransOrd _ (ord₁.lex' ord₂) := inferInstanceAs (TransCmp (compareLex ord₁.compare ord₂.compare)) theorem LawfulLTCmp.eq_compareOfLessAndEq [LT α] [DecidableEq α] [LawfulEqCmp cmp] [LawfulLTCmp cmp] (x y : α) [Decidable (x < y)] : cmp x y = compareOfLessAndEq x y := by simp only [compareOfLessAndEq] split <;> rename_i h1 <;> [skip; split <;> rename_i h2] · exact LawfulLTCmp.eq_lt_iff_lt.2 h1 · exact LawfulEqCmp.compare_eq_iff_eq.2 h2 · cases e : cmp x y · cases h1 (LawfulLTCmp.eq_lt_iff_lt.1 e) · cases h2 (LawfulEqCmp.compare_eq_iff_eq.1 e) · rfl theorem ReflCmp.compareOfLessAndEq_of_lt_irrefl [LT α] [DecidableLT α] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬ x < x) : ReflCmp (α := α) (compareOfLessAndEq · ·) where compare_self {x} := by simp [compareOfLessAndEq, if_neg (lt_irrefl x)] theorem LawfulBEqCmp.compareOfLessAndEq_of_lt_irrefl [LT α] [DecidableLT α] [DecidableEq α] [BEq α] [LawfulBEq α] (lt_irrefl : ∀ x : α, ¬x < x) : LawfulBEqCmp (α := α) (compareOfLessAndEq · ·) where compare_eq_iff_beq {x y} := by simp [compareOfLessAndEq] split <;> [skip; split] <;> simp [*] rintro rfl; exact lt_irrefl _ ‹_› -- redundant? See `compareOfLessAndEq_of_lt_trans_of_lt_iff` in core theorem TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_antisymm [LT α] [DecidableLT α] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (lt_antisymm : ∀ {x y : α}, ¬x < y → ¬y < x → x = y) : TransCmp (α := α) (compareOfLessAndEq · ·) := TransOrd.compareOfLessAndEq_of_lt_trans_of_lt_iff lt_trans <| by intros constructor · intro h₁ constructor · intro h₂ apply lt_irrefl exact lt_trans h₁ h₂ · intro | rfl => exact lt_irrefl _ h₁ · intro ⟨h₁, h₂⟩ by_contra h₃ apply h₂ exact lt_antisymm h₃ h₁ -- redundant? See `compareOfLessAndEq_of_antisymm_of_trans_of_total_of_not_le` in core theorem TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm [LT α] [LE α] [DecidableLT α] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y → y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : TransCmp (α := α) (compareOfLessAndEq · ·) := .compareOfLessAndEq_of_irrefl_of_trans_of_antisymm lt_irrefl lt_trans fun xy yx => le_antisymm (not_lt yx) (not_lt xy) -- make redundant? theorem LawfulLTCmp.compareOfLessAndEq_of_irrefl_of_trans_of_antisymm [LT α] [DecidableLT α] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (lt_antisymm : ∀ {x y : α}, ¬x < y → ¬y < x → x = y) : LawfulLTCmp (α := α) (compareOfLessAndEq · ·) := { TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_antisymm lt_irrefl lt_trans lt_antisymm with eq_lt_iff_lt := Batteries.compareOfLessAndEq_eq_lt } -- make redundant? theorem LawfulLTCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm [LT α] [DecidableLT α] [DecidableEq α] [LE α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y → y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LawfulLTCmp (α := α) (compareOfLessAndEq · ·) := { TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm lt_irrefl lt_trans not_lt le_antisymm with eq_lt_iff_lt := Batteries.compareOfLessAndEq_eq_lt } -- make redundant? theorem LawfulLECmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm [LT α] [DecidableLT α] [DecidableEq α] [LE α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y ↔ y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LawfulLECmp (α := α) (compareOfLessAndEq · ·) := have := TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm lt_irrefl lt_trans not_lt.1 le_antisymm { this with isLE_iff_le := by intro x y simp only [Ordering.isLE_iff_ne_gt, ← not_lt] apply not_congr rw [this.gt_iff_lt, Batteries.compareOfLessAndEq_eq_lt] } theorem LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm [LT α] [LE α] [DecidableLT α] [DecidableLE α] [DecidableEq α] (lt_irrefl : ∀ x : α, ¬x < x) (lt_trans : ∀ {x y z : α}, x < y → y < z → x < z) (not_lt : ∀ {x y : α}, ¬x < y ↔ y ≤ x) (le_antisymm : ∀ {x y : α}, x ≤ y → y ≤ x → x = y) : LawfulCmp (α := α) (compareOfLessAndEq · ·) := have instT := TransCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm lt_irrefl lt_trans not_lt.1 le_antisymm have instLT := LawfulLTCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm lt_irrefl lt_trans not_lt.1 le_antisymm have instLE := LawfulLECmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm lt_irrefl lt_trans not_lt le_antisymm have le_refl (x : α) : x ≤ x := by rw [← not_lt]; exact lt_irrefl _ have not_le {x y : α} : ¬x ≤ y ↔ y < x := by simp [← not_lt] { instT, instLT, instLE with eq_of_compare {_ _}:= by rw [compareOfLessAndEq_eq_eq le_refl not_le]; exact id } instance : LawfulOrd Nat := LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm Nat.lt_irrefl Nat.lt_trans Nat.not_lt Nat.le_antisymm instance : LawfulOrd Int := LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm Int.lt_irrefl Int.lt_trans Int.not_lt Int.le_antisymm instance : LawfulOrd Bool := by apply LawfulCmp.mk <;> decide instance : LawfulOrd (Fin n) where eq_swap := OrientedCmp.eq_swap (α := Nat) (cmp := compare) .. eq_lt_iff_lt := LawfulLTCmp.eq_lt_iff_lt (α := Nat) (cmp := compare) isLE_iff_le := LawfulLECmp.isLE_iff_le (α := Nat) (cmp := compare) isLE_trans := TransCmp.isLE_trans (α := Nat) (cmp := compare) end Std ================================================ FILE: Batteries/Classes/RatCast.lean ================================================ /- Copyright (c) 2014 Robert Lewis. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Robert Lewis, Leonardo de Moura, Johannes Hölzl, Mario Carneiro, Gabriel Ebner -/ module @[expose] public section /-- Type class for the canonical homomorphism `Rat → K`. -/ class RatCast (K : Type u) where /-- The canonical homomorphism `Rat → K`. -/ protected ratCast : Rat → K instance : RatCast Rat where ratCast n := n /-- Canonical homomorphism from `Rat` to a division ring `K`. This is just the bare function in order to aid in creating instances of `DivisionRing`. -/ @[coe, reducible, match_pattern] protected def Rat.cast {K : Type u} [RatCast K] : Rat → K := RatCast.ratCast -- see note [coercion into rings] instance [RatCast K] : CoeTail Rat K where coe := Rat.cast -- see note [coercion into rings] instance [RatCast K] : CoeHTCT Rat K where coe := Rat.cast ================================================ FILE: Batteries/Classes/SatisfiesM.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Kim Morrison -/ module public import Batteries.Lean.EStateM public import Batteries.Lean.Except @[expose] public section /-! ## SatisfiesM The `SatisfiesM` predicate works over an arbitrary (lawful) monad / applicative / functor, and enables Hoare-like reasoning over monadic expressions. For example, given a monadic function `f : α → m β`, to say that the return value of `f` satisfies `Q` whenever the input satisfies `P`, we write `∀ a, P a → SatisfiesM Q (f a)`. For any monad equipped with `MonadSatisfying m` one can lift `SatisfiesM` to a monadic value in `Subtype`, using `satisfying x h : m {a // p a}`, where `x : m α` and `h : SatisfiesM p x`. This includes `Option`, `ReaderT`, `StateT`, and `ExceptT`, and the Lean monad stack. (Although it is not entirely clear one should treat the Lean monad stack as lawful, even though Lean accepts this.) ## Notes `SatisfiesM` is not yet a satisfactory solution for verifying the behaviour of large scale monadic programs. Such a solution would allow ergonomic reasoning about large `do` blocks, with convenient mechanisms for introducing invariants and loop conditions as needed. It is possible that in the future `SatiesfiesM` will become part of such a solution, presumably requiring more syntactic support (and smarter `do` blocks) from Lean. Or it may be that such a solution will look different! This is an open research program, and for now one should not be overly ambitious using `SatisfiesM`. In particular lemmas about pure operations on data structures in `Batteries` except for `HashMap` should avoid `SatisfiesM` for now, so that it is easy to migrate to other approaches in future. -/ /-- `SatisfiesM p (x : m α)` lifts propositions over a monad. It asserts that `x` may as well have the type `x : m {a // p a}`, because there exists some `m {a // p a}` whose image is `x`. So `p` is the postcondition of the monadic value. -/ def SatisfiesM {m : Type u → Type v} [Functor m] (p : α → Prop) (x : m α) : Prop := ∃ x' : m {a // p a}, Subtype.val <$> x' = x namespace SatisfiesM /-- If `p` is always true, then every `x` satisfies it. -/ theorem of_true [Functor m] [LawfulFunctor m] {x : m α} (h : ∀ a, p a) : SatisfiesM p x := ⟨(fun a => ⟨a, h a⟩) <$> x, by simp⟩ /-- If `p` is always true, then every `x` satisfies it. (This is the strongest postcondition version of `of_true`.) -/ protected theorem trivial [Functor m] [LawfulFunctor m] {x : m α} : SatisfiesM (fun _ => True) x := of_true fun _ => trivial /-- The `SatisfiesM p x` predicate is monotonic in `p`. -/ theorem imp [Functor m] [LawfulFunctor m] {x : m α} (h : SatisfiesM p x) (H : ∀ {a}, p a → q a) : SatisfiesM q x := let ⟨x, h⟩ := h; ⟨(fun ⟨_, h⟩ => ⟨_, H h⟩) <$> x, by rw [← h, ← comp_map]; rfl⟩ /-- `SatisfiesM` distributes over `<$>`, general version. -/ protected theorem map [Functor m] [LawfulFunctor m] {x : m α} (hx : SatisfiesM p x) (hf : ∀ {a}, p a → q (f a)) : SatisfiesM q (f <$> x) := by let ⟨x', hx⟩ := hx refine ⟨(fun ⟨a, h⟩ => ⟨f a, hf h⟩) <$> x', ?_⟩ rw [← hx]; simp /-- `SatisfiesM` distributes over `<$>`, strongest postcondition version. (Use this for reasoning forward from assumptions.) -/ theorem map_post [Functor m] [LawfulFunctor m] {x : m α} (hx : SatisfiesM p x) : SatisfiesM (fun b => ∃ a, p a ∧ b = f a) (f <$> x) := hx.map fun h => ⟨_, h, rfl⟩ /-- `SatisfiesM` distributes over `<$>`, weakest precondition version. (Use this for reasoning backward from the goal.) -/ theorem map_pre [Functor m] [LawfulFunctor m] {x : m α} (hx : SatisfiesM (fun a => p (f a)) x) : SatisfiesM p (f <$> x) := hx.map fun h => h /-- `SatisfiesM` distributes over `mapConst`, general version. -/ protected theorem mapConst [Functor m] [LawfulFunctor m] {x : m α} (hx : SatisfiesM q x) (ha : ∀ {b}, q b → p a) : SatisfiesM p (Functor.mapConst a x) := map_const (f := m) ▸ hx.map ha /-- `SatisfiesM` distributes over `pure`, general version / weakest precondition version. -/ protected theorem pure [Applicative m] [LawfulApplicative m] (h : p a) : SatisfiesM (m := m) p (pure a) := ⟨pure ⟨_, h⟩, by simp⟩ /-- `SatisfiesM` distributes over `<*>`, general version. -/ protected theorem seq [Applicative m] [LawfulApplicative m] {x : m α} (hf : SatisfiesM p₁ f) (hx : SatisfiesM p₂ x) (H : ∀ {f a}, p₁ f → p₂ a → q (f a)) : SatisfiesM q (f <*> x) := by match f, x, hf, hx with | _, _, ⟨f, rfl⟩, ⟨x, rfl⟩ => ?_ refine ⟨(fun ⟨a, h₁⟩ ⟨b, h₂⟩ => ⟨a b, H h₁ h₂⟩) <$> f <*> x, ?_⟩ simp only [← pure_seq]; simp [seq_assoc] simp only [← pure_seq]; simp [seq_assoc, Function.comp_def] /-- `SatisfiesM` distributes over `<*>`, strongest postcondition version. -/ protected theorem seq_post [Applicative m] [LawfulApplicative m] {x : m α} (hf : SatisfiesM p₁ f) (hx : SatisfiesM p₂ x) : SatisfiesM (fun c => ∃ f a, p₁ f ∧ p₂ a ∧ c = f a) (f <*> x) := hf.seq hx fun hf ha => ⟨_, _, hf, ha, rfl⟩ /-- `SatisfiesM` distributes over `<*>`, weakest precondition version 1. (Use this when `x` and the goal are known and `f` is a subgoal.) -/ protected theorem seq_pre [Applicative m] [LawfulApplicative m] {x : m α} (hf : SatisfiesM (fun f => ∀ {a}, p₂ a → q (f a)) f) (hx : SatisfiesM p₂ x) : SatisfiesM q (f <*> x) := hf.seq hx fun hf ha => hf ha /-- `SatisfiesM` distributes over `<*>`, weakest precondition version 2. (Use this when `f` and the goal are known and `x` is a subgoal.) -/ protected theorem seq_pre' [Applicative m] [LawfulApplicative m] {x : m α} (hf : SatisfiesM p₁ f) (hx : SatisfiesM (fun a => ∀ {f}, p₁ f → q (f a)) x) : SatisfiesM q (f <*> x) := hf.seq hx fun hf ha => ha hf /-- `SatisfiesM` distributes over `<*`, general version. -/ protected theorem seqLeft [Applicative m] [LawfulApplicative m] {x : m α} (hx : SatisfiesM p₁ x) (hy : SatisfiesM p₂ y) (H : ∀ {a b}, p₁ a → p₂ b → q a) : SatisfiesM q (x <* y) := seqLeft_eq x y ▸ (hx.map fun h _ => H h).seq_pre hy /-- `SatisfiesM` distributes over `*>`, general version. -/ protected theorem seqRight [Applicative m] [LawfulApplicative m] {x : m α} (hx : SatisfiesM p₁ x) (hy : SatisfiesM p₂ y) (H : ∀ {a b}, p₁ a → p₂ b → q b) : SatisfiesM q (x *> y) := seqRight_eq x y ▸ (hx.map fun h _ => H h).seq_pre hy /-- `SatisfiesM` distributes over `>>=`, general version. -/ protected theorem bind [Monad m] [LawfulMonad m] {f : α → m β} (hx : SatisfiesM p x) (hf : ∀ a, p a → SatisfiesM q (f a)) : SatisfiesM q (x >>= f) := by match x, hx with | _, ⟨x, rfl⟩ => ?_ have g a ha := Classical.indefiniteDescription _ (hf a ha) refine ⟨x >>= fun ⟨a, h⟩ => g a h, ?_⟩ simp [← bind_pure_comp]; congr; funext ⟨a, h⟩; simp [← (g a h).2, ← bind_pure_comp] /-- `SatisfiesM` distributes over `>>=`, weakest precondition version. -/ protected theorem bind_pre [Monad m] [LawfulMonad m] {f : α → m β} (hx : SatisfiesM (fun a => SatisfiesM q (f a)) x) : SatisfiesM q (x >>= f) := hx.bind fun _ h => h end SatisfiesM @[simp] theorem SatisfiesM_Id_eq : SatisfiesM (m := Id) p x ↔ p x := ⟨fun ⟨y, eq⟩ => eq ▸ y.2, fun h => ⟨⟨_, h⟩, rfl⟩⟩ @[simp] theorem SatisfiesM_Option_eq : SatisfiesM (m := Option) p x ↔ ∀ a, x = some a → p a := ⟨by revert x; intro | some _, ⟨some ⟨_, h⟩, rfl⟩, _, rfl => exact h, fun h => match x with | some a => ⟨some ⟨a, h _ rfl⟩, rfl⟩ | none => ⟨none, rfl⟩⟩ @[simp] theorem SatisfiesM_Except_eq : SatisfiesM (m := Except ε) p x ↔ ∀ a, x = .ok a → p a := ⟨by revert x; intro | .ok _, ⟨.ok ⟨_, h⟩, rfl⟩, _, rfl => exact h, fun h => match x with | .ok a => ⟨.ok ⟨a, h _ rfl⟩, rfl⟩ | .error e => ⟨.error e, rfl⟩⟩ theorem SatisfiesM_EStateM_eq : SatisfiesM (m := EStateM ε σ) p x ↔ ∀ s a s', x.run s = .ok a s' → p a := by constructor · rintro ⟨x, rfl⟩ s a s' h match w : x.run s with | .ok a s' => simp at h; exact h.1 | .error e s' => simp [w] at h · intro w refine ⟨?_, ?_⟩ · intro s match q : x.run s with | .ok a s' => exact .ok ⟨a, w s a s' q⟩ s' | .error e s' => exact .error e s' · ext s rw [EStateM.run_map, EStateM.run] split <;> simp_all theorem SatisfiesM_ReaderT_eq [Monad m] : SatisfiesM (m := ReaderT ρ m) p x ↔ ∀ s, SatisfiesM p (x.run s) := (exists_congr fun a => by exact ⟨fun eq _ => eq ▸ rfl, funext⟩).trans Classical.skolem.symm theorem SatisfiesM_StateRefT_eq [Monad m] : SatisfiesM (m := StateRefT' ω σ m) p x ↔ ∀ s, SatisfiesM p (x s) := SatisfiesM_ReaderT_eq theorem SatisfiesM_StateT_eq [Monad m] [LawfulMonad m] : SatisfiesM (m := StateT ρ m) (α := α) p x ↔ ∀ s, SatisfiesM (m := m) (p ·.1) (x.run s) := by change SatisfiesM (m := StateT ρ m) (α := α) p x ↔ ∀ s, SatisfiesM (m := m) (p ·.1) (x s) refine .trans ⟨fun ⟨f, eq⟩ => eq ▸ ?_, fun ⟨f, h⟩ => ?_⟩ Classical.skolem.symm · refine ⟨fun s => (fun ⟨⟨a, h⟩, s'⟩ => ⟨⟨a, s'⟩, h⟩) <$> f s, fun s => ?_⟩ rw [← comp_map, map_eq_pure_bind]; rfl · refine ⟨fun s => (fun ⟨⟨a, s'⟩, h⟩ => ⟨⟨a, h⟩, s'⟩) <$> f s, funext fun s => ?_⟩ show _ >>= _ = _; simp [← h] theorem SatisfiesM_ExceptT_eq [Monad m] [LawfulMonad m] : SatisfiesM (m := ExceptT ρ m) (α := α) p x ↔ SatisfiesM (m := m) (∀ a, · = .ok a → p a) x.run := by change _ ↔ SatisfiesM (m := m) (∀ a, · = .ok a → p a) x refine ⟨fun ⟨f, eq⟩ => eq ▸ ?_, fun ⟨f, eq⟩ => eq ▸ ?_⟩ · exists (fun | .ok ⟨a, h⟩ => ⟨.ok a, fun | _, rfl => h⟩ | .error e => ⟨.error e, nofun⟩) <$> f show _ = _ >>= _; rw [← comp_map, map_eq_pure_bind]; congr; funext a; cases a <;> rfl · exists ((fun | ⟨.ok a, h⟩ => .ok ⟨a, h _ rfl⟩ | ⟨.error e, _⟩ => .error e) <$> f : m _) show _ >>= _ = _; simp [← bind_pure_comp]; congr; funext ⟨a, h⟩; cases a <;> rfl /-- If a monad has `MonadSatisfying m`, then we can lift a `h : SatisfiesM (m := m) p x` predicate to monadic value `satisfying x p : m { x // p x }`. Reader, state, and exception monads have `MonadSatisfying` instances if the base monad does. -/ class MonadSatisfying (m : Type u → Type v) [Functor m] [LawfulFunctor m] where /-- Lift a `SatisfiesM` predicate to a monadic value. -/ satisfying {p : α → Prop} {x : m α} (h : SatisfiesM (m := m) p x) : m {a // p a} /-- The value of the lifted monadic value is equal to the original monadic value. -/ val_eq {p : α → Prop} {x : m α} (h : SatisfiesM (m := m) p x) : Subtype.val <$> satisfying h = x export MonadSatisfying (satisfying) namespace MonadSatisfying instance : MonadSatisfying Id where satisfying {α p x} h := ⟨x, by obtain ⟨⟨_, h⟩, rfl⟩ := h; exact h⟩ val_eq {α p x} h := rfl instance : MonadSatisfying Option where satisfying {α p x?} h := have h' := SatisfiesM_Option_eq.mp h match x? with | none => none | some x => some ⟨x, h' x rfl⟩ val_eq {α p x?} h := by cases x? <;> simp instance : MonadSatisfying (Except ε) where satisfying {α p x?} h := have h' := SatisfiesM_Except_eq.mp h match x? with | .ok x => .ok ⟨x, h' x rfl⟩ | .error e => .error e val_eq {α p x?} h := by cases x? <;> simp instance [Monad m] [LawfulMonad m][MonadSatisfying m] : MonadSatisfying (ReaderT ρ m) where satisfying {α p x} h := have h' := SatisfiesM_ReaderT_eq.mp h fun r => satisfying (h' r) val_eq {α p x} h := by have h' := SatisfiesM_ReaderT_eq.mp h ext r rw [ReaderT.run_map, ← MonadSatisfying.val_eq (h' r)] rfl instance [Monad m] [LawfulMonad m] [MonadSatisfying m] : MonadSatisfying (StateRefT' ω σ m) := inferInstanceAs <| MonadSatisfying (ReaderT (ST.Ref ω σ) m) instance [Monad m] [LawfulMonad m] [MonadSatisfying m] : MonadSatisfying (StateT ρ m) where satisfying {α p x} h := have h' := SatisfiesM_StateT_eq.mp h fun r => (fun ⟨⟨a, r'⟩, h⟩ => ⟨⟨a, h⟩, r'⟩) <$> satisfying (h' r) val_eq {α p x} h := by have h' := SatisfiesM_StateT_eq.mp h ext r rw [← MonadSatisfying.val_eq (h' r), StateT.run_map] simp [StateT.run] instance [Monad m] [LawfulMonad m] [MonadSatisfying m] : MonadSatisfying (ExceptT ε m) where satisfying {α p x} h := let x' := satisfying (SatisfiesM_ExceptT_eq.mp h) ExceptT.mk ((fun ⟨y, w⟩ => y.pmap fun a h => ⟨a, w _ h⟩) <$> x') val_eq {α p x} h := by ext refine Eq.trans ?_ (MonadSatisfying.val_eq (SatisfiesM_ExceptT_eq.mp h)) simp instance : MonadSatisfying (EStateM ε σ) where satisfying {α p x} h := have h' := SatisfiesM_EStateM_eq.mp h fun s => match w : x.run s with | .ok a s' => .ok ⟨a, h' s a s' w⟩ s' | .error e s' => .error e s' val_eq {α p x} h := by ext s rw [EStateM.run_map, EStateM.run] split <;> simp_all end MonadSatisfying ================================================ FILE: Batteries/CodeAction/Attr.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Lean.Server.CodeActions.Basic public import Lean.Compiler.IR.CompilerM @[expose] public section /-! # Initial setup for code action attributes * `@[hole_code_action]` and `@[command_code_action]` now live in the Lean repository, and are builtin. * Attribute `@[tactic_code_action]` collects code actions which will be called on each occurrence of a tactic. -/ namespace Batteries.CodeAction open Lean Elab Server Lsp RequestM Snapshots /-- A tactic code action extension. -/ abbrev TacticCodeAction := CodeActionParams → Snapshot → (ctx : ContextInfo) → (stack : Syntax.Stack) → (node : InfoTree) → RequestM (Array LazyCodeAction) /-- A tactic code action extension. -/ abbrev TacticSeqCodeAction := CodeActionParams → Snapshot → (ctx : ContextInfo) → (i : Nat) → (stack : Syntax.Stack) → (goals : List MVarId) → RequestM (Array LazyCodeAction) /-- Read a tactic code action from a declaration of the right type. -/ def mkTacticCodeAction (n : Name) : ImportM TacticCodeAction := do let { env, opts, .. } ← read IO.ofExcept <| unsafe env.evalConstCheck TacticCodeAction opts ``TacticCodeAction n /-- Read a tacticSeq code action from a declaration of the right type. -/ def mkTacticSeqCodeAction (n : Name) : ImportM TacticSeqCodeAction := do let { env, opts, .. } ← read IO.ofExcept <| unsafe env.evalConstCheck TacticSeqCodeAction opts ``TacticSeqCodeAction n /-- An entry in the tactic code actions extension, containing the attribute arguments. -/ structure TacticCodeActionEntry where /-- The declaration to tag -/ declName : Name /-- The tactic kinds that this extension supports. If empty it is called on all tactic kinds. -/ tacticKinds : Array Name deriving Inhabited /-- The state of the tactic code actions extension. -/ structure TacticCodeActions where /-- The list of tactic code actions to apply on any tactic. -/ onAnyTactic : Array TacticCodeAction := {} /-- The list of tactic code actions to apply when a particular tactic kind is highlighted. -/ onTactic : NameMap (Array TacticCodeAction) := {} deriving Inhabited /-- Insert a tactic code action entry into the `TacticCodeActions` structure. -/ def TacticCodeActions.insert (self : TacticCodeActions) (tacticKinds : Array Name) (action : TacticCodeAction) : TacticCodeActions := if tacticKinds.isEmpty then { self with onAnyTactic := self.onAnyTactic.push action } else { self with onTactic := tacticKinds.foldl (init := self.onTactic) fun m a => m.insert a ((m.getD a #[]).push action) } /-- An extension which collects all the tactic code actions. -/ initialize tacticSeqCodeActionExt : PersistentEnvExtension Name (Name × TacticSeqCodeAction) (Array Name × Array TacticSeqCodeAction) ← registerPersistentEnvExtension { mkInitial := pure (#[], #[]) addImportedFn := fun as => return (#[], ← as.foldlM (init := #[]) fun m as => as.foldlM (init := m) fun m a => return m.push (← mkTacticSeqCodeAction a)) addEntryFn := fun (s₁, s₂) (n₁, n₂) => (s₁.push n₁, s₂.push n₂) exportEntriesFn := (·.1) } /-- An extension which collects all the tactic code actions. -/ initialize tacticCodeActionExt : PersistentEnvExtension TacticCodeActionEntry (TacticCodeActionEntry × TacticCodeAction) (Array TacticCodeActionEntry × TacticCodeActions) ← registerPersistentEnvExtension { mkInitial := pure (#[], {}) addImportedFn := fun as => return (#[], ← as.foldlM (init := {}) fun m as => as.foldlM (init := m) fun m ⟨name, kinds⟩ => return m.insert kinds (← mkTacticCodeAction name)) addEntryFn := fun (s₁, s₂) (e, n₂) => (s₁.push e, s₂.insert e.tacticKinds n₂) exportEntriesFn := (·.1) } /-- This attribute marks a code action, which is used to suggest new tactics or replace existing ones. * `@[tactic_code_action]`: This is a code action which applies to the spaces between tactics, to suggest a new tactic to change the goal state. * `@[tactic_code_action kind]`: This is a code action which applies to applications of the tactic `kind` (a tactic syntax kind), which can replace the tactic or insert things before or after it. * `@[tactic_code_action kind₁ kind₂]`: shorthand for `@[tactic_code_action kind₁, tactic_code_action kind₂]`. * `@[tactic_code_action *]`: This is a tactic code action that applies to all tactics. Use sparingly. -/ syntax (name := tactic_code_action) "tactic_code_action" ("*" <|> (ppSpace ident)*) : attr initialize registerBuiltinAttribute { name := `tactic_code_action descr := "Declare a new tactic code action, to appear in the code actions on tactics" applicationTime := .afterCompilation add := fun decl stx kind => do unless kind == AttributeKind.global do throwError "invalid attribute 'tactic_code_action', must be global" match stx with | `(attr| tactic_code_action *) => if (IR.getSorryDep (← getEnv) decl).isSome then return -- ignore in progress definitions modifyEnv (tacticCodeActionExt.addEntry · (⟨decl, #[]⟩, ← mkTacticCodeAction decl)) | `(attr| tactic_code_action $[$args]*) => if args.isEmpty then if (IR.getSorryDep (← getEnv) decl).isSome then return -- ignore in progress definitions modifyEnv (tacticSeqCodeActionExt.addEntry · (decl, ← mkTacticSeqCodeAction decl)) else let args ← args.mapM realizeGlobalConstNoOverloadWithInfo if (IR.getSorryDep (← getEnv) decl).isSome then return -- ignore in progress definitions modifyEnv (tacticCodeActionExt.addEntry · (⟨decl, args⟩, ← mkTacticCodeAction decl)) | _ => pure () } ================================================ FILE: Batteries/CodeAction/Basic.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.BuiltinTerm public meta import Lean.Elab.BuiltinNotation public meta import Lean.Server.InfoUtils public meta import Lean.Server.CodeActions.Provider public meta import Batteries.CodeAction.Attr public meta section /-! # Initial setup for code actions This declares a code action provider that calls all `@[hole_code_action]` definitions on each occurrence of a hole (`_`, `?_` or `sorry`). (This is in a separate file from `Batteries.CodeAction.Hole.Attr` so that the server does not attempt to use this code action provider when browsing the `Batteries.CodeAction.Hole.Attr` file itself.) -/ namespace Batteries.CodeAction open Lean Elab Server RequestM CodeAction /-- A code action which calls `@[tactic_code_action]` code actions. -/ @[code_action_provider] def tacticCodeActionProvider : CodeActionProvider := fun params snap => do let doc ← readDoc let startPos := doc.meta.text.lspPosToUtf8Pos params.range.start let endPos := doc.meta.text.lspPosToUtf8Pos params.range.end let pointerCol := if params.range.start.line == params.range.end.line then max params.range.start.character params.range.end.character else 0 let some result := findTactic? (fun pos => (doc.meta.text.utf8PosToLspPos pos).character ≤ pointerCol) ⟨startPos, endPos⟩ snap.stx | return #[] let tgtTac := match result with | .tactic (tac :: _) | .tacticSeq _ _ (_ :: tac :: _) => tac.1 | _ => unreachable! let tgtRange := tgtTac.getRange?.get! have info := findInfoTree? tgtTac.getKind tgtRange none snap.infoTree (canonicalOnly := true) fun _ info => info matches .ofTacticInfo _ let some (ctx, node@(.node (.ofTacticInfo info) _)) := info | return #[] let mut out := #[] match result with | .tactic stk@((tac, _) :: _) => do let ctx := { ctx with mctx := info.mctxBefore } let actions := (tacticCodeActionExt.getState snap.env).2 if let some arr := actions.onTactic.find? tac.getKind then for act in arr do try out := out ++ (← act params snap ctx stk node) catch _ => pure () for act in actions.onAnyTactic do try out := out ++ (← act params snap ctx stk node) catch _ => pure () | .tacticSeq _ i stk@((seq, _) :: _) => let (ctx, goals) ← if 2*i < seq.getNumArgs then let stx := seq[2*i] let some stxRange := stx.getRange? | return #[] let some (ctx, .node (.ofTacticInfo info') _) := findInfoTree? stx.getKind stxRange ctx node fun _ info => (info matches .ofTacticInfo _) | return #[] pure ({ ctx with mctx := info'.mctxBefore }, info'.goalsBefore) else pure ({ ctx with mctx := info.mctxAfter }, info.goalsAfter) for act in (tacticSeqCodeActionExt.getState snap.env).2 do try out := out ++ (← act params snap ctx i stk goals) catch _ => pure () | _ => unreachable! pure out ================================================ FILE: Batteries/CodeAction/Deprecated.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Server.CodeActions.Provider public meta section /-! # Code action for @[deprecated] replacements This is an opt-in mechanism for making machine-applicable `@[deprecated]` definitions. When enabled (by setting the `machineApplicableDeprecated` tag attribute), a code action will be triggered whenever the deprecation lint also fires, allowing the user to replace the usage of the deprecated constant. -/ namespace Batteries open Lean Elab Server Lsp RequestM CodeAction /-- An environment extension for identifying `@[deprecated]` definitions which can be auto-fixed -/ initialize machineApplicableDeprecated : TagDeclarationExtension ← mkTagDeclarationExtension namespace CodeAction /-- A code action which applies replacements for `@[deprecated]` definitions. -/ @[code_action_provider] def deprecatedCodeActionProvider : CodeActionProvider := fun params snap => do let mut i := 0 let doc ← readDoc let mut msgs := #[] for m in snap.msgLog.toList do if m.data.isDeprecationWarning then if h : _ then msgs := msgs.push (snap.cmdState.messages.toList[i]'h) i := i + 1 if msgs.isEmpty then return #[] let start := doc.meta.text.lspPosToUtf8Pos params.range.start let stop := doc.meta.text.lspPosToUtf8Pos params.range.end for msg in msgs do let some endPos := msg.endPos | continue let pos := doc.meta.text.ofPosition msg.pos let endPos' := doc.meta.text.ofPosition endPos unless start ≤ endPos' && pos ≤ stop do continue let some (ctx, .node (.ofTermInfo info@{ expr := .const c .., ..}) _) := findInfoTree? identKind ⟨pos, endPos'⟩ none snap.infoTree fun _ i => (i matches .ofTermInfo { elaborator := .anonymous, expr := .const .., ..}) | continue unless machineApplicableDeprecated.isTagged snap.cmdState.env c do continue let some c' := Linter.getDeprecatedNewName snap.cmdState.env c | continue let eager : CodeAction := { title := s!"Replace {c} with {c'}" kind? := "quickfix" isPreferred? := true } return #[{ eager lazy? := some do let c' ← info.runMetaM ctx (unresolveNameGlobal c') let pos := doc.meta.text.leanPosToLspPos msg.pos let endPos' := doc.meta.text.leanPosToLspPos endPos pure { eager with edit? := some <| .ofTextEdit doc.versionedIdentifier { range := ⟨pos, endPos'⟩ newText := toString c' } } }] return #[] ================================================ FILE: Batteries/CodeAction/Match.lean ================================================ /- Copyright (c) 2026 Moritz Roos. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Moritz Roos -/ module public meta import Batteries.CodeAction.Misc public meta import Batteries.Data.List.Basic @[expose] public meta section namespace Batteries.CodeAction open Lean Meta Elab Server RequestM CodeAction /-- Filter for the info-nodes to find the match-nodes. -/ def isMatchTerm : Info → Bool | .ofTermInfo i => i.stx.isOfKind ``Lean.Parser.Term.match | _ => false /-- Returns the String.range that encompasses `match e (with)`. -/ def getMatchHeaderRange? (matchStx : Syntax) : Option Lean.Syntax.Range := do match matchStx with | `(term| match $[(generalizing := $generalizingVal)]? $[(motive := $motiveVal)]? $[$discrs:matchDiscr],* with $_) => --Here the $alts would go, if they were already typed. Else $_ will match "missing" -- Isolate the syntax of only the "match" atom to get the starting position: let mStx ← matchStx.getArgs.find? (fun s => s.isAtom && s.getAtomVal == "match") let startPos ← mStx.getPos? -- begin of 'match' keyword -- Depending on the existence of 'with', return the correct range: if let some withStx := (matchStx.getArgs.find? (fun s => s.isAtom && s.getAtomVal == "with")) then return ⟨startPos, ←withStx.getTailPos?⟩ else let lastMatchDiscr ← discrs.back? return ⟨startPos, ←lastMatchDiscr.raw.getTailPos?⟩ | _ => none /-- Flattens an Infotree into an array of Info-nodes that fulfill p. -/ partial def findAllInfos (p : Info → Bool) (t : InfoTree) : Array Info := loop t #[] where /-- Inner loop for `findAllInfos`. -/ loop (t : InfoTree) (acc : Array Info) : Array Info := match t with | .context _ childTree => loop childTree acc | .node info children => let acc' := if p info then acc.push info else acc children.foldl (fun currentAcc child => loop child currentAcc) acc' | .hole _ => acc /-- Computes for a constructor, if it makes sense to use `@constr` in a match, by determining if it has any non-parameter implicit arguments. -/ def hasImplicitNonparArg (ctor : Name) (env : Environment) : Bool := Id.run do let some (.ctorInfo ctorInfo) := env.find? ctor | panic! "bad inductive" let explicitArgs := getExplicitArgs ctorInfo.type #[] let allArgs := getAllArgs ctorInfo.type #[] let some (.inductInfo indInfo) := env.find? ctorInfo.induct | panic! "not an inductive" let numParams := indInfo.numParams return (allArgs.size - (explicitArgs.size + numParams) > 0) /-- From a constructor-name e.g. `Option.some` construct the corresponding match pattern, e.g. `.some val`. We implement special cases for `Nat` and `List`, `Option` and `Bool` to e.g. produce `n + 1` instead of `Nat.succ n`. -/ def patternFromConstructor (ctor : Name) (env : Environment) (suffix : String) (explicitArgsOnly : Bool) (ctor_hasImplicitNonparArg : Bool): Option String := do let some (.ctorInfo ctorInfo) := env.find? ctor | panic! "bad inductive" let some (.inductInfo indInfo) := env.find? ctorInfo.induct | panic! "not an inductive" let numParams := indInfo.numParams let ctor_short := toString (ctor.updatePrefix .anonymous) let explicitCtorArgs := getExplicitArgs ctorInfo.type #[] let allCtorArgs := getAllArgs ctorInfo.type #[] /- Special cases with nicer Notation. None of these constructors has any implicit arguments that aren't parameters, i.e. that aren't already determined by the match discriminant. So it doesn't make sense to use them with `@`. That's why we *always* nicely print them regardless of the setting `explicitArgsOnly`. -/ match ctor with | (.str (.str .anonymous "Nat") "zero") => "0" /- At the moment this evaluates to "n + 1": -/ | (.str (.str .anonymous "Nat") "succ") => s!"{explicitCtorArgs[0]!}{suffix} + 1" -- | (.str (.str .anonymous "List") "nil") => "[]" /- At the moment this evaluates to "head :: tail": -/ | (.str (.str .anonymous "List") "cons") => s!"{explicitCtorArgs[0]!}{suffix} :: {explicitCtorArgs[1]!}{suffix}" | (.str (.str .anonymous "Option") "some") => s!"some {explicitCtorArgs[0]!}{suffix}" | (.str (.str .anonymous "Option") "none") => "none" | (.str (.str .anonymous "Bool") "true") => "true" | (.str (.str .anonymous "Bool") "false") => "false" | _ => /- This is the Default case. It fills the constructor arguments with the variable names `arg` which were used in the inductive type specification. When using this action with multiple (same-type) arguments these might clash, so we fix it by appending a suffix like `_2` - you will probably want to rename these suffixed names yourself. If the the user wants the match to contain the implicit arguments as well, we additionally put `_` for every `parameter` (a parameter is an argument to the inductive type that is fixed over constructors), since these should already be determined by the match discriminant. One could elaborate the type of this discriminant and fill the parameters from there, but we don't see any value in this. -/ if explicitArgsOnly || Bool.not ctor_hasImplicitNonparArg then let mut str := s!".{ctor_short}" for arg in explicitCtorArgs do str := str ++ if arg.hasNum || arg.isInternal then " _" else s!" {arg}{suffix}" return str else let mut str := s!".{ctor_short}" /- This loop skips the first `numParams` many arguments, since these are the parameters and are already determined by the match discriminant and thus unlikely to be useful for the match. -/ for i in [numParams:allCtorArgs.size] do let arg := allCtorArgs[i]! str := str ++ if arg.hasNum || arg.isInternal then " _" else if arg ∈ explicitCtorArgs then s!" {arg}{suffix}" else s!" ({arg} := {arg}{suffix})" return str /-- Invoking tactic code action `Generate a list of alternatives for this match.` in the following: ```lean def myfun2 (n : Nat) : Nat := match n ``` produces: ```lean def myfun2 (n : Nat) : Nat := match n with | 0 => _ | n + 1 => _ ``` Also has support for multiple discriminants, e.g. ``` def myfun3 (o : Option Bool) (m : Nat) : Nat := match o, m with ``` can be expanded into ``` def myfun3 (o : Option Bool) (m : Nat) : Nat := match o, m with | none, 0 => _ | none, n_2 + 1 => _ | some val_1, 0 => _ | some val_1, n_2 + 1 => _ ``` If it makes sense to use at least one of the constructors with `@` (i.e. iff it has an implicit non-parameter argument) then we also show a codeaction that expands every such constructor with implicit arguments filled in with the syntax `implicitArg := implicitArg`. E.g. invoking `Generate a list of equations with implicit arguments for this match.` in the following ```lean inductive TermWithImplicit (F : Nat → Type u) (α : Type w) | var (x : α) : TermWithImplicit F α | func {l : Nat} (f : F l) (ts : Fin l → TermWithImplicit F α) : TermWithImplicit F α def myfun4 (t : TermWithImplicit F α) : Nat := by match t with ``` produces ```lean def myfun4 (t : TermWithImplicit F α) : Nat := by match t with | .var x => _ | .func (l := l) f ts => _ ``` where the implicit argument `{l : Nat}` is now usable. Note that the arguments `F` and `α` are not filled since they are `parameters` (a parameter is an argument to an inductive type that is fixed over constructors), i.e. they are already determined by the match discriminant `t`. This means they don't provide any new information for you. -/ @[command_code_action] def matchExpand : CommandCodeAction := fun CodeActionParams snap ctx node => do /- Since `match` is a term (not a command) `@[command_code_action Parser.Term.match]` will not fire. So we filter `command_code_action` ourselves in Step 1 for now. -/ /- 1. Find ALL ofTermInfo Info nodes that are of kind `Term.match` -/ let allMatchInfos := findAllInfos isMatchTerm node /- 2. Filter these candidates within the `RequestM` monad based on the cursor being in the header lines of these matches. -/ let doc ← readDoc let relevantMatchInfos ← allMatchInfos.filterM fun matchInfo => do let some headerRangeRaw := getMatchHeaderRange? matchInfo.stx | return false let headerRangeLsp := doc.meta.text.utf8RangeToLspRange headerRangeRaw let cursorRangeLsp := CodeActionParams.range -- check if the cursor range is contained in the header range return (cursorRangeLsp.start ≥ headerRangeLsp.start && cursorRangeLsp.end ≤ headerRangeLsp.end) /- 3. Pick the first (and mostly only) candidate. There might sometimes be more, since some things are just contained multiple times in 'node'. -/ let some matchInfo := relevantMatchInfos[0]? | return #[] let some headerRangeRaw := getMatchHeaderRange? matchInfo.stx | return #[] /- Isolate the array of match-discriminants -/ let discrs ← match matchInfo.stx with | `(term| match $[(generalizing := $generalizingVal)]? $[(motive := $motiveVal)]? $[$discrs:matchDiscr],* with $_) => pure discrs | _ => return #[] /- Reduce discrs to the array of match-discriminants-terms (i.e. "[n1, n2]" in "match n2,n2"). -/ let some discrTerms := discrs.mapM (fun discr => match discr with | `(matchDiscr| $t: term) => some t | `(matchDiscr| $_:ident : $t: term) => some t | _ => none ) | return #[] -- Get a Bool, that tells us if "with" is already typed in: let withPresent := (matchInfo.stx.getArgs.find? (fun s => s.isAtom && s.getAtomVal == "with")).isSome /- Construct a list containing for each discriminant its list of constructor names paired with a Bool that determines if it makes sense to use the constructor with `@`. The list contains the first discriminant constructors last, since we are prepending in the loop. -/ let mut constructors_rev : List (List (Name × Bool)) := [] for discrTerm in discrTerms do let some (info, updatedCtx) := findTermInfoWithCtx? node discrTerm ctx | return #[] let ty ← info.runMetaM updatedCtx (Lean.Meta.inferType info.expr) let .const name _ := (← info.runMetaM updatedCtx (whnf ty)).getAppFn | return #[] -- Find the inductive constructors of e: let some (.inductInfo indInfo) := snap.env.find? name | return #[] let ctors := indInfo.ctors constructors_rev := (ctors.map (fun ctor => (ctor, hasImplicitNonparArg ctor snap.env))) :: constructors_rev let mkAction (title : String) (explicitArgsOnly : Bool) : LazyCodeAction := let eager : Lsp.CodeAction := { title := title kind? := "quickfix" } { --rest is lightly adapted from eqnStub: eager lazy? := some do let holePos := headerRangeRaw.stop --where we start inserting let (indent, _) := findIndentAndIsStart doc.meta.text.source headerRangeRaw.start let mut str := if withPresent then "" else " with" let indent := "\n".pushn ' ' (indent) --use the same indent as the 'match' line. let constructor_combinations := constructors_rev.sections.map List.reverse for l in constructor_combinations do str := str ++ indent ++ "| " for ctor_idx in [:l.length] do let (ctor, existsExplicitNonparArg) := l[ctor_idx]! let suffix := if constructors_rev.length ≥ 2 then s!"_{ctor_idx + 1}" else "" let some pat := patternFromConstructor ctor snap.env suffix explicitArgsOnly existsExplicitNonparArg | panic! "bad inductive" str := str ++ pat if ctor_idx < l.length - 1 then str := str ++ ", " str := str ++ s!" => _" pure { eager with edit? := some <|.ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange ⟨holePos, holePos⟩-- adapted to insert-only newText := str } } } /- Show the code action with implicit arguments if at least one constructor has an implicit non-parameter argument. -/ let showExplicitCodeAction := constructors_rev.any (fun l => l.any (fun (_, ctor_hasImplicitNonparArg) => ctor_hasImplicitNonparArg)) if (showExplicitCodeAction) then return #[mkAction "Generate a list of equations for this match." True, mkAction "Generate a list of equations with implicit arguments for this match." False] else return #[mkAction "Generate a list of equations for this match." True] ================================================ FILE: Batteries/CodeAction/Misc.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Tactic.Induction public meta import Batteries.Lean.Position public meta import Batteries.CodeAction.Attr public meta import Lean.Server.CodeActions.Provider public meta section /-! # Miscellaneous code actions This declares some basic tactic code actions, using the `@[tactic_code_action]` API. -/ namespace Batteries.CodeAction open Lean Meta Elab Server RequestM CodeAction /-- Return the syntax stack leading to `target` from `root`, if one exists. -/ def findStack? (root target : Syntax) : Option Syntax.Stack := do let range ← target.getRange? root.findStack? (·.getRange?.any (·.includes range)) (fun s => s.getKind == target.getKind && s.getRange? == range) /-- Constructs a hole with a kind matching the provided hole elaborator. -/ def holeKindToHoleString : (elaborator : Name) → (synthName : String) → String | ``Elab.Term.elabSyntheticHole, name => "?" ++ name | ``Elab.Term.elabSorry, _ => "sorry" | _, _ => "_" /-- Hole code action used to fill in a structure's field when specifying an instance. In the following: ```lean instance : Monad Id := _ ``` invoking the hole code action "Generate a (minimal) skeleton for the structure under construction." produces: ```lean instance : Monad Id where pure := _ bind := _ ``` and invoking "Generate a (maximal) skeleton for the structure under construction." produces: ```lean instance : Monad Id where map := _ mapConst := _ pure := _ seq := _ seqLeft := _ seqRight := _ bind := _ ``` -/ @[hole_code_action] partial def instanceStub : HoleCodeAction := fun _ snap ctx info => do let some ty := info.expectedType? | return #[] let .const name _ := (← info.runMetaM ctx (whnf ty)).getAppFn | return #[] unless isStructure snap.env name do return #[] let doc ← readDoc let fields := collectFields snap.env name #[] [] let only := !fields.any fun (_, auto) => auto let mkAutofix minimal := let eager := { title := s!"\ Generate a {if only then "" else if minimal then "(minimal) " else "(maximal) "}\ skeleton for the structure under construction." kind? := "quickfix" isPreferred? := minimal } let lazy? := some do let useWhere := do let _ :: (stx, _) :: _ ← findStack? snap.stx info.stx | none guard (stx.getKind == ``Parser.Command.declValSimple) stx[0].getPos? let holePos := useWhere.getD info.stx.getPos?.get! let (indent, isStart) := findIndentAndIsStart doc.meta.text.source holePos let indent := "\n".pushn ' ' indent let mut str := if useWhere.isSome then "where" else "{" let mut first := useWhere.isNone && isStart for (field, auto) in fields do if minimal && auto then continue if first then str := str ++ " " first := false else str := str ++ indent ++ " " let field := toString field str := str ++ s!"{field} := {holeKindToHoleString info.elaborator field}" if useWhere.isNone then if isStart then str := str ++ " }" else str := str ++ indent ++ "}" pure { eager with edit? := some <| .ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange ⟨holePos, info.stx.getTailPos?.get!⟩ newText := str } } { eager, lazy? } pure <| if only then #[mkAutofix true] else #[mkAutofix true, mkAutofix false] where /-- Returns true if this field is an autoParam or optParam, or if it is given an optional value in a child struct. -/ isAutofillable (env : Environment) (fieldInfo : StructureFieldInfo) (stack : List Name) : Bool := fieldInfo.autoParam?.isSome || env.contains (mkDefaultFnOfProjFn fieldInfo.projFn) || stack.any fun struct => env.contains (mkDefaultFnOfProjFn (struct ++ fieldInfo.fieldName)) /-- Returns the fields of a structure, unfolding parent structures. -/ collectFields (env : Environment) (structName : Name) (fields : Array (Name × Bool)) (stack : List Name) : Array (Name × Bool) := (getStructureFields env structName).foldl (init := fields) fun fields field => if let some fieldInfo := getFieldInfo? env structName field then if let some substructName := fieldInfo.subobject? then collectFields env substructName fields (structName :: stack) else fields.push (field, isAutofillable env fieldInfo stack) else fields /-- Returns the explicit arguments given a type. The second argument of this function is an accumulator. -/ def getExplicitArgs : Expr → Array Name → Array Name | .forallE n _ body bi, args => getExplicitArgs body <| if bi.isExplicit then args.push n else args | _, args => args /-- Returns all of the arguments given a type. The second argument of this function is an accumulator. -/ def getAllArgs : Expr → Array Name → Array Name | .forallE n _ body _, args => getAllArgs body <| args.push n | _, args => args /-- Invoking hole code action "Generate a list of equations for a recursive definition" in the following: ```lean def foo : Expr → Unit := _ ``` produces: ```lean def foo : Expr → Unit := fun | .bvar deBruijnIndex => _ | .fvar fvarId => _ | .mvar mvarId => _ | .sort u => _ | .const declName us => _ | .app fn arg => _ | .lam binderName binderType body binderInfo => _ | .forallE binderName binderType body binderInfo => _ | .letE declName type value body nonDep => _ | .lit _ => _ | .mdata data expr => _ | .proj typeName idx struct => _ ``` -/ @[hole_code_action] def eqnStub : HoleCodeAction := fun _ snap ctx info => do let some ty := info.expectedType? | return #[] let .forallE _ dom .. ← info.runMetaM ctx (whnf ty) | return #[] let .const name _ := (← info.runMetaM ctx (whnf dom)).getAppFn | return #[] let some (.inductInfo val) := snap.env.find? name | return #[] let eager := { title := "Generate a list of equations for a recursive definition." kind? := "quickfix" } let doc ← readDoc pure #[{ eager lazy? := some do let holePos := info.stx.getPos?.get! let (indent, isStart) := findIndentAndIsStart doc.meta.text.source holePos let mut str := "fun" let indent := "\n".pushn ' ' (if isStart then indent else indent + 2) for ctor in val.ctors do let some (.ctorInfo ci) := snap.env.find? ctor | panic! "bad inductive" let ctor := toString (ctor.updatePrefix .anonymous) str := str ++ indent ++ s!"| .{ctor}" for arg in getExplicitArgs ci.type #[] do str := str ++ if arg.hasNum || arg.isInternal then " _" else s!" {arg}" str := str ++ s!" => {holeKindToHoleString info.elaborator ctor}" pure { eager with edit? := some <|.ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange ⟨holePos, info.stx.getTailPos?.get!⟩ newText := str } } }] /-- Invoking hole code action "Start a tactic proof" will fill in a hole with `by done`. -/ @[hole_code_action] def startTacticStub : HoleCodeAction := fun _ _ _ info => do let holePos := info.stx.getPos?.get! let doc ← readDoc let indent := (findIndentAndIsStart doc.meta.text.source holePos).1 pure #[{ eager.title := "Start a tactic proof." eager.kind? := "quickfix" eager.edit? := some <|.ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange ⟨holePos, info.stx.getTailPos?.get!⟩ newText := "by\n".pushn ' ' (indent + 2) ++ "done" } }] /-- The "Remove tactics after 'no goals'" code action deletes any tactics following a completed proof. ``` example : True := by trivial trivial -- <- remove this, proof is already done rfl ``` is transformed to ``` example : True := by trivial ``` -/ @[tactic_code_action*] def removeAfterDoneAction : TacticCodeAction := fun _ _ _ stk node => do let .node (.ofTacticInfo info) _ := node | return #[] unless info.goalsBefore.isEmpty do return #[] let _ :: (seq, i) :: _ := stk | return #[] let some stop := seq.getTailPos? | return #[] let some prev := (seq.setArgs seq.getArgs[:i]).getTailPos? | return #[] let doc ← readDoc let eager := { title := "Remove tactics after 'no goals'" kind? := "quickfix" isPreferred? := true edit? := some <|.ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange ⟨prev, stop⟩ newText := "" } } pure #[{ eager }] /-- Similar to `getElimExprInfo`, but returns the names of binders instead of just the numbers; intended for code actions which need to name the binders. -/ def getElimExprNames (elimType : Expr) : MetaM (Array (Name × Array Name)) := do -- let inductVal ← getConstInfoInduct inductName -- let decl ← getConstInfo declName forallTelescopeReducing elimType fun xs type => do let motive := type.getAppFn let targets := type.getAppArgs let motiveType ← inferType motive let mut altsInfo := #[] for _h : i in [:xs.size] do let x := xs[i] if x != motive && !targets.contains x then let xDecl ← x.fvarId!.getDecl if xDecl.binderInfo.isExplicit then let args ← forallTelescopeReducing xDecl.type fun args _ => do let lctx ← getLCtx pure <| args.filterMap fun y => let yDecl := (lctx.find? y.fvarId!).get! if yDecl.binderInfo.isExplicit then some yDecl.userName else none altsInfo := altsInfo.push (xDecl.userName, args) pure altsInfo /-- Finds the `TermInfo` for an elaborated term `stx`. -/ def findTermInfo? (node : InfoTree) (stx : Term) : Option TermInfo := match node.findInfo? fun | .ofTermInfo i => i.stx.getKind == stx.raw.getKind && i.stx.getRange? == stx.raw.getRange? | _ => false with | some (.ofTermInfo info) => pure info | _ => none /-- `findTermInfoWithCtx?` finds the `TermInfo` for an elaborated term `stx` and also updates the inputted `ContextInfo` using all the `PartialContextInfo` on the path to the returned `TermInfo`. -/ partial def findTermInfoWithCtx? (t : InfoTree) (stx : Term) (ctx : ContextInfo) : Option (TermInfo × ContextInfo) := match t with | .context partialCtx t' => -- Merge partial context with outer, fall back to outer if merge fails let ctx' := partialCtx.mergeIntoOuter? ctx |>.getD ctx findTermInfoWithCtx? t' stx ctx' | .node info children => let optResult : Option (TermInfo × ContextInfo) := match info with | .ofTermInfo i => if i.stx.getKind == stx.raw.getKind && i.stx.getRange? == stx.raw.getRange? then some (i, ctx) else none | _ => none if let some res := optResult then return res else children.findSome? (findTermInfoWithCtx? · stx ctx) | .hole _ => none /-- Invoking tactic code action "Generate an explicit pattern match for 'induction'" in the following: ```lean example (x : Nat) : x = x := by induction x ``` produces: ```lean example (x : Nat) : x = x := by induction x with | zero => sorry | succ n ih => sorry ``` It also works for `cases`. -/ @[tactic_code_action Parser.Tactic.cases Parser.Tactic.induction] def casesExpand : TacticCodeAction := fun _ snap ctx _ node => do let .node (.ofTacticInfo info) _ := node | return #[] let (targets, induction, using_, alts) ← match info.stx with | `(tactic| cases $[$[$_ :]? $targets],* $[using $u]? $(alts)?) => pure (targets, false, u, alts) | `(tactic| induction $[$[$_ :]? $targets],* $[using $u]? $[generalizing $_*]? $(alts)?) => pure (targets, true, u, alts) | _ => return #[] let some discrInfos := targets.mapM (findTermInfo? node) | return #[] let some discr₀ := discrInfos[0]? | return #[] let mut some ctors ← discr₀.runMetaM ctx do let targets := discrInfos.map (·.expr) match using_ with | none => if tactic.customEliminators.get (← getOptions) then if let some elimName ← getCustomEliminator? targets induction then return some (← getElimExprNames (← getConstInfo elimName).type) matchConstInduct (← whnf (← inferType discr₀.expr)).getAppFn (fun _ => failure) fun val _ => do let elimName := if induction then mkRecName val.name else mkCasesOnName val.name return some (← getElimExprNames (← getConstInfo elimName).type) | some u => let some info := findTermInfo? node u | return none return some (← getElimExprNames (← inferType info.expr)) | return #[] let mut fallback := none if let some alts := alts then if let `(Parser.Tactic.inductionAlts| with $(_)? $alts*) := alts then for alt in alts do match alt with | `(Parser.Tactic.inductionAlt| | _ $_* => $fb) => fallback := fb.raw.getRange? | `(Parser.Tactic.inductionAlt| | $id:ident $_* => $_) => ctors := ctors.filter (fun x => x.1 != id.getId) | _ => pure () if ctors.isEmpty then return #[] let tacName := info.stx.getKind.updatePrefix .anonymous let eager := { title := s!"Generate an explicit pattern match for '{tacName}'." kind? := "quickfix" } let doc ← readDoc pure #[{ eager lazy? := some do let tacPos := info.stx.getPos?.get! let endPos := doc.meta.text.utf8PosToLspPos info.stx.getTailPos?.get! let indent := "\n".pushn ' ' (findIndentAndIsStart doc.meta.text.source tacPos).1 let (startPos, str') := if alts.isSome then let stx' := if fallback.isSome then info.stx.modifyArg (if induction then 4 else 3) (·.modifyArg 0 (·.modifyArg 2 (·.modifyArgs (·.filter fun s => !(s matches `(Parser.Tactic.inductionAlt| | _ $_* => $_)))))) else info.stx (doc.meta.text.utf8PosToLspPos stx'.getTailPos?.get!, "") else (endPos, " with") let fallback := if let some ⟨startPos, endPos⟩ := fallback then String.Pos.Raw.extract doc.meta.text.source startPos endPos else "sorry" let newText := Id.run do let mut str := str' for (name, args) in ctors do let mut ctor := toString name if let some _ := (Parser.getTokenTable snap.env).find? ctor then ctor := s!"{idBeginEscape}{ctor}{idEndEscape}" str := str ++ indent ++ s!"| {ctor}" -- replace n_ih with just ih if there is only one let args := if induction && args.foldl (fun c n => if n.eraseMacroScopes.getString!.endsWith "_ih" then c+1 else c) 0 == 1 then args.map (fun n => if !n.hasMacroScopes && n.getString!.endsWith "_ih" then `ih else n) else args for arg in args do str := str ++ if arg.hasNum || arg.isInternal then " _" else s!" {arg}" str := str ++ s!" => " ++ fallback str pure { eager with edit? := some <|.ofTextEdit doc.versionedIdentifier { range := ⟨startPos, endPos⟩ newText } } }] /-- The "Add subgoals" code action puts `· done` subgoals for any goals remaining at the end of a proof. ``` example : True ∧ True := by constructor -- <- here ``` is transformed to ``` example : True ∧ True := by constructor · done · done ``` -/ def addSubgoalsActionCore (params : Lsp.CodeActionParams) (i : Nat) (stk : Syntax.Stack) (goals : List MVarId) : RequestM (Array LazyCodeAction) := do -- If there are zero goals remaining, no need to do anything -- If there is one goal remaining, the user can just keep typing and subgoals are not helpful unless goals.length > 1 do return #[] let seq := stk.head!.1 let nargs := (seq.getNumArgs + 1) / 2 unless i == nargs do -- only trigger at the end of a block -- or if there is only a `done` or `sorry` terminator unless i + 1 == nargs && [ ``Parser.Tactic.done, ``Parser.Tactic.tacticSorry, ``Parser.Tactic.tacticAdmit ].contains seq[2*i].getKind do return #[] let some startPos := seq[0].getPos? true | return #[] let doc ← readDoc let eager := { title := "Add subgoals", kind? := "quickfix" } pure #[{ eager lazy? := some do let indent := "\n".pushn ' ' (doc.meta.text.toPosition startPos).column let mut (range, newText) := (default, "") if let some tac := seq.getArgs[2*i]? then let some range2 := tac.getRange? true | return eager range := range2 else let trimmed := seq.modifyArgs (·[:2*i]) let some tail := trimmed.getTailPos? true | return eager (range, newText) := (⟨tail, tail⟩, indent) let cursor := doc.meta.text.lspPosToUtf8Pos params.range.end if range.stop ≤ cursor && cursor.1 ≤ range.stop.1 + trimmed.getTrailingSize then range := { range with stop := cursor } newText := newText ++ "· done" for _ in goals.tail! do newText := newText ++ indent ++ "· done" pure { eager with edit? := some <|.ofTextEdit doc.versionedIdentifier { range := doc.meta.text.utf8RangeToLspRange range newText } } }] @[inherit_doc addSubgoalsActionCore, tactic_code_action] def addSubgoalsSeqAction : TacticSeqCodeAction := fun params _ _ => addSubgoalsActionCore params -- This makes sure that the addSubgoals action also triggers -- when the cursor is on the final `done` of a tactic block @[inherit_doc addSubgoalsActionCore, tactic_code_action Parser.Tactic.done Parser.Tactic.tacticSorry Parser.Tactic.tacticAdmit] def addSubgoalsAction : TacticCodeAction := fun params _ _ stk node => do let (_ :: (seq, i) :: stk@(_ :: t :: _), .node (.ofTacticInfo info) _) := (stk, node) | return #[] unless t.1.getKind == ``Parser.Tactic.tacticSeq do return #[] addSubgoalsActionCore params (i/2) ((seq, 0) :: stk) info.goalsBefore ================================================ FILE: Batteries/CodeAction.lean ================================================ module public import Batteries.CodeAction.Attr public import Batteries.CodeAction.Basic public import Batteries.CodeAction.Misc public import Batteries.CodeAction.Match ================================================ FILE: Batteries/Control/AlternativeMonad.lean ================================================ /- Copyright (c) 2025 Devon Tuma. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Devon Tuma -/ module public import Batteries.Control.Lemmas public import Batteries.Control.OptionT import all Init.Control.Option import all Init.Control.State import all Init.Control.Reader import all Init.Control.StateRef @[expose] public section /-! # Laws for Monads with Failure Definitions for monads that also have an `Alternative` instance while sharing the underlying `Applicative` instance, and a class `LawfulAlternative` for types where the `failure` and `orElse` operations behave in a natural way. More specifically they satisfy: * `f <$> failure = failure` * `failure <*> x = failure` * `x <|> failure = x` * `failure <|> y = y` * `x <|> y <|> z = (x <|> y) <|> z` * `f <$> (x <|> y) = (f <$> x <|> f <$> y)` `Option`/`OptionT` are the most basic examples, but transformers like `StateT` also preserve the lawfulness of this on the underlying monad. The law `x *> failure = failure` is true for monads like `Option` and `List` that don't have any "side effects" to execution, but not for something like `OptionT` on some monads, so we don't include this condition. We also define a class `LawfulAlternativeLift` similar to `LawfulMonadLift` that states that a lifting between monads preserves `failure` and `orElse`. ## Tags monad, alternative, failure -/ /-- `AlternativeMonad m` means that `m` has both a `Monad` and `Alternative` instance, which both share the same underlying `Applicative` instance. The main example is `Option`, but many monad transformers also preserve or add this structure. -/ class AlternativeMonad (m : Type _ → Type _) extends Alternative m, Monad m section LawfulAlternative /-- `LawfulAlternative m` means that the `failure` operation on `m` behaves naturally with respect to `map`, `seq`, and `orElse` operators. -/ class LawfulAlternative (m : Type _ → Type _) [Alternative m] : Prop extends LawfulApplicative m where /-- Mapping the result of a failure is still a failure -/ map_failure (f : α → β) : f <$> (failure : m α) = failure /-- Sequencing a `failure` call results in failure -/ failure_seq (x : m α) : (failure : m (α → β)) <*> x = failure /-- `failure` is a right identity for `orElse`. -/ orElse_failure (x : m α) : (x <|> failure) = x /-- `failure` is a left identity for `orElse`. -/ failure_orElse (y : m α) : (failure <|> y) = y /-- `orElse` is associative. -/ orElse_assoc (x y z : m α) : (x <|> y <|> z) = ((x <|> y) <|> z) /-- `map` commutes with `orElse`. The stronger statement with `bind` generally isn't true -/ map_orElse (x y : m α) (f : α → β) : f <$> (x <|> y) = (f <$> x <|> f <$> y) export LawfulAlternative (map_failure failure_seq orElse_failure failure_orElse orElse_assoc map_orElse) attribute [simp] map_failure failure_seq orElse_failure failure_orElse map_orElse section Alternative @[simp] theorem mapConst_failure [Alternative m] [LawfulAlternative m] (y : β) : Functor.mapConst y (failure : m α) = failure := by rw [LawfulFunctor.map_const, Function.comp_apply, map_failure] @[simp] theorem mapConst_orElse [Alternative m] [LawfulAlternative m] (x x' : m α) (y : β) : Functor.mapConst y (x <|> x') = (Functor.mapConst y x <|> Functor.mapConst y x') := by simp only [map_const, Function.comp_apply, map_orElse] @[simp] theorem failure_seqLeft [Alternative m] [LawfulAlternative m] (x : m α) : (failure : m β) <* x = failure := by simp only [seqLeft_eq, map_failure, failure_seq] @[simp] theorem failure_seqRight [Alternative m] [LawfulAlternative m] (x : m α) : (failure : m β) *> x = failure := by simp only [seqRight_eq, map_failure, failure_seq] end Alternative section AlternativeMonad @[simp] theorem failure_bind [AlternativeMonad m] [LawfulAlternative m] [LawfulMonad m] (x : α → m β) : failure >>= x = failure := by calc failure >>= x = (PEmpty.elim <$> failure) >>= x := by rw [map_failure] _ = failure >>= (x ∘ PEmpty.elim) := by rw [bind_map_left, Function.comp_def] _ = failure >>= (pure ∘ PEmpty.elim) := bind_congr fun a => a.elim _ = (PEmpty.elim <$> failure) >>= pure := by rw [bind_map_left, Function.comp_def] _ = failure := by rw [map_failure, bind_pure] @[simp] theorem seq_failure [AlternativeMonad m] [LawfulAlternative m] [LawfulMonad m] (x : m (α → β)) : x <*> failure = x *> failure := by simp only [seq_eq_bind_map, map_failure, seqRight_eq, bind_map_left] end AlternativeMonad end LawfulAlternative /-- Type-class for monad lifts that preserve the `Alternative` operations. -/ class LawfulAlternativeLift (m : semiOutParam (Type u → Type v)) (n : Type u → Type w) [Alternative m] [Alternative n] [MonadLift m n] : Prop where /-- Lifting preserves `failure`. -/ monadLift_failure : monadLift (failure : m α) = (failure : n α) /-- Lifting preserves `orElse`. -/ monadLift_orElse (x y : m α) : monadLift (x <|> y) = (monadLift x <|> monadLift y : n α) export LawfulAlternativeLift (monadLift_failure monadLift_orElse) attribute [simp] monadLift_failure monadLift_orElse namespace Option instance : AlternativeMonad Option.{u} where instance : LawfulAlternative Option.{u} where map_failure _ := rfl failure_seq _ := rfl orElse_failure x := by cases x <;> rfl failure_orElse := by simp [failure] orElse_assoc | some _, _, _ => rfl | none, _, _ => rfl map_orElse | some _ => by simp | none => by simp end Option namespace OptionT instance (m) [Monad m] : AlternativeMonad (OptionT m) where instance (m) [Monad m] [LawfulMonad m] : LawfulAlternative (OptionT m) where map_failure _ := pure_bind _ _ failure_seq _ := pure_bind _ _ orElse_failure x := (bind_congr (fun | some _ => rfl | none => rfl)).trans (bind_pure x) failure_orElse _ := pure_bind _ _ orElse_assoc _ _ _ := by simp only [OptionT.ext_iff, run_orElse, Option.elimM, bind_assoc] refine bind_congr fun | some _ => by simp | none => rfl map_orElse x y f := by simp only [OptionT.ext_iff, run_map, run_orElse, map_bind, bind_map_left, Option.elimM] refine bind_congr fun | some _ => by simp | none => rfl end OptionT namespace StateT instance (m) [AlternativeMonad m] : AlternativeMonad (StateT σ m) where instance (m) [AlternativeMonad m] [LawfulAlternative m] [LawfulMonad m] : LawfulAlternative (StateT σ m) where map_failure _ := StateT.ext fun _ => by simp only [run_map, run_failure, map_failure] failure_seq _ := StateT.ext fun _ => by simp only [run_seq, run_failure, failure_bind] orElse_failure _ := StateT.ext fun _ => orElse_failure _ failure_orElse _ := StateT.ext fun _ => failure_orElse _ orElse_assoc _ _ _ := StateT.ext fun _ => orElse_assoc _ _ _ map_orElse _ _ _ := StateT.ext fun _ => by simp only [run_map, run_orElse, map_orElse] instance (m) [AlternativeMonad m] [LawfulAlternative m] [LawfulMonad m] : LawfulAlternativeLift m (StateT σ m) where monadLift_failure {α} := StateT.ext fun s => by simp monadLift_orElse {α} x y := StateT.ext fun s => by simp end StateT namespace ReaderT instance [AlternativeMonad m] : AlternativeMonad (ReaderT ρ m) where instance [AlternativeMonad m] [LawfulAlternative m] : LawfulAlternative (ReaderT ρ m) where map_failure _ := ReaderT.ext fun _ => map_failure _ failure_seq _ := ReaderT.ext fun _ => failure_seq _ orElse_failure _ := ReaderT.ext fun _ => orElse_failure _ failure_orElse _ := ReaderT.ext fun _ => failure_orElse _ orElse_assoc _ _ _ := ReaderT.ext fun _ => orElse_assoc _ _ _ map_orElse _ _ _ := ReaderT.ext fun _ => by simp only [run_map, run_orElse, map_orElse] instance [AlternativeMonad m] : LawfulAlternativeLift m (ReaderT ρ m) where monadLift_failure {α} := ReaderT.ext fun s => by simp monadLift_orElse {α} x y := ReaderT.ext fun s => by simp end ReaderT namespace StateRefT' instance [AlternativeMonad m] : AlternativeMonad (StateRefT' ω σ m) where instance [AlternativeMonad m] [LawfulAlternative m] : LawfulAlternative (StateRefT' ω σ m) := inferInstanceAs (LawfulAlternative (ReaderT (ST.Ref ω σ) m)) instance [AlternativeMonad m] : LawfulAlternativeLift m (StateRefT' ω σ m) := inferInstanceAs (LawfulAlternativeLift m (ReaderT (ST.Ref ω σ) m)) end StateRefT' ================================================ FILE: Batteries/Control/ForInStep/Basic.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module @[expose] public section /-! # Additional definitions on `ForInStep` -/ /-- This is similar to a monadic `bind` operator, except that the two type parameters have to be the same, which prevents putting a monad instance on `ForInStepT m α := m (ForInStep α)`. -/ @[inline] protected def ForInStep.bind [Monad m] (a : ForInStep α) (f : α → m (ForInStep α)) : m (ForInStep α) := match a with | .done a => return .done a | .yield a => f a @[inherit_doc ForInStep.bind] protected abbrev ForInStep.bindM [Monad m] (a : m (ForInStep α)) (f : α → m (ForInStep α)) : m (ForInStep α) := a >>= (·.bind f) /-- Get the value out of a `ForInStep`. This is usually done at the end of a `forIn` loop to scope the early exit to the loop body. -/ @[inline] def ForInStep.run : ForInStep α → α | .done a | .yield a => a /-- Applies function `f` to each element of a list to accumulate a `ForInStep` value. -/ def ForInStep.bindList [Monad m] (f : α → β → m (ForInStep β)) : List α → ForInStep β → m (ForInStep β) | [], s => pure s | a::l, s => s.bind fun b => f a b >>= (·.bindList f l) ================================================ FILE: Batteries/Control/ForInStep/Lemmas.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Control.ForInStep.Basic @[expose] public section /-! # Additional theorems on `ForInStep` -/ @[simp] theorem ForInStep.bind_done [Monad m] (a : α) (f : α → m (ForInStep α)) : (ForInStep.done a).bind (m := m) f = pure (.done a) := rfl @[simp] theorem ForInStep.bind_yield [Monad m] (a : α) (f : α → m (ForInStep α)) : (ForInStep.yield a).bind (m := m) f = f a := rfl attribute [simp] ForInStep.bindM @[simp] theorem ForInStep.run_done : (ForInStep.done a).run = a := rfl @[simp] theorem ForInStep.run_yield : (ForInStep.yield a).run = a := rfl @[simp] theorem ForInStep.bindList_nil [Monad m] (f : α → β → m (ForInStep β)) (s : ForInStep β) : s.bindList f [] = pure s := rfl @[simp] theorem ForInStep.bindList_cons [Monad m] (f : α → β → m (ForInStep β)) (s : ForInStep β) (a l) : s.bindList f (a::l) = s.bind fun b => f a b >>= (·.bindList f l) := rfl @[simp] theorem ForInStep.done_bindList [Monad m] (f : α → β → m (ForInStep β)) (a l) : (ForInStep.done a).bindList f l = pure (.done a) := by cases l <;> simp @[simp] theorem ForInStep.bind_yield_bindList [Monad m] (f : α → β → m (ForInStep β)) (s : ForInStep β) (l) : (s.bind fun a => (yield a).bindList f l) = s.bindList f l := by cases s <;> simp @[simp] theorem ForInStep.bind_bindList_assoc [Monad m] [LawfulMonad m] (f : β → m (ForInStep β)) (g : α → β → m (ForInStep β)) (s : ForInStep β) (l) : s.bind f >>= (·.bindList g l) = s.bind fun b => f b >>= (·.bindList g l) := by cases s <;> simp theorem ForInStep.bindList_cons' [Monad m] [LawfulMonad m] (f : α → β → m (ForInStep β)) (s : ForInStep β) (a l) : s.bindList f (a::l) = s.bind (f a) >>= (·.bindList f l) := by simp @[simp] theorem ForInStep.bindList_append [Monad m] [LawfulMonad m] (f : α → β → m (ForInStep β)) (s : ForInStep β) (l₁ l₂) : s.bindList f (l₁ ++ l₂) = s.bindList f l₁ >>= (·.bindList f l₂) := by induction l₁ generalizing s <;> simp [*] ================================================ FILE: Batteries/Control/ForInStep.lean ================================================ module public import Batteries.Control.ForInStep.Basic public import Batteries.Control.ForInStep.Lemmas ================================================ FILE: Batteries/Control/LawfulMonadState.lean ================================================ /- Copyright (c) 2025 Devon Tuma. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Devon Tuma, Quang Dao -/ module import all Init.Control.StateRef @[expose] public section /-! # Laws for Monads with State This file defines a typeclass for `MonadStateOf` with compatible `get` and `set` operations. Note that we use `MonadStateOf` over `MonadState` as the first induces the second, but we phrase things using `MonadStateOf.set` and `MonadState.get` as those are the versions that are available at the top level namespace. -/ /-- The namespaced `MonadStateOf.get` is equal to the `MonadState` provided `get`. -/ @[simp] theorem monadStateOf_get_eq_get [MonadStateOf σ m] : (MonadStateOf.get : m σ) = get := rfl /-- The namespaced `MonadStateOf.modifyGet` is equal to the `MonadState` provided `modifyGet`. -/ @[simp] theorem monadStateOf_modifyGet_eq_modifyGet [MonadStateOf σ m] (f : σ → α × σ) : (MonadStateOf.modifyGet f : m α) = modifyGet f := rfl @[simp] theorem liftM_get {m n} [MonadStateOf σ m] [MonadLift m n] : (liftM (get (m := m)) : n _) = get := rfl @[simp] theorem liftM_set {m n} [MonadStateOf σ m] [MonadLift m n] (s : σ) : (liftM (set (m := m) s) : n _) = set s := rfl @[simp] theorem liftM_modify {m n} [MonadStateOf σ m] [MonadLift m n] (f : σ → σ) : (liftM (modify (m := m) f) : n _) = modify f := rfl @[simp] theorem liftM_modifyGet {m n} [MonadStateOf σ m] [MonadLift m n] (f : σ → α × σ) : (liftM (modifyGet (m := m) f) : n _) = modifyGet f := rfl @[simp] theorem liftM_getModify {m n} [MonadStateOf σ m] [MonadLift m n] (f : σ → σ) : (liftM (getModify (m := m) f) : n _) = getModify f := rfl /-- Class for well behaved state monads, extending the base `MonadState` type. Requires that `modifyGet` is equal to the same definition with only `get` and `set`, that `get` is idempotent if the result isn't used, and that `get` after `set` returns exactly the value that was previously `set`. -/ class LawfulMonadStateOf (σ : semiOutParam (Type _)) (m : Type _ → Type _) [Monad m] [MonadStateOf σ m] extends LawfulMonad m where /-- `modifyGet f` is equal to getting the state, modifying it, and returning a result. -/ modifyGet_eq {α} (f : σ → α × σ) : modifyGet (m := m) f = do let z ← f <$> get; set z.2; return z.1 /-- Discarding the result of `get` is the same as never getting the state. -/ get_bind_const {α} (mx : m α) : (do let _ ← get; mx) = mx /-- Calling `get` twice is the same as just using the first retreived state value. -/ get_bind_get_bind {α} (mx : σ → σ → m α) : (do let s ← get; let s' ← get; mx s s') = (do let s ← get; mx s s) /-- Setting the monad state to its current value has no effect. -/ get_bind_set_bind {α} (mx : σ → PUnit → m α) : (do let s ← get; let u ← set s; mx s u) = (do let s ← get; mx s PUnit.unit) /-- Setting and then returning the monad state is the same as returning the set value. -/ set_bind_get (s : σ) : (do set (m := m) s; get) = (do set s; return s) /-- Setting the monad twice is the same as just setting to the final state. -/ set_bind_set (s s' : σ) : (do set (m := m) s; set s') = set s' namespace LawfulMonadStateOf variable {σ : Type _} {m : Type _ → Type _} [Monad m] [MonadStateOf σ m] [LawfulMonadStateOf σ m] attribute [simp] get_bind_const get_bind_get_bind get_bind_set_bind set_bind_get set_bind_set @[simp] theorem get_seqRight (mx : m α) : get *> mx = mx := by rw [seqRight_eq_bind, get_bind_const] @[simp] theorem seqLeft_get (mx : m α) : mx <* get = mx := by simp only [seqLeft_eq_bind, get_bind_const, bind_pure] @[simp] theorem get_map_const (x : α) : (fun _ => x) <$> get (m := m) = pure x := by rw [map_eq_pure_bind, get_bind_const] theorem get_bind_get : (do let _ ← get (m := m); get) = get := get_bind_const get @[simp] theorem get_bind_set : (do let s ← get (m := m); set s) = return PUnit.unit := by simpa only [bind_pure_comp, id_map', get_map_const] using get_bind_set_bind (σ := σ) (m := m) (fun _ _ => return PUnit.unit) @[simp] theorem get_bind_map_set (f : σ → PUnit → α) : (do let s ← get (m := m); f s <$> set s) = (do return f (← get) PUnit.unit) := by simp [map_eq_pure_bind, -bind_pure_comp] @[simp] theorem set_bind_get_bind (s : σ) (f : σ → m α) : (do set s; let s' ← get; f s') = (do set s; f s) := by rw [← bind_assoc, set_bind_get, bind_assoc, pure_bind] @[simp] theorem set_bind_map_get (f : σ → α) (s : σ) : (do set (m := m) s; f <$> get) = (do set (m := m) s; pure (f s)) := by simp [map_eq_pure_bind, -bind_pure_comp] @[simp] theorem set_bind_set_bind (s s' : σ) (mx : m α) : (do set s; set s'; mx) = (do set s'; mx) := by rw [← bind_assoc, set_bind_set] @[simp] theorem set_bind_map_set (s s' : σ) (f : PUnit → α) : (do set (m := m) s; f <$> set s') = (do f <$> set s') := by simp [map_eq_pure_bind, ← bind_assoc, -bind_pure_comp] section modify theorem modifyGetThe_eq (f : σ → α × σ) : modifyGetThe σ (m := m) f = do let z ← f <$> get; set z.2; return z.1 := modifyGet_eq f theorem modify_eq (f : σ → σ) : modify (m := m) f = (do set (f (← get))) := by simp [modify, modifyGet_eq] theorem modifyThe_eq (f : σ → σ) : modifyThe σ (m := m) f = (do set (f (← get))) := modify_eq f theorem getModify_eq (f : σ → σ) : getModify (m := m) f = do let s ← get; set (f s); return s := by rw [getModify, modifyGet_eq, bind_map_left] /-- Version of `modifyGet_eq` that preserves an call to `modify`. -/ theorem modifyGet_eq' (f : σ → α × σ) : modifyGet (m := m) f = do let s ← get; modify (Prod.snd ∘ f); return (f s).fst := by simp [modify_eq, modifyGet_eq] @[simp] theorem modify_id : modify (m := m) id = pure PUnit.unit := by simp [modify_eq] @[simp] theorem getModify_id : getModify (m := m) id = get := by simp [getModify_eq] @[simp] theorem set_bind_modify (s : σ) (f : σ → σ) : (do set (m := m) s; modify f) = set (f s) := by simp [modify_eq] @[simp] theorem set_bind_modify_bind (s : σ) (f : σ → σ) (mx : PUnit → m α) : (do set s; let u ← modify f; mx u) = (do set (f s); mx PUnit.unit) := by simp [modify_eq, ← bind_assoc] @[simp] theorem set_bind_modifyGet (s : σ) (f : σ → α × σ) : (do set (m := m) s; modifyGet f) = (do set (f s).2; return (f s).1) := by simp [modifyGet_eq] @[simp] theorem set_bind_modifyGet_bind (s : σ) (f : σ → α × σ) (mx : α → m β) : (do set s; let x ← modifyGet f; mx x) = (do set (f s).2; mx (f s).1) := by simp [modifyGet_eq] @[simp] theorem set_bind_getModify (s : σ) (f : σ → σ) : (do set (m := m) s; getModify f) = (do set (f s); return s) := by simp [getModify_eq] @[simp] theorem set_bind_getModify_bind (s : σ) (f : σ → σ) (mx : σ → m α) : (do set s; let x ← getModify f; mx x) = (do set (f s); mx s) := by simp [getModify_eq, ← bind_assoc] @[simp] theorem modify_bind_modify (f g : σ → σ) : (do modify (m := m) f; modify g) = modify (g ∘ f) := by simp [modify_eq] @[simp] theorem modify_bind_modifyGet (f : σ → σ) (g : σ → α × σ) : (do modify (m := m) f; modifyGet g) = modifyGet (g ∘ f) := by simp [modify_eq, modifyGet_eq] @[simp] theorem getModify_bind_modify (f : σ → σ) (g : σ → σ → σ) : (do let s ← getModify (m := m) f; modify (g s)) = (do let s ← get; modify (g s ∘ f)) := by simp [modify_eq, getModify_eq] theorem modify_comm_of_comp_comm {f g : σ → σ} (h : f ∘ g = g ∘ f) : (do modify (m := m) f; modify g) = (do modify (m := m) g; modify f) := by simp [modify_bind_modify, h] theorem modify_bind_get (f : σ → σ) : (do modify (m := m) f; get) = (do let s ← get; modify f; return (f s)) := by simp [modify_eq] end modify /-- `StateT` has lawful state operations if the underlying monad is lawful. This is applied for `StateM` as well due to the reducibility of that definition. -/ instance {m σ} [Monad m] [LawfulMonad m] : LawfulMonadStateOf σ (StateT σ m) where modifyGet_eq f := StateT.ext fun s => by simp get_bind_const mx := StateT.ext fun s => by simp get_bind_get_bind mx := StateT.ext fun s => by simp get_bind_set_bind mx := StateT.ext fun s => by simp set_bind_get s := StateT.ext fun s => by simp set_bind_set s s' := StateT.ext fun s => by simp /-- The continuation passing state monad variant `StateCpsT` always has lawful state instance. -/ instance {σ m} : LawfulMonadStateOf σ (StateCpsT σ m) where modifyGet_eq _ := rfl get_bind_const _ := rfl get_bind_get_bind _ := rfl get_bind_set_bind _ := rfl set_bind_get _ := rfl set_bind_set _ _ := rfl /-- The `EStateM` monad always has a lawful state instance. -/ instance {σ ε} : LawfulMonadStateOf σ (EStateM ε σ) where modifyGet_eq _ := rfl get_bind_const _ := rfl get_bind_get_bind _ := rfl get_bind_set_bind _ := rfl set_bind_get _ := rfl set_bind_set _ _ := rfl /-- If the underlying monad `m` has a lawful state instance, then the induced state instance on `ReaderT ρ m` will also be lawful. -/ instance {m σ ρ} [Monad m] [LawfulMonad m] [MonadStateOf σ m] [LawfulMonadStateOf σ m] : LawfulMonadStateOf σ (ReaderT ρ m) where modifyGet_eq f := ReaderT.ext fun ctx => by simp [← liftM_modifyGet, LawfulMonadStateOf.modifyGet_eq, ← liftM_get] get_bind_const mx := ReaderT.ext fun ctx => by simp [← liftM_get] get_bind_get_bind mx := ReaderT.ext fun ctx => by simp [← liftM_get] get_bind_set_bind mx := ReaderT.ext fun ctx => by simp [← liftM_get, ← liftM_set] set_bind_get s := ReaderT.ext fun ctx => by simp [← liftM_get, ← liftM_set] set_bind_set s s' := ReaderT.ext fun ctx => by simp [← liftM_set] instance {m ω σ} [Monad m] [LawfulMonad m] [MonadStateOf σ m] [LawfulMonadStateOf σ m] : LawfulMonadStateOf σ (StateRefT' ω σ m) := inferInstanceAs (LawfulMonadStateOf σ (ReaderT (ST.Ref ω σ) m)) ================================================ FILE: Batteries/Control/Lemmas.lean ================================================ /- Copyright (c) 2023 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais, Eric Wieser -/ module import all Init.Control.Reader import all Init.Control.State @[expose] public section namespace ReaderT attribute [ext] ReaderT.ext @[simp] theorem run_failure [Monad m] [Alternative m] (ctx : ρ) : (failure : ReaderT ρ m α).run ctx = failure := (rfl) @[simp] theorem run_orElse [Monad m] [Alternative m] (x y : ReaderT ρ m α) (ctx : ρ) : (x <|> y).run ctx = (x.run ctx <|> y.run ctx) := (rfl) @[simp] theorem run_throw [MonadExceptOf ε m] (e : ε) (ctx : ρ) : (throw e : ReaderT ρ m α).run ctx = throw e := rfl @[simp] theorem run_throwThe [MonadExceptOf ε m] (e : ε) (ctx : ρ) : (throwThe ε e : ReaderT ρ m α).run ctx = throwThe ε e := rfl @[simp] theorem run_tryCatch [MonadExceptOf ε m] (body : ReaderT ρ m α) (handler : ε → ReaderT ρ m α) (ctx : ρ) : (tryCatch body handler).run ctx = tryCatch (body.run ctx) (handler · |>.run ctx) := rfl @[simp] theorem run_tryCatchThe [MonadExceptOf ε m] (body : ReaderT ρ m α) (handler : ε → ReaderT ρ m α) (ctx : ρ) : (tryCatchThe ε body handler).run ctx = tryCatchThe ε (body.run ctx) (handler · |>.run ctx) := rfl end ReaderT namespace StateT attribute [ext] StateT.ext @[simp] theorem run_failure {α σ} [Monad m] [Alternative m] (s : σ) : (failure : StateT σ m α).run s = failure := (rfl) @[simp] theorem run_orElse {α σ} [Monad m] [Alternative m] (x y : StateT σ m α) (s : σ) : (x <|> y).run s = (x.run s <|> y.run s) := (rfl) @[simp] theorem run_throw [Monad m] [MonadExceptOf ε m] (e : ε) (s : σ) : (throw e : StateT σ m α).run s = (do let a ← throw e; pure (a, s)) := rfl @[simp] theorem run_throwThe [Monad m] [MonadExceptOf ε m] (e : ε) (s : σ) : (throwThe ε e : StateT σ m α).run s = (do let a ← throwThe ε e; pure (a, s)) := rfl @[simp] theorem run_tryCatch [Monad m] [MonadExceptOf ε m] (body : StateT σ m α) (handler : ε → StateT σ m α) (s : σ) : (tryCatch body handler).run s = tryCatch (body.run s) (handler · |>.run s) := rfl @[simp] theorem run_tryCatchThe [Monad m] [MonadExceptOf ε m] (body : StateT σ m α) (handler : ε → StateT σ m α) (s : σ) : (tryCatchThe ε body handler).run s = tryCatchThe ε (body.run s) (handler · |>.run s) := rfl end StateT ================================================ FILE: Batteries/Control/Monad.lean ================================================ /- Copyright (c) 2025 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Tactic.Alias @[expose] public section @[deprecated (since := "2025-02-09")] alias LawfulFunctor.map_inj_right_of_nonempty := map_inj_right_of_nonempty @[deprecated (since := "2025-02-09")] alias LawfulMonad.map_inj_right := map_inj_right ================================================ FILE: Batteries/Control/Nondet/Basic.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Tactic.Lint.Misc public import Batteries.Data.MLList.Basic import Lean.Util.MonadBacktrack @[expose] public section /-! # A nondeterminism monad. We represent nondeterministic values in a type `α` as a single field structure containing an `MLList m (σ × α)`, i.e. as a monadic lazy list of possible values, each equipped with the backtrackable state required to run further computations in the ambient monad. We provide an `Alternative` `Monad` instance, as well as functions `bind`, `mapM`, and `filterMapM`, and functions `singletonM`, `ofListM`, `ofOptionM`, and `firstM` for entering and leaving the nondeterministic world. Operations on the nondeterministic value via `bind`, `mapM`, and `filterMapM` run with the appropriate backtrackable state, and are responsible for updating the state themselves (typically this doesn't need to be done explicitly, but just happens as a side effect in the monad `m`). -/ open Lean (MonadBacktrack) open Lean.MonadBacktrack /-- `Nondet m α` is variation on `MLList m α` suitable for use with backtrackable monads `m`. We think of `Nondet m α` as a nondeterministic value in `α`, with the possible alternatives stored in a monadic lazy list. Along with each `a : α` we store the backtrackable state, and ensure that monadic operations on alternatives run with the appropriate state. Operations on the nondeterministic value via `bind`, `mapM`, and `filterMapM` run with the appropriate backtrackable state, and are responsible for updating the state themselves (typically this doesn't need to be done explicitly, but just happens as a side effect in the monad `m`). -/ @[nolint unusedArguments] structure Nondet (m : Type → Type) [MonadBacktrack σ m] (α : Type) : Type where /-- Convert a non-deterministic value into a lazy list, keeping the backtrackable state. Be careful that monadic operations on the `MLList` will not respect this state! -/ toMLList : MLList m (α × σ) namespace Nondet variable {m : Type → Type} section Monad variable [Monad m] [MonadBacktrack σ m] /-- The empty nondeterministic value. -/ def nil : Nondet m α := .mk .nil instance : Inhabited (Nondet m α) := ⟨.nil⟩ /-- Squash a monadic nondeterministic value to a nondeterministic value. -/ def squash (L : Unit → m (Nondet m α)) : Nondet m α := .mk <| MLList.squash fun _ => return (← L ()).toMLList /-- Bind a nondeterministic function over a nondeterministic value, ensuring the function is run with the relevant backtrackable state at each value. -/ partial def bind (L : Nondet m α) (f : α → Nondet m β) : Nondet m β := .squash fun _ => do match ← L.toMLList.uncons with | none => pure .nil | some (⟨x, s⟩, xs) => do let r := (Nondet.mk xs).bind f restoreState s match ← (f x).toMLList.uncons with | none => return r | some (y, ys) => return .mk <| .cons y (ys.append (fun _ => r.toMLList)) /-- Convert any value in the monad to the singleton nondeterministic value. -/ def singletonM (x : m α) : Nondet m α := .mk <| .singletonM do let a ← x return (a, ← saveState) /-- Convert a value to the singleton nondeterministic value. -/ def singleton (x : α) : Nondet m α := singletonM (pure x) /-- `Nondet m` is an alternative monad. -/ instance : AlternativeMonad (Nondet m) where pure a := singletonM (pure a) bind := bind failure := .nil orElse x y := .mk <| x.toMLList.append fun _ => (y ()).toMLList instance : MonadLift m (Nondet m) where monadLift := singletonM /-- Lift a list of monadic values to a nondeterministic value. We ensure that each monadic value is evaluated with the same backtrackable state. -/ def ofListM (L : List (m α)) : Nondet m α := .squash fun _ => do let s ← saveState return .mk <| MLList.ofListM <| L.map fun x => do restoreState s let a ← x pure (a, ← saveState) /-- Lift a list of values to a nondeterministic value. (The backtrackable state in each will be identical: whatever the state was when we first read from the result.) -/ def ofList (L : List α) : Nondet m α := ofListM (L.map pure) /-- Apply a function which returns values in the monad to every alternative of a `Nondet m α`. -/ def mapM (f : α → m β) (L : Nondet m α) : Nondet m β := L.bind fun a => singletonM (f a) /-- Apply a function to each alternative in a `Nondet m α` . -/ def map (f : α → β) (L : Nondet m α) : Nondet m β := L.mapM fun a => pure (f a) /-- Convert a monadic optional value to a nondeterministic value. -/ def ofOptionM (x : m (Option α)) : Nondet m α := .squash fun _ => do match ← x with | none => return .nil | some a => return singleton a /-- Convert an optional value to a nondeterministic value. -/ def ofOption (x : Option α) : Nondet m α := ofOptionM (pure x) /-- Filter and map a nondeterministic value using a monadic function which may return `none`. -/ def filterMapM (f : α → m (Option β)) (L : Nondet m α) : Nondet m β := L.bind fun a => ofOptionM (f a) /-- Filter and map a nondeterministic value. -/ def filterMap (f : α → Option β) (L : Nondet m α) : Nondet m β := L.filterMapM fun a => pure (f a) /-- Filter a nondeterministic value using a monadic predicate. -/ def filterM (p : α → m (ULift Bool)) (L : Nondet m α) : Nondet m α := L.filterMapM fun a => do if (← p a).down then pure (some a) else pure none /-- Filter a nondeterministic value. -/ def filter (p : α → Bool) (L : Nondet m α) : Nondet m α := L.filterM fun a => pure <| .up (p a) /-- All iterations of a non-deterministic function on an initial value. (That is, depth first search.) -/ partial def iterate (f : α → Nondet m α) (a : α) : Nondet m α := singleton a <|> (f a).bind (iterate f) /-- Convert a non-deterministic value into a lazy list, by discarding the backtrackable state. -/ def toMLList' (L : Nondet m α) : MLList m α := L.toMLList.map (·.1) /-- Convert a non-deterministic value into a list in the monad, retaining the backtrackable state. -/ def toList (L : Nondet m α) : m (List (α × σ)) := L.toMLList.force /-- Convert a non-deterministic value into a list in the monad, by discarding the backtrackable state. -/ def toList' (L : Nondet m α) : m (List α) := L.toMLList.map (·.1) |>.force end Monad section AlternativeMonad variable [AlternativeMonad m] [MonadBacktrack σ m] /-- Find the first alternative in a nondeterministic value, as a monadic value. -/ def head (L : Nondet m α) : m α := do let (x, s) ← L.toMLList.head restoreState s return x /-- Find the value of a monadic function on the first alternative in a nondeterministic value where the function succeeds. -/ def firstM (L : Nondet m α) (f : α → m (Option β)) : m β := L.filterMapM f |>.head end AlternativeMonad end Nondet /-- The `Id` monad is trivially backtrackable, with state `Unit`. -/ -- This is useful so we can use `Nondet Id α` instead of `List α` -- as the basic non-determinism monad. instance : MonadBacktrack Unit Id where saveState := pure () restoreState _ := pure () ================================================ FILE: Batteries/Control/OptionT.lean ================================================ /- Copyright (c) 2017 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Sebastian Ullrich -/ module public import Batteries.Control.LawfulMonadState import all Init.Control.Option @[expose] public section /-! # Lemmas About Option Monad Transformer This file contains lemmas about the behavior of `OptionT` and `OptionT.run`. -/ namespace OptionT @[simp] theorem run_monadLift [Monad m] [LawfulMonad m] [MonadLiftT n m] (x : n α) : (monadLift x : OptionT m α).run = some <$> (monadLift x : m α) := (map_eq_pure_bind _ _).symm @[simp] theorem run_mapConst [Monad m] [LawfulMonad m] (x : OptionT m α) (y : β) : (Functor.mapConst y x).run = Option.map (Function.const α y) <$> x.run := run_map _ _ instance [Monad m] [LawfulMonad m] [MonadStateOf σ m] [LawfulMonadStateOf σ m] : LawfulMonadStateOf σ (OptionT m) where modifyGet_eq f := by simp [← liftM_modifyGet, ← liftM_get, LawfulMonadStateOf.modifyGet_eq] get_bind_const mx := OptionT.ext (by simp [← liftM_get]) get_bind_get_bind mx := OptionT.ext (by simp [← liftM_get]) get_bind_set_bind mx := OptionT.ext (by simp [← liftM_get, ← liftM_set]) set_bind_get s := OptionT.ext (by simp [← liftM_get, ← liftM_set]) set_bind_set s s' := OptionT.ext (by simp [← liftM_set]) end OptionT ================================================ FILE: Batteries/Data/Array/Basic.lean ================================================ /- Copyright (c) 2021 Floris van Doorn. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Arthur Paulino, Floris van Doorn, Jannis Limperg -/ module import Batteries.Tactic.Alias import Batteries.Data.UInt @[expose] public section /-! ## Definitions on Arrays This file contains various definitions on `Array`. It does not contain proofs about these definitions, those are contained in other files in `Batteries.Data.Array`. -/ namespace Array /-- Check whether `xs` and `ys` are equal as sets, i.e. they contain the same elements when disregarding order and duplicates. `O(n*m)`! If your element type has an `Ord` instance, it is asymptotically more efficient to sort the two arrays, remove duplicates and then compare them elementwise. -/ def equalSet [BEq α] (xs ys : Array α) : Bool := xs.all (ys.contains ·) && ys.all (xs.contains ·) /-- Returns the first minimal element among `d` and elements of the array. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered (in addition to `d`). -/ @[inline] protected def rangeMinWith [ord : Ord α] (xs : Array α) (d : α) (start := 0) (stop := xs.size) : α := xs.foldl (init := d) (start := start) (stop := stop) fun min x => if compare x min |>.isLT then x else min @[inherit_doc Array.rangeMinWith, deprecated Array.rangeMinWith (since := "2026-01-08")] protected def minWith := @Array.rangeMinWith /-- Find the first minimal element of an array. If the array is empty, `d` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMinD [ord : Ord α] (xs : Array α) (d : α) (start := 0) (stop := xs.size) : α := if h: start < xs.size ∧ start < stop then xs.rangeMinWith xs[start] (start + 1) stop else d @[inherit_doc Array.rangeMinD, deprecated Array.rangeMinD (since := "2026-01-08")] protected def minD := @Array.rangeMinD /-- Find the first minimal element of an array. If the array is empty, `none` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMin? [ord : Ord α] (xs : Array α) (start := 0) (stop := xs.size) : Option α := if h : start < xs.size ∧ start < stop then some $ xs.rangeMinD xs[start] start stop else none /-- Find the first minimal element of an array. If the array is empty, `default` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMinI [ord : Ord α] [Inhabited α] (xs : Array α) (start := 0) (stop := xs.size) : α := xs.rangeMinD default start stop @[inherit_doc Array.rangeMinI, deprecated Array.rangeMinI (since := "2026-01-08")] protected def minI := @Array.rangeMinI /-- Returns the first maximal element among `d` and elements of the array. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered (in addition to `d`). -/ @[inline] protected def rangeMaxWith [ord : Ord α] (xs : Array α) (d : α) (start := 0) (stop := xs.size) : α := xs.rangeMinWith (ord := ord.opposite) d start stop @[inherit_doc Array.rangeMaxWith, deprecated Array.rangeMaxWith (since := "2026-01-08")] protected def maxWith := @Array.rangeMaxWith /-- Find the first maximal element of an array. If the array is empty, `d` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMaxD [ord : Ord α] (xs : Array α) (d : α) (start := 0) (stop := xs.size) : α := xs.rangeMinD (ord := ord.opposite) d start stop @[inherit_doc Array.rangeMaxD, deprecated Array.rangeMaxD (since := "2026-01-08")] protected def maxD := @Array.rangeMaxD /-- Find the first maximal element of an array. If the array is empty, `none` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMax? [ord : Ord α] (xs : Array α) (start := 0) (stop := xs.size) : Option α := xs.rangeMin? (ord := ord.opposite) start stop /-- Find the first maximal element of an array. If the array is empty, `default` is returned. If `start` and `stop` are given, only the subarray `xs[start...stop]` is considered. -/ @[inline] protected def rangeMaxI [ord : Ord α] [Inhabited α] (xs : Array α) (start := 0) (stop := xs.size) : α := xs.rangeMinI (ord := ord.opposite) start stop @[inherit_doc Array.rangeMaxI, deprecated Array.rangeMaxI (since := "2026-01-08")] protected def maxI := @Array.rangeMaxI @[deprecated set (since := "2026-02-02")] alias setN := set /- This is guaranteed by the Array docs but it is unprovable. May be asserted to be true in an unsafe context via `Array.unsafe_sizeFitsUsize` -/ private abbrev SizeFitsUSize (a : Array α) : Prop := a.size < USize.size /- This is guaranteed by the Array docs but it is unprovable. Can be used in unsafe functions to write more efficient implementations that avoid arbitrary precision integer arithmetic. -/ private unsafe def unsafe_sizeFitsUSize (a : Array α) : SizeFitsUSize a := lcProof @[inline] private def scanlMFast [Monad m] (f : β → α → m β) (init : β) (as : Array α) (start := 0) (stop := as.size) : m (Array β) := let stop := min stop as.size let start := min start as.size loop f init as (start := USize.ofNat start) (stop := USize.ofNat stop) (h_stop := by grind only [USize.size_eq, USize.ofNat_eq_iff_mod_eq_toNat, = Nat.min_def]) (acc := Array.mkEmpty <| stop - start + 1) where @[specialize] loop (f : β → α → m β) (init: β) (as: Array α) (start stop : USize) (h_stop : stop.toNat ≤ as.size) (acc : Array β) : m (Array β) := do if h_lt: start < stop then let next ← f init (as.uget start <| Nat.lt_of_lt_of_le h_lt h_stop) loop f next as (start + 1) stop h_stop (acc.push init) else pure <| acc.push init termination_by stop.toNat - min start.toNat stop.toNat decreasing_by have : start < (start + 1) := by grind only [USize.size_eq] grind only [Nat.min_def, USize.lt_iff_toNat_lt] /-- Folds a monadic function over an array from the left, accumulating the partial results starting with `init`. The accumulated value is combined with the each element of the list in order, using `f`. The optional parameters `start` and `stop` control the region of the array to be folded. Folding proceeds from `start` (inclusive) to `stop` (exclusive), so no folding occurs unless `start < stop`. By default, the entire array is folded. Examples: ```lean example example [Monad m] (f : α → β → m α) : Array.scanlM f x₀ #[a, b, c] = (do let x₁ ← f x₀ a let x₂ ← f x₁ b let x₃ ← f x₂ c pure #[x₀, x₁, x₂, x₃]) := by simp [scanlM, scanlM.loop] ``` ```lean example example [Monad m] (f : α → β → m α) : Array.scanlM f x₀ #[a, b, c] (start := 1) (stop := 3) = (do let x₁ ← f x₀ b let x₂ ← f x₁ c pure #[x₀, x₁, x₂]) := by simp [scanlM, scanlM.loop] ``` -/ @[implemented_by scanlMFast] def scanlM [Monad m] (f : β → α → m β) (init : β) (as : Array α) (start := 0) (stop := as.size) : m (Array β) := loop f init as (min start as.size) (min stop as.size) (Nat.min_le_right _ _) #[] where /-- auxiliary tail-recursive function for scanlM -/ loop (f : β → α → m β) (init : β ) (as : Array α) (start stop : Nat) (h_stop : stop ≤ as.size) (acc : Array β) : m (Array β) := do if h_lt : start < stop then loop f (← f init as[start]) as (start + 1) stop h_stop (acc.push init) else pure <| acc.push init private theorem scanlM_loop_eq_scanlMFast_loop [Monad m] {f : β → α → m β} {init : β} {as : Array α} {h_size : as.SizeFitsUSize} {start stop : Nat} {h_start : start ≤ as.size} {h_stop : stop ≤ as.size} {acc : Array β} : scanlM.loop f init as start stop h_stop acc = scanlMFast.loop f init as (USize.ofNat start) (USize.ofNat stop) (by rw [USize.toNat_ofNat_of_le_of_lt h_size h_stop]; exact h_stop) acc := by generalize h_n : stop - start = n induction n using Nat.strongRecOn generalizing start acc init rename_i n ih rw [scanlM.loop, scanlMFast.loop] have h_stop_usize := USize.toNat_ofNat_of_le_of_lt h_size h_stop have h_start_usize := USize.toNat_ofNat_of_le_of_lt h_size h_start split case isTrue h_lt => simp_all only [USize.toNat_ofNat', ↓reduceDIte, uget, show USize.ofNat start < USize.ofNat stop by simp_all [USize.lt_iff_toNat_lt]] apply bind_congr intro next have h_start_succ : USize.ofNat start + 1 = USize.ofNat (start + 1) := by simp_all only [← USize.toNat_inj, USize.toNat_add] grind only [USize.size_eq, USize.toNat_ofNat_of_le_of_lt] rw [h_start_succ] apply ih (stop - (start + 1)) <;> omega case isFalse h_nlt => grind [USize.lt_iff_toNat_lt] -- this theorem establishes that given the (unprovable) assumption that as.size < USize.size, -- the scanlMFast and scanlM are equivalent -- TODO (cmlsharp): prova an analogous theorem for scanrM private theorem scanlM_eq_scanlMFast [Monad m] {f : β → α → m β} {init : β} {as : Array α} {h_size : as.SizeFitsUSize} {start stop : Nat} : scanlM f init as start stop = scanlMFast f init as start stop := by unfold scanlM scanlMFast apply scanlM_loop_eq_scanlMFast_loop simp_all only [gt_iff_lt] apply Nat.min_le_right @[inline] private def scanrMFast [Monad m] (f : α → β → m β) (init : β) (as : Array α) (h_size : as.SizeFitsUSize) (start := as.size) (stop := 0) : m (Array β) := let start := min start as.size let stop := min stop start loop f init as (start := USize.ofNat start) (stop := USize.ofNat stop) (h_start := by grind only [USize.size_eq, USize.ofNat_eq_iff_mod_eq_toNat, = Nat.min_def]) (acc := Array.replicate (start - stop + 1) init) (by grind only [!Array.size_replicate, = Nat.min_def, USize.toNat_ofNat_of_le_of_lt]) where @[specialize] loop (f : α → β → m β) (init : β) (as : Array α) (start stop : USize) (h_start : start.toNat ≤ as.size) (acc : Array β) (h_bound : start.toNat - stop.toNat < acc.size) : m (Array β) := do if h_gt : stop < start then let startM1 := start - 1 have : startM1 < start := by grind only [!USize.sub_add_cancel, USize.lt_iff_le_and_ne, USize.lt_add_one, USize.le_zero_iff] have : startM1.toNat < as.size := Nat.lt_of_lt_of_le ‹_› ‹_› have : (startM1 - stop) < (start - stop) := by grind only [!USize.sub_add_cancel, USize.sub_right_inj, USize.add_comm, USize.lt_add_one, USize.add_assoc, USize.add_right_inj] let next ← f (as.uget startM1 ‹_›) init loop f next as (start := startM1) (stop := stop) (h_start := Nat.le_of_succ_le_succ (Nat.le_succ_of_le ‹_›)) (acc := acc.uset (startM1 - stop) next (by grind only [USize.toNat_sub_of_le, USize.le_of_lt, USize.lt_iff_toNat_lt])) (h_bound := (by grind only [USize.toNat_sub_of_le, = uset_eq_set, = size_set, USize.size_eq])) else pure acc termination_by start.toNat - stop.toNat decreasing_by grind only [USize.lt_iff_toNat_lt, USize.toNat_sub, USize.toNat_sub_of_le, USize.le_iff_toNat_le] @[inline] private unsafe def scanrMUnsafe [Monad m] (f : α → β → m β) (init : β) (as : Array α) (start := as.size) (stop := 0) : m (Array β) := scanrMFast (h_size := as.unsafe_sizeFitsUSize) f init as (start := start) (stop := stop) /-- Folds a monadic function over an array from the right, accumulating the partial results starting with `init`. The accumulated value is combined with the each element of the list in order using `f`. The optional parameters `start` and `stop` control the region of the array to be folded. Folding proceeds from `start` (exclusive) to `stop` (inclusive), so no folding occurs unless `start > stop`. By default, the entire array is folded. Examples: ```lean example example [Monad m] (f : α → β → m β) : Array.scanrM f x₀ #[a, b, c] = (do let x₁ ← f c x₀ let x₂ ← f b x₁ let x₃ ← f a x₂ pure #[x₃, x₂, x₁, x₀]) := by simp [scanrM, scanrM.loop] ``` ```lean example example [Monad m] (f : α → β → m β) : Array.scanrM f x₀ #[a, b, c] (start := 3) (stop := 1) = (do let x₁ ← f c x₀ let x₂ ← f b x₁ pure #[x₂, x₁, x₀]) := by simp [scanrM, scanrM.loop] ``` -/ @[implemented_by scanrMUnsafe] def scanrM [Monad m] (f : α → β → m β) (init : β) (as : Array α) (start := as.size) (stop := 0) : m (Array β) := let start := min start as.size loop f init as start stop (Nat.min_le_right _ _) #[] where /-- auxiliary tail-recursive function for scanrM -/ loop (f : α → β → m β) (init : β) (as : Array α) (start stop : Nat) (h_start : start ≤ as.size) (acc : Array β) : m (Array β) := do if h_gt : stop < start then let i := start - 1 let next ← f as[i] init loop f next as i stop (by omega) (acc.push init) else pure <| acc.push init |>.reverse /-- Fold a function `f` over the array from the left, returning the array of partial results. ``` scanl (· + ·) 0 #[1, 2, 3] = #[0, 1, 3, 6] ``` -/ @[inline] def scanl (f : β → α → β) (init : β) (as : Array α) (start := 0) (stop := as.size) : Array β := Id.run <| as.scanlM (pure <| f · ·) init start stop /-- Fold a function `f` over the array from the right, returning the array of partial results. ``` scanr (· + ·) 0 #[1, 2, 3] = #[6, 5, 3, 0] ``` -/ @[inline] def scanr (f : α → β → β) (init : β) (as : Array α) (start := as.size) (stop := 0) : Array β := Id.run <| as.scanrM (pure <| f · ·) init start stop end Array namespace Subarray /-- Fold a monadic function `f` over the subarray from the left, returning the list of partial results. -/ @[inline] def scanlM [Monad m] (f : β → α → m β) (init : β) (as : Subarray α) : m (Array β) := as.array.scanlM f init (start := as.start) (stop := as.stop) /-- Fold a monadic function `f` over the subarray from the right, returning the list of partial results. -/ @[inline] def scanrM [Monad m] (f : α → β → m β) (init : β) (as : Subarray α) : m (Array β) := as.array.scanrM f init (start := as.start) (stop := as.stop) /-- Fold a function `f` over the subarray from the left, returning the list of partial results. -/ @[inline] def scanl (f : β → α → β) (init : β) (as : Subarray α) : Array β := as.array.scanl f init (start := as.start) (stop := as.stop) /-- Fold a function `f` over the subarray from the right, returning the list of partial results. -/ @[inline] def scanr (f : α → β → β) (init : β) (as : Subarray α) : Array β := as.array.scanr f init (start := as.start) (stop := as.stop) /-- Check whether a subarray is empty. -/ @[inline] def isEmpty (as : Subarray α) : Bool := as.start == as.stop /-- Check whether a subarray contains a given element. -/ @[inline] def contains [BEq α] (as : Subarray α) (a : α) : Bool := as.any (· == a) /-- Remove the first element of a subarray. Returns the element and the remaining subarray, or `none` if the subarray is empty. -/ def popHead? (as : Subarray α) : Option (α × Subarray α) := if h : as.start < as.stop then let head := as.array[as.start]'(Nat.lt_of_lt_of_le h as.stop_le_array_size) let tail := ⟨{ as.internalRepresentation with start := as.start + 1 start_le_stop := Nat.le_of_lt_succ $ Nat.succ_lt_succ h }⟩ some (head, tail) else none end Subarray ================================================ FILE: Batteries/Data/Array/Init/Lemmas.lean ================================================ /- Copyright (c) 2024 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module @[expose] public section /-! While this file is currently empty, it is intended as a home for any lemmas which are required for definitions in `Batteries.Data.Array.Basic`, but which are not provided by Lean. -/ ================================================ FILE: Batteries/Data/Array/Lemmas.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Gabriel Ebner -/ module public import Batteries.Data.List.Lemmas @[expose] public section namespace Array @[deprecated forIn_toList (since := "2025-07-01")] theorem forIn_eq_forIn_toList [Monad m] (as : Array α) (b : β) (f : α → β → m (ForInStep β)) : forIn as b f = forIn as.toList b f := by cases as simp /-! ### idxOf? -/ @[grind =] theorem idxOf?_toList [BEq α] {a : α} {l : Array α} : l.toList.idxOf? a = l.idxOf? a := by rcases l with ⟨l⟩ simp /-! ### erase -/ @[deprecated (since := "2025-02-06")] alias eraseP_toArray := List.eraseP_toArray @[deprecated (since := "2025-02-06")] alias erase_toArray := List.erase_toArray @[simp, grind =] theorem toList_erase [BEq α] (l : Array α) (a : α) : (l.erase a).toList = l.toList.erase a := by rcases l with ⟨l⟩ simp @[simp] theorem size_eraseIdxIfInBounds (a : Array α) (i : Nat) : (a.eraseIdxIfInBounds i).size = if i < a.size then a.size-1 else a.size := by grind theorem toList_drop (as: Array α) (n : Nat) : (as.drop n).toList = as.toList.drop n := by simp only [drop, toList_extract, size_eq_length_toList, List.drop_eq_extract] /-! ### set -/ theorem size_set! (a : Array α) (i v) : (a.set! i v).size = a.size := by simp /-! ### map -/ /-! ### mem -/ /-! ### insertAt -/ @[deprecated (since := "2025-02-06")] alias getElem_insertIdx_lt := getElem_insertIdx_of_lt @[deprecated (since := "2025-02-06")] alias getElem_insertIdx_eq := getElem_insertIdx_self @[deprecated (since := "2025-02-06")] alias getElem_insertIdx_gt := getElem_insertIdx_of_gt /-! ### extract -/ @[simp] theorem extract_empty_of_start_eq_stop {a : Array α} : a.extract i i = #[] := by grind theorem extract_append_of_stop_le_size_left {a b : Array α} (h : j ≤ a.size) : (a ++ b).extract i j = a.extract i j := by grind theorem extract_append_of_size_left_le_start {a b : Array α} (h : a.size ≤ i) : (a ++ b).extract i j = b.extract (i - a.size) (j - a.size) := by rw [extract_append]; grind theorem extract_eq_of_size_le_stop {a : Array α} (h : a.size ≤ j) : a.extract i j = a.extract i := by grind ================================================ FILE: Batteries/Data/Array/Match.lean ================================================ /- Copyright (c) 2023 F. G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: F. G. Dorais -/ module @[expose] public section namespace Array /-- Prefix table for the Knuth-Morris-Pratt matching algorithm This is an array of the form `t = [(x₀,n₀), (x₁,n₁), (x₂, n₂), ...]` where for each `i`, `nᵢ` is the length of the longest proper prefix of `xs = [x₀,x₁,...,xᵢ]` which is also a suffix of `xs`. -/ structure PrefixTable (α : Type _) extends Array (α × Nat) where /-- Validity condition to help with termination proofs -/ valid : (h : i < toArray.size) → toArray[i].2 ≤ i instance : Inhabited (PrefixTable α) where default := ⟨#[], nofun⟩ /-- Returns the size of the prefix table -/ abbrev PrefixTable.size (t : PrefixTable α) := t.toArray.size /-- Transition function for the KMP matcher Assuming we have an input `xs` with a suffix that matches the pattern prefix `t.pattern[:len]` where `len : Fin (t.size+1)`. Then `xs.push x` has a suffix that matches the pattern prefix `t.pattern[:t.step x len]`. If `len` is as large as possible then `t.step x len` will also be as large as possible. -/ def PrefixTable.step [BEq α] (t : PrefixTable α) (x : α) : Fin (t.size+1) → Fin (t.size+1) | ⟨k, hk⟩ => let cont := fun () => match k with | 0 => ⟨0, Nat.zero_lt_succ _⟩ | k + 1 => have h2 : k < t.size := Nat.lt_of_succ_lt_succ hk let k' := t.toArray[k].2 have hk' : k' < k + 1 := Nat.lt_succ_of_le (t.valid h2) step t x ⟨k', Nat.lt_trans hk' hk⟩ if hsz : k < t.size then if x == t.toArray[k].1 then ⟨k+1, Nat.succ_lt_succ hsz⟩ else cont () else cont () termination_by k => k.val /-- Extend a prefix table by one element If `t` is the prefix table for `xs` then `t.extend x` is the prefix table for `xs.push x`. -/ def PrefixTable.extend [BEq α] (t : PrefixTable α) (x : α) : PrefixTable α where toArray := t.toArray.push (x, t.step x ⟨t.size, Nat.lt_succ_self _⟩) valid _ := by rw [Array.getElem_push] split · exact t.valid .. · next h => exact Nat.le_trans (Nat.lt_succ_iff.1 <| Fin.isLt ..) (Nat.not_lt.1 h) /-- Make prefix table from a pattern array -/ def mkPrefixTable [BEq α] (xs : Array α) : PrefixTable α := xs.foldl (·.extend) default /-- Make prefix table from a pattern stream -/ partial def mkPrefixTableOfStream [BEq α] [Std.Stream σ α] (stream : σ) : PrefixTable α := loop default stream where /-- Inner loop for `mkPrefixTableOfStream` -/ loop (t : PrefixTable α) (stream : σ) := match Stream.next? stream with | none => t | some (x, stream) => loop (t.extend x) stream /-- KMP matcher structure -/ structure Matcher (α) where /-- Prefix table for the pattern -/ table : PrefixTable α /-- Current longest matching prefix -/ state : Fin (table.size + 1) := 0 /-- Make a KMP matcher for a given pattern array -/ def Matcher.ofArray [BEq α] (pat : Array α) : Matcher α where table := mkPrefixTable pat /-- Make a KMP matcher for a given a pattern stream -/ def Matcher.ofStream [BEq α] [Std.Stream σ α] (pat : σ) : Matcher α where table := mkPrefixTableOfStream pat /-- Find next match from a given stream Runs the stream until it reads a sequence that matches the sought pattern, then returns the stream state at that point and an updated matcher state. -/ partial def Matcher.next? [BEq α] [Std.Stream σ α] (m : Matcher α) (stream : σ) : Option (σ × Matcher α) := match Stream.next? stream with | none => none | some (x, stream) => let state := m.table.step x m.state if state = m.table.size then some (stream, { m with state }) else next? { m with state } stream namespace Matcher open Std Std.Iterators /-- Iterator transformer for KMP matcher. -/ protected structure Iterator (σ n α) [BEq α] (m : Matcher α) [Iterator σ n α] where /-- Inner iterator. -/ inner : IterM (α := σ) n α /-- Matcher state. -/ state : Fin (m.table.size + 1) := 0 /-- Implementation datail for `Matcher.Iterator`. -/ def modifyStep [BEq α] (m : Matcher α) [Iterator σ n α] (it : IterM (α := m.Iterator σ n α) n σ) : it.internalState.inner.Step (α := σ) → IterStep (IterM (α := m.Iterator σ n α) n σ) σ | .done _ => .done | .skip it' _ => .skip ⟨{it.internalState with inner := it'}⟩ | .yield it' x _ => let state := m.table.step x m.state if state = m.table.size then .yield ⟨{inner := it', state := state}⟩ it'.internalState else .skip ⟨{inner := it', state := state}⟩ instance [Monad n] [BEq α] (m : Matcher α) [Iterator σ n α] : Iterator (m.Iterator σ n α) n σ where IsPlausibleStep it step := ∃ step', m.modifyStep it step' = step step it := it.internalState.inner.step >>= fun step => pure (.deflate ⟨m.modifyStep _ _, step.inflate, rfl⟩) private def finitenessRelation [Monad n] [BEq α] (m : Matcher α) [Iterator σ n α] [Finite σ n] : FinitenessRelation (m.Iterator σ n α) n where Rel := InvImage IterM.IsPlausibleSuccessorOf fun it => it.internalState.inner wf := InvImage.wf _ Finite.wf subrelation {it it'} h := by obtain ⟨_, hsucc, step, rfl⟩ := h simp only [IterM.Step] at step cases step with simp only [IterStep.successor, modifyStep, reduceCtorEq] at hsucc | skip => cases hsucc apply IterM.isPlausibleSuccessorOf_of_skip assumption | yield => split at hsucc · next heq => cases hsucc split at heq · cases heq apply IterM.isPlausibleSuccessorOf_of_yield assumption · contradiction · next heq => cases hsucc split at heq · contradiction · cases heq apply IterM.isPlausibleSuccessorOf_of_yield assumption · contradiction instance [Monad n] [BEq α] (m : Matcher α) [Iterator σ n α] [inst : Finite σ n] : Finite (m.Iterator σ n α) n (β := σ) := .of_finitenessRelation m.finitenessRelation end Matcher end Array ================================================ FILE: Batteries/Data/Array/Merge.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module @[expose] public section namespace Array /-- `O(|xs| + |ys|)`. Merge arrays `xs` and `ys`. If the arrays are sorted according to `lt`, then the result is sorted as well. If two (or more) elements are equal according to `lt`, they are preserved. -/ def merge (lt : α → α → Bool) (xs ys : Array α) : Array α := go (Array.mkEmpty (xs.size + ys.size)) 0 0 where /-- Auxiliary definition for `merge`. -/ go (acc : Array α) (i j : Nat) : Array α := if hi : i ≥ xs.size then acc ++ ys[j:] else if hj : j ≥ ys.size then acc ++ xs[i:] else let x := xs[i] let y := ys[j] if lt x y then go (acc.push x) (i + 1) j else go (acc.push y) i (j + 1) termination_by xs.size + ys.size - (i + j) -- We name `ord` so it can be provided as a named argument. set_option linter.unusedVariables.funArgs false in /-- `O(|xs| + |ys|)`. Merge arrays `xs` and `ys`, which must be sorted according to `compare` and must not contain duplicates. Equal elements are merged using `merge`. If `merge` respects the order (i.e. for all `x`, `y`, `y'`, `z`, if `x < y < z` and `x < y' < z` then `x < merge y y' < z`) then the resulting array is again sorted. -/ def mergeDedupWith [ord : Ord α] (xs ys : Array α) (merge : α → α → α) : Array α := go (Array.mkEmpty (xs.size + ys.size)) 0 0 where /-- Auxiliary definition for `mergeDedupWith`. -/ go (acc : Array α) (i j : Nat) : Array α := if hi : i ≥ xs.size then acc ++ ys[j:] else if hj : j ≥ ys.size then acc ++ xs[i:] else let x := xs[i] let y := ys[j] match compare x y with | .lt => go (acc.push x) (i + 1) j | .gt => go (acc.push y) i (j + 1) | .eq => go (acc.push (merge x y)) (i + 1) (j + 1) termination_by xs.size + ys.size - (i + j) /-- `O(|xs| + |ys|)`. Merge arrays `xs` and `ys`, which must be sorted according to `compare` and must not contain duplicates. If an element appears in both `xs` and `ys`, only one copy is kept. -/ @[inline] def mergeDedup [ord : Ord α] (xs ys : Array α) : Array α := mergeDedupWith (ord := ord) xs ys fun x _ => x set_option linter.unusedVariables false in /-- `O(|xs| * |ys|)`. Merge `xs` and `ys`, which do not need to be sorted. Elements which occur in both `xs` and `ys` are only added once. If `xs` and `ys` do not contain duplicates, then neither does the result. -/ def mergeUnsortedDedup [eq : BEq α] (xs ys : Array α) : Array α := -- Ideally we would check whether `xs` or `ys` have spare capacity, to prevent -- copying if possible. But Lean arrays don't expose their capacity. if xs.size < ys.size then go ys xs else go xs ys where /-- Auxiliary definition for `mergeUnsortedDedup`. -/ @[inline] go (xs ys : Array α) := let xsSize := xs.size ys.foldl (init := xs) fun xs y => if xs.any (· == y) (stop := xsSize) then xs else xs.push y -- We name `eq` so it can be provided as a named argument. set_option linter.unusedVariables.funArgs false in /-- `O(|xs|)`. Replace each run `[x₁, ⋯, xₙ]` of equal elements in `xs` with `f ⋯ (f (f x₁ x₂) x₃) ⋯ xₙ`. -/ def mergeAdjacentDups [eq : BEq α] (f : α → α → α) (xs : Array α) : Array α := if h : 0 < xs.size then go (mkEmpty xs.size) 1 xs[0] else xs where /-- Auxiliary definition for `mergeAdjacentDups`. -/ go (acc : Array α) (i : Nat) (hd : α) := if h : i < xs.size then let x := xs[i] if x == hd then go acc (i + 1) (f hd x) else go (acc.push hd) (i + 1) x else acc.push hd termination_by xs.size - i /-- `O(|xs|)`. Deduplicate a sorted array. The array must be sorted with to an order which agrees with `==`, i.e. whenever `x == y` then `compare x y == .eq`. -/ def dedupSorted [eq : BEq α] (xs : Array α) : Array α := xs.mergeAdjacentDups (eq := eq) fun x _ => x /-- `O(|xs| log |xs|)`. Sort and deduplicate an array. -/ def sortDedup [ord : Ord α] (xs : Array α) : Array α := have := ord.toBEq dedupSorted <| xs.qsort (compare · · |>.isLT) end Array ================================================ FILE: Batteries/Data/Array/Monadic.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Gabriel Ebner -/ module public import Batteries.Classes.SatisfiesM public import Batteries.Util.ProofWanted import all Init.Data.Array.Basic -- for unfolding `modifyM` @[expose] public section /-! # Results about monadic operations on `Array`, in terms of `SatisfiesM`. The pure versions of these theorems are proved in `Batteries.Data.Array.Lemmas` directly, in order to minimize dependence on `SatisfiesM`. -/ namespace Array theorem SatisfiesM_foldlM [Monad m] [LawfulMonad m] {as : Array α} {init : β} {motive : Nat → β → Prop} {f : β → α → m β} (h0 : motive 0 init) (hf : ∀ i : Fin as.size, ∀ b, motive i.1 b → SatisfiesM (motive (i.1 + 1)) (f b as[i])) : SatisfiesM (motive as.size) (as.foldlM f init) := by let rec go {i j b} (h₁ : j ≤ as.size) (h₂ : as.size ≤ i + j) (H : motive j b) : SatisfiesM (motive as.size) (foldlM.loop f as as.size (Nat.le_refl _) i j b) := by unfold foldlM.loop; split · next hj => split · cases Nat.not_le_of_gt (by simp [hj]) h₂ · exact (hf ⟨j, hj⟩ b H).bind fun _ => go hj (by rwa [Nat.succ_add] at h₂) · next hj => exact Nat.le_antisymm h₁ (Nat.ge_of_not_lt hj) ▸ .pure H simp [foldlM]; exact go (Nat.zero_le _) (Nat.le_refl _) h0 theorem SatisfiesM_mapM [Monad m] [LawfulMonad m] {as : Array α} {f : α → m β} {motive : Nat → Prop} {p : Fin as.size → β → Prop} (h0 : motive 0) (hs : ∀ i, motive i.1 → SatisfiesM (p i · ∧ motive (i + 1)) (f as[i])) : SatisfiesM (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p ⟨i, h⟩ arr[i]) (Array.mapM f as) := by rw [mapM_eq_foldlM] refine SatisfiesM_foldlM (m := m) (β := Array β) (motive := fun i arr => motive i ∧ arr.size = i ∧ ∀ i h2, p i (arr[i.1]'h2)) ?z ?s |>.imp fun ⟨h₁, eq, h₂⟩ => ⟨h₁, eq, fun _ _ => h₂ ..⟩ · case z => exact ⟨h0, rfl, nofun⟩ · case s => intro ⟨i, hi⟩ arr ⟨ih₁, eq, ih₂⟩ refine (hs _ ih₁).map fun ⟨h₁, h₂⟩ => ⟨h₂, by simp [eq], fun j hj => ?_⟩ simp [getElem_push] at hj ⊢; split; {apply ih₂} cases j; cases (Nat.le_or_eq_of_le_succ hj).resolve_left ‹_›; cases eq; exact h₁ theorem SatisfiesM_mapM' [Monad m] [LawfulMonad m] {as : Array α} {f : α → m β} {p : Fin as.size → β → Prop} (hs : ∀ i, SatisfiesM (p i) (f as[i])) : SatisfiesM (fun arr => ∃ eq : arr.size = as.size, ∀ i h, p ⟨i, h⟩ arr[i]) (Array.mapM f as) := (SatisfiesM_mapM (motive := fun _ => True) trivial (fun _ h => (hs _).imp (⟨·, h⟩))).imp (·.2) theorem size_mapM [Monad m] [LawfulMonad m] (f : α → m β) (as : Array α) : SatisfiesM (fun arr => arr.size = as.size) (Array.mapM f as) := (SatisfiesM_mapM' (fun _ => .trivial)).imp (·.1) theorem SatisfiesM_anyM [Monad m] [LawfulMonad m] {p : α → m Bool} {as : Array α} (hstart : start ≤ min stop as.size) (tru : Prop) (fal : Nat → Prop) (h0 : fal start) (hp : ∀ i : Fin as.size, i.1 < stop → fal i.1 → SatisfiesM (bif · then tru else fal (i + 1)) (p as[i])) : SatisfiesM (fun res => bif res then tru else fal (min stop as.size)) (anyM p as start stop) := by let rec go {stop j} (hj' : j ≤ stop) (hstop : stop ≤ as.size) (h0 : fal j) (hp : ∀ i : Fin as.size, i.1 < stop → fal i.1 → SatisfiesM (bif · then tru else fal (i + 1)) (p as[i])) : SatisfiesM (fun res => bif res then tru else fal stop) (anyM.loop p as stop hstop j) := by unfold anyM.loop; split · next hj => exact (hp ⟨j, Nat.lt_of_lt_of_le hj hstop⟩ hj h0).bind fun | true, h => .pure h | false, h => go hj hstop h hp · next hj => exact .pure <| Nat.le_antisymm hj' (Nat.ge_of_not_lt hj) ▸ h0 termination_by stop - j simp only [Array.anyM_eq_anyM_loop] exact go hstart _ h0 fun i hi => hp i <| Nat.lt_of_lt_of_le hi <| Nat.min_le_left .. theorem SatisfiesM_anyM_iff_exists [Monad m] [LawfulMonad m] {p : α → m Bool} {as : Array α} {q : Fin as.size → Prop} (hp : ∀ i : Fin as.size, start ≤ i.1 → i.1 < stop → SatisfiesM (· = true ↔ q i) (p as[i])) : SatisfiesM (fun res => res = true ↔ ∃ i : Fin as.size, start ≤ i.1 ∧ i.1 < stop ∧ q i) (anyM p as start stop) := by cases Nat.le_total start (min stop as.size) with | inl hstart => refine (SatisfiesM_anyM hstart (fal := fun j => start ≤ j ∧ ¬ ∃ i : Fin as.size, start ≤ i.1 ∧ i.1 < j ∧ q i) (tru := ∃ i : Fin as.size, start ≤ i.1 ∧ i.1 < stop ∧ q i) ?_ ?_).imp ?_ · exact ⟨Nat.le_refl _, fun ⟨i, h₁, h₂, _⟩ => (Nat.not_le_of_gt h₂ h₁).elim⟩ · refine fun i h₂ ⟨h₁, h₃⟩ => (hp _ h₁ h₂).imp fun hq => ?_ unfold cond; split <;> simp at hq · exact ⟨_, h₁, h₂, hq⟩ · refine ⟨Nat.le_succ_of_le h₁, h₃.imp fun ⟨j, h₃, h₄, h₅⟩ => ⟨j, h₃, ?_, h₅⟩⟩ refine Nat.lt_of_le_of_ne (Nat.le_of_lt_succ h₄) fun e => hq (Fin.eq_of_val_eq e ▸ h₅) · intro | true, h => simp only [true_iff]; exact h | false, h => simp only [false_iff, reduceCtorEq] exact h.2.imp fun ⟨j, h₁, h₂, hq⟩ => ⟨j, h₁, Nat.lt_min.2 ⟨h₂, j.2⟩, hq⟩ | inr hstart => rw [anyM_stop_le_start (h := hstart)] refine .pure ?_; simp; intro j h₁ h₂ cases Nat.not_lt.2 (Nat.le_trans hstart h₁) (Nat.lt_min.2 ⟨h₂, j.2⟩) theorem SatisfiesM_foldrM [Monad m] [LawfulMonad m] {as : Array α} {init : β} {motive : Nat → β → Prop} {f : α → β → m β} (h0 : motive as.size init) (hf : ∀ i : Fin as.size, ∀ b, motive (i.1 + 1) b → SatisfiesM (motive i.1) (f as[i] b)) : SatisfiesM (motive 0) (as.foldrM f init) := by let rec go {i b} (hi : i ≤ as.size) (H : motive i b) : SatisfiesM (motive 0) (foldrM.fold f as 0 i hi b) := by unfold foldrM.fold; simp; split · next hi => exact .pure (hi ▸ H) · next hi => split; {simp at hi} · next i hi' => exact (hf ⟨i, hi'⟩ b H).bind fun _ => go _ simp [foldrM]; split; {exact go _ h0} · next h => exact .pure (Nat.eq_zero_of_not_pos h ▸ h0) theorem SatisfiesM_mapFinIdxM [Monad m] [LawfulMonad m] {as : Array α} {f : (i : Nat) → α → i < as.size → m β} {motive : Nat → Prop} {p : (i : Nat) → β → i < as.size → Prop} (h0 : motive 0) (hs : ∀ i h, motive i → SatisfiesM (p i · h ∧ motive (i + 1)) (f i as[i] h)) : SatisfiesM (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p i arr[i] h) (Array.mapFinIdxM as f) := by let rec go {bs i j h} (h₁ : j = bs.size) (h₂ : ∀ i h h', p i bs[i] h) (hm : motive j) : SatisfiesM (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p i arr[i] h) (Array.mapFinIdxM.map as f i j h bs) := by induction i generalizing j bs with simp [mapFinIdxM.map] | zero => have := (Nat.zero_add _).symm.trans h exact .pure ⟨this ▸ hm, h₁ ▸ this, fun _ _ => h₂ ..⟩ | succ i ih => refine (hs _ _ (by exact hm)).bind fun b hb => ih (by simp [h₁]) (fun i hi hi' => ?_) hb.2 simp at hi'; simp [getElem_push]; split · next h => exact h₂ _ _ h · next h => cases h₁.symm ▸ (Nat.le_or_eq_of_le_succ hi').resolve_left h; exact hb.1 simp [mapFinIdxM]; exact go rfl nofun h0 theorem SatisfiesM_mapIdxM [Monad m] [LawfulMonad m] {as : Array α} {f : Nat → α → m β} {p : (i : Nat) → β → i < as.size → Prop} {motive : Nat → Prop} (h0 : motive 0) (hs : ∀ i h, motive i → SatisfiesM (p i · h ∧ motive (i + 1)) (f i as[i])) : SatisfiesM (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p i arr[i] h) (as.mapIdxM f) := SatisfiesM_mapFinIdxM h0 hs theorem size_mapFinIdxM [Monad m] [LawfulMonad m] (as : Array α) (f : (i : Nat) → α → i < as.size → m β) : SatisfiesM (fun arr => arr.size = as.size) (Array.mapFinIdxM as f) := (SatisfiesM_mapFinIdxM (motive := fun _ => True) trivial (fun _ _ _ => .of_true fun _ => ⟨trivial, trivial⟩)).imp (·.2.1) theorem size_mapIdxM [Monad m] [LawfulMonad m] (as : Array α) (f : Nat → α → m β) : SatisfiesM (fun arr => arr.size = as.size) (Array.mapIdxM f as) := size_mapFinIdxM _ _ theorem size_modifyM [Monad m] [LawfulMonad m] (as : Array α) (i : Nat) (f : α → m α) : SatisfiesM (·.size = as.size) (as.modifyM i f) := by unfold modifyM; split · exact .bind_pre <| .of_true fun _ => .pure <| by simp only [size_set] · exact .pure rfl end Array ================================================ FILE: Batteries/Data/Array/Pairwise.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Tactic.Alias @[expose] public section namespace Array /-- `Pairwise R as` means that all the elements of the array `as` are `R`-related to all elements with larger indices. `Pairwise R #[1, 2, 3] ↔ R 1 2 ∧ R 1 3 ∧ R 2 3` For example `as.Pairwise (· ≠ ·)` asserts that `as` has no duplicates, `as.Pairwise (· < ·)` asserts that `as` is strictly sorted and `as.Pairwise (· ≤ ·)` asserts that `as` is weakly sorted. -/ def Pairwise (R : α → α → Prop) (as : Array α) : Prop := as.toList.Pairwise R theorem pairwise_iff_getElem {as : Array α} : as.Pairwise R ↔ ∀ (i j : Nat) (_ : i < as.size) (_ : j < as.size), i < j → R as[i] as[j] := by unfold Pairwise; simp [List.pairwise_iff_getElem, length_toList] @[deprecated (since := "2025-02-19")] alias pairwise_iff_get := pairwise_iff_getElem instance (R : α → α → Prop) [DecidableRel R] (as) : Decidable (Pairwise R as) := have : (∀ (j : Fin as.size) (i : Fin j.val), R as[i.val] (as[j.val])) ↔ Pairwise R as := by rw [pairwise_iff_getElem] constructor · intro h i j _ hj hlt; exact h ⟨j, hj⟩ ⟨i, hlt⟩ · intro h ⟨j, hj⟩ ⟨i, hlt⟩; exact h i j (Nat.lt_trans hlt hj) hj hlt decidable_of_iff _ this @[grind ←] theorem pairwise_empty : #[].Pairwise R := by unfold Pairwise; exact List.Pairwise.nil @[grind ←] theorem pairwise_singleton (R : α → α → Prop) (a) : #[a].Pairwise R := by unfold Pairwise; exact List.pairwise_singleton .. @[grind =] theorem pairwise_pair : #[a, b].Pairwise R ↔ R a b := by unfold Pairwise; exact List.pairwise_pair @[grind =] theorem pairwise_append {as bs : Array α} : (as ++ bs).Pairwise R ↔ as.Pairwise R ∧ bs.Pairwise R ∧ (∀ x ∈ as, ∀ y ∈ bs, R x y) := by unfold Pairwise; simp [← mem_toList_iff, toList_append, ← List.pairwise_append] @[grind =] theorem pairwise_push {as : Array α} : (as.push a).Pairwise R ↔ as.Pairwise R ∧ (∀ x ∈ as, R x a) := by unfold Pairwise simp [← mem_toList_iff, toList_push, List.pairwise_append] @[grind ←] theorem pairwise_extract {as : Array α} (h : as.Pairwise R) (start stop) : (as.extract start stop).Pairwise R := by simp only [pairwise_iff_getElem, getElem_extract, size_extract] at h ⊢ intro _ _ _ _ hlt apply h exact Nat.add_lt_add_left hlt start ================================================ FILE: Batteries/Data/Array/Scan.lean ================================================ /- Copyright (c) 2026 Chad Sharp. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Chad Sharp -/ module public import Batteries.Data.Array.Basic public import Batteries.Data.Array.Lemmas import Batteries.Data.List.Scan import Batteries.Data.List.Lemmas public section /-! # Array Prove basic results about `Array.scanl`, `Array.scanr`, `Array.scanlM` and `Array.scanrM`. -/ namespace Array set_option backward.isDefEq.respectTransparency false in theorem scanlM.loop_toList [Monad m] [LawfulMonad m] {f : β → α → m β} {stop : Nat} (h : stop ≤ as.size) : Array.toList <$> scanlM.loop f init as start stop h acc = return acc.toList ++ (← as.toList.drop start |>.take (stop - start) |>.scanlM f init) := by induction h_ind : stop - start generalizing start acc init with | zero => unfold scanlM.loop simp [show ¬(start < stop) by omega, ← Array.toList_push] | succ n ih => unfold scanlM.loop rw [List.drop_eq_getElem_cons (by simp; omega)] simp [show start < stop by omega, show stop - (start + 1) = n by omega, ih] theorem scanlM_eq_scanlM_toList [Monad m] [LawfulMonad m] {f : β → α → m β} {as : Array α} : as.scanlM f init = List.toArray <$> as.toList.scanlM f init := by apply map_toList_inj.mp simp [scanlM, Array.scanlM.loop_toList, ←Array.length_toList] @[simp, grind =] theorem toList_scanlM [Monad m] [LawfulMonad m] {f : β → α → m β} {as : Array α} : toList <$> as.scanlM f init = as.toList.scanlM f init := by simp [scanlM_eq_scanlM_toList] theorem scanrM.loop_toList [Monad m] [LawfulMonad m] {f : α → β → m β} {start : Nat} {h : start ≤ as.size} : Array.toList <$> scanrM.loop f init as start stop h acc = return (← as.toList.drop stop |>.take (start - stop) |>.scanrM f init) ++ acc.toList.reverse := by induction h_ind : start - stop generalizing stop acc init start with | zero => simp [scanrM.loop, show ¬ stop < start by omega] | succ n ih => unfold scanrM.loop simp_all only [bind_pure_comp, show stop < start by omega, ↓reduceDIte] simp only [map_bind] conv => lhs arg 2 ext a rw [ih (start := start - 1) (stop := stop) (acc := acc.push init) (by omega)] simp only [List.scanrM_eq_scanlM_reverse] have h_take := List.take_succ_drop (l := as.toList) (n := n) (stop := stop) (by simp; omega) simp only [h_take, List.reverse_append, List.reverse_singleton, List.singleton_append, List.scanlM_cons, map_bind, show stop + n = start - 1 by omega] apply bind_congr simp_all theorem scanrM_eq_scanrM_toList [Monad m] [LawfulMonad m] {f : α → β → m β} {as : Array α} : as.scanrM f init = List.toArray <$> as.toList.scanrM f init := by apply map_toList_inj.mp simp [scanrM, Array.scanrM.loop_toList, ← Array.length_toList] @[simp, grind =] theorem toList_scanrM [Monad m] [LawfulMonad m] {f : α → β → m β} {as : Array α} : toList <$> as.scanrM f init = as.toList.scanrM f init := by simp [scanrM_eq_scanrM_toList] theorem scanlM_extract [Monad m] [LawfulMonad m] {f : β → α → m β} {as : Array α} : (as.extract start stop).scanlM f init = as.scanlM f init start stop := by rw (occs := [2]) [scanlM] apply map_toList_inj.mp rw [scanlM.loop_toList, scanlM_eq_scanlM_toList, bind_pure_comp] simp_all only [toList_extract, Functor.map_map, id_map', List.nil_append_fun, id_map] grind [List.take_eq_take_iff, List.drop_eq_drop_iff] theorem scanrM_extract [Monad m] [LawfulMonad m] {f : α → β → m β} {as : Array α} : (as.extract stop start).scanrM f init = as.scanrM f init start stop := by rw (occs := [2]) [scanrM] apply map_toList_inj.mp rw [scanrM.loop_toList, scanrM_eq_scanrM_toList, bind_pure_comp] simp_all only [toList_extract, Functor.map_map, id_map', List.reverse_nil, List.append_nil] grind [List.take_eq_take_iff, List.drop_eq_drop_iff] @[simp, grind =] theorem scanlM_empty [Monad m] {f : β → α → m β} {start stop : Nat} : #[].scanlM f init start stop = pure #[init] := by simp [scanlM, scanlM.loop] @[grind =] theorem scanrM_empty [Monad m] {f : α → β → m β} {start stop : Nat} : #[].scanrM f init start stop = pure #[init] := by simp [scanrM, scanrM.loop] theorem scanlM_reverse [Monad m] [LawfulMonad m] {f : β → α → m β} {as : Array α} : as.reverse.scanlM f init = Array.reverse <$> (as.scanrM (flip f) init) := by simp only [scanlM_eq_scanlM_toList, scanrM_eq_scanrM_toList] simp @[simp] theorem scanlM_pure [Monad m] [LawfulMonad m] {f : β → α → β} {as : Array α} : as.scanlM (m := m) (pure <| f · ·) init = pure (as.scanl f init) := by simp only [scanl, scanlM_eq_scanlM_toList, scanlM_eq_scanlM_toList, List.scanlM_pure, map_pure] rfl @[simp] theorem scanrM_pure [Monad m] [LawfulMonad m] {f : α → β → β} {as : Array α} : as.scanrM (m := m) (pure <| f · ·) init = pure (as.scanr f init) := by simp only [scanr, scanrM_eq_scanrM_toList, scanrM_eq_scanrM_toList, List.scanrM_pure, map_pure] rfl @[simp] theorem idRun_scanlM {f : β → α → Id β} {as : Array α} : (as.scanlM f init).run = as.scanl (f · · |>.run) init := scanlM_pure @[simp] theorem idRun_scanrM {f : α → β → Id β} {as : Array α} : (as.scanrM f init).run = as.scanr (f · · |>.run) init := scanrM_pure @[grind =] theorem scanlM_map [Monad m] [LawfulMonad m] {f : α₁ → α₂ } {g: β → α₂ → m β} {as : Array α₁} : (as.map f).scanlM g init = as.scanlM (g · <| f ·) init := by simp only [scanlM_eq_scanlM_toList, toList_map, List.scanlM_map] @[grind =] theorem scanrM_map [Monad m] [LawfulMonad m] {f : α₁ → α₂ } {g: α₂ → β → m β} {as : Array α₁} : (as.map f).scanrM g init = as.scanrM (fun a b => g (f a) b) init := by simp only [scanrM_eq_scanrM_toList, toList_map, List.scanrM_map] /-- ### Array.scanl -/ theorem scanl_eq_scanlM {f : β → α → β} {as: Array α} : as.scanl f init = (as.scanlM (m := Id) (pure <| f · ·) init).run := by simp theorem scanl_eq_scanl_toList {f: β → α → β} {as : Array α} : as.scanl f init = (as.toList.scanl f init).toArray := by simp only [scanl_eq_scanlM, scanlM_eq_scanlM_toList] simp [List.idRun_scanlM] @[simp, grind =] theorem toList_scanl {f : β → α → β} {as: Array α} : (as.scanl f init).toList = as.toList.scanl f init := by rw [scanl_eq_scanl_toList] @[simp] theorem size_scanl {f : β → α → β} (init : β) (as : Array α) : size (scanl f init as) = as.size + 1 := by grind [size_eq_length_toList] grind_pattern size_scanl => scanl f init as @[grind =] theorem scanl_empty {f : β → α → β} (init : β) : scanl f init #[] = #[init] := by apply toList_inj.mp grind @[grind =] theorem scanl_singleton {f : β → α → β} : scanl f init #[a] = #[init, f init a] := by apply toList_inj.mp grind @[simp] theorem scanl_ne_empty {f : β → α → β} : scanl f init as ≠ #[] := by grind @[simp] theorem scanl_eq_singleton_iff {f : β → α → β} (c : β) : scanl f init as = #[c] ↔ c = init ∧ as = #[] := by grind @[simp, grind =] theorem getElem_scanl {f : β → α → β} {as: Array α} (h : i < (as.scanl f init).size) : (as.scanl f init)[i]'h = foldl f init (as.take i) := by simp only [scanl_eq_scanl_toList, ← foldl_toList] simp @[grind =] theorem getElem?_scanl {f : β → α → β} : (scanl f a l)[i]? = if i ≤ l.size then some (foldl f a (l.take i)) else none := by grind @[grind =] theorem take_scanl {f : β → α → β} (init : β) (as : Array α) : (scanl f init as).take (i + 1) = scanl f init (as.take i) := by grind theorem getElem?_scanl_zero {f : β → α → β} : (scanl f init as)[0]? = some init := by simp theorem getElem_scanl_zero {f : β → α → β} : (scanl f init as)[0] = init := by simp theorem getElem?_succ_scanl {f : β → α → β} : (scanl f init as)[i + 1]? = (scanl f init as)[i]?.bind fun x => as[i]?.map fun y => f x y := by simp [scanl_eq_scanl_toList, List.getElem?_succ_scanl] theorem getElem_succ_scanl {f : β → α → β} (h : i + 1 < (scanl f b as).size) : (as.scanl f b)[i + 1] = f (as.scanl f b)[i] (as[i]'(by grind)) := by simp only [scanl_eq_scanl_toList, List.getElem_toArray] grind [List.getElem_succ_scanl] @[grind =] theorem scanl_push {f : β → α → β} {init: β} {a : α} {as : Array α} : (as.push a).scanl f init = (as.scanl f init).push (f (as.foldl f init) a) := by simp only [scanl_eq_scanl_toList] simp [List.scanl_append] @[grind =] theorem scanl_map {f : γ → β → γ} {g : α → β} (init : γ) (as : Array α) : scanl f init (as.map g) = scanl (f · <| g ·) init as := by simp only [scanl_eq_scanl_toList, toList_map, List.scanl_map] @[simp, grind =] theorem back_scanl {f : β → α → β} {as : Array α} : (as.scanl f init).back = as.foldl f init := by simp [Array.back_eq_getElem] theorem back_scanl? {f : β → α → β} {as : Array α} : (as.scanl f init).back? = some (as.foldl f init) := by simp [Array.back?_eq_getElem?] /-! ### Array.scanr -/ theorem scanr_eq_scanrM {f : α → β → β} {as : Array α} : as.scanr f init = (as.scanrM (m := Id) (pure <| f · ·) init).run := by simp theorem scanr_eq_scanr_toList {f : α → β → β} {as : Array α} : as.scanr f init = (as.toList.scanr f init).toArray := by simp only [scanr_eq_scanrM, scanrM_eq_scanrM_toList] simp [List.idRun_scanrM] @[simp, grind =] theorem toList_scanr {f : α → β → β} {as : Array α} : (as.scanr f init).toList = as.toList.scanr f init := by rw [scanr_eq_scanr_toList] @[simp] theorem size_scanr {f : α → β → β} (init : β) (as : Array α) : size (as.scanr f init) = as.size + 1 := by grind [size_eq_length_toList] grind_pattern size_scanr => scanr f init as @[grind =] theorem scanr_empty {f : α → β → β} {init: β} : #[].scanr f init = #[init] := by apply toList_inj.mp grind @[simp] theorem scanr_ne_empty {f : α → β → β} {as : Array α} : as.scanr f init ≠ #[] := by grind @[grind =] theorem scanr_push {f : α → β → β} {as : Array α} : (as.push a).scanr f init = (as.scanr f (f a init)).push init := by apply toList_inj.mp grind @[simp, grind =] theorem back_scanr {f : α → β → β} {as : Array α} : (as.scanr f init).back = init := by simp [←getLast_toList, List.getLast_scanr] theorem back?_scanr {f : α → β → β} {as : Array α} : (as.scanr f init).back? = some init := by simp [←getLast?_toList, List.getLast?_scanr] @[simp, grind =] theorem getElem_scanr {f : α → β → β} (h : i < (scanr f b l).size) : (scanr f b l)[i] = foldr f b (l.drop i) := by simp only [← foldr_toList, scanr_eq_scanr_toList] grind [toList_drop] @[grind =] theorem getElem?_scanr {f : α → β → β} : (scanr f b as)[i]? = if i < as.size + 1 then some (foldr f b (as.drop i)) else none := by grind theorem getElem_scanr_zero {f : α → β → β} : (scanr f init as)[0] = as.foldr f init := by simp theorem getElem?_scanr_zero {f : α → β → β} : (scanr f init as)[0]? = some (as.foldr f init ) := by simp @[grind =] theorem scanr_map {f : β → γ → γ} {g : α → β} (init : γ) (as : Array α) : scanr f init (as.map g) = scanr (fun x acc => f (g x) acc) init as := by simp only [scanr_eq_scanr_toList, toList_map, List.scanr_map] @[grind =] theorem scanl_reverse {f : β → α → β} {as : Array α} : scanl f init as.reverse = reverse (scanr (flip f) init as) := by apply toList_inj.mp simp only [scanl_eq_scanl_toList, scanr_eq_scanr_toList] simp theorem scanl_extract {f : β → α → β} {as : Array α} : (as.extract start stop).scanl f init = as.scanl f init start stop := by unfold scanl rw [scanlM_extract] theorem scanr_extract {f : α → β → β} {as : Array α} : (as.extract stop start).scanr f init = as.scanr f init start stop := by unfold scanr rw [scanrM_extract] end Array namespace List theorem toArray_scanlM [Monad m] [LawfulMonad m] {f : β → α → m β} {as : List α} : toArray <$> as.scanlM f init = as.toArray.scanlM f init := by rw [← Array.toList_scanlM] simp theorem toArray_scanrM [Monad m] [LawfulMonad m] {f : α → β → m β} {as : List α} : toArray <$> as.scanrM f init = as.toArray.scanrM f init := by rw [← Array.toList_scanrM] simp theorem toArray_scanl {f : β → α → β} {as : List α} : (as.scanl f init).toArray = as.toArray.scanl f init := by rw [← Array.toList_scanl] theorem toArray_scanr {f : α → β → β} {as : List α} : (as.scanr f init).toArray = as.toArray.scanr f init := by rw [← Array.toList_scanr] end List namespace Subarray @[simp] theorem scanlM_eq_scanlM_extract [Monad m] [LawfulMonad m] {f : β → α → m β} {as : Subarray α} : as.scanlM f init = (as.array.extract as.start as.stop).scanlM f init := by simp only [scanlM, Array.scanlM_extract] @[simp] theorem scanrM_eq_scanrM_extract [Monad m] [LawfulMonad m] {f : α → β → m β} {as : Subarray α} : as.scanrM f init = (as.array.extract as.stop as.start).scanrM f init := by simp only [scanrM, Array.scanrM_extract] @[simp] theorem scanl_eq_scanl_extract {f : β → α → β} {as : Subarray α} : as.scanl f init = (as.array.extract as.start as.stop).scanl f init := by simp only [scanl, Array.scanl_extract] @[simp] theorem scanr_eq_scanr_extract {f : α → β → β} {as : Subarray α} : as.scanr f init = (as.array.extract as.stop as.start).scanr f init := by simp only [scanr, Array.scanr_extract] end Subarray ================================================ FILE: Batteries/Data/Array.lean ================================================ module public import Batteries.Data.Array.Basic public import Batteries.Data.Array.Init.Lemmas public import Batteries.Data.Array.Lemmas public import Batteries.Data.Array.Match public import Batteries.Data.Array.Merge public import Batteries.Data.Array.Monadic public import Batteries.Data.Array.Pairwise public import Batteries.Data.Array.Scan ================================================ FILE: Batteries/Data/AssocList.lean ================================================ /- Copyright (c) 2019 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Mario Carneiro -/ module public import Batteries.Data.List.Basic @[expose] public section namespace Batteries /-- `AssocList α β` is "the same as" `List (α × β)`, but flattening the structure leads to one fewer pointer indirection (in the current code generator). It is mainly intended as a component of `HashMap`, but it can also be used as a plain key-value map. -/ inductive AssocList (α : Type u) (β : Type v) where /-- An empty list -/ | nil /-- Add a `key, value` pair to the list -/ | cons (key : α) (value : β) (tail : AssocList α β) deriving Inhabited namespace AssocList /-- `O(n)`. Convert an `AssocList α β` into the equivalent `List (α × β)`. This is used to give specifications for all the `AssocList` functions in terms of corresponding list functions. -/ @[simp] def toList : AssocList α β → List (α × β) | nil => [] | cons a b es => (a, b) :: es.toList instance : EmptyCollection (AssocList α β) := ⟨nil⟩ @[simp] theorem empty_eq : (∅ : AssocList α β) = nil := rfl /-- `O(1)`. Is the list empty? -/ def isEmpty : AssocList α β → Bool | nil => true | _ => false @[simp] theorem isEmpty_eq (l : AssocList α β) : isEmpty l = l.toList.isEmpty := by cases l <;> simp [*, isEmpty, List.isEmpty] /-- The number of entries in an `AssocList`. -/ def length (L : AssocList α β) : Nat := match L with | .nil => 0 | .cons _ _ t => t.length + 1 @[simp] theorem length_nil : length (nil : AssocList α β) = 0 := rfl @[simp] theorem length_cons : length (cons a b t) = length t + 1 := rfl theorem length_toList (l : AssocList α β) : l.toList.length = l.length := by induction l <;> simp_all /-- `O(n)`. Fold a monadic function over the list, from head to tail. -/ @[specialize] def foldlM [Monad m] (f : δ → α → β → m δ) : (init : δ) → AssocList α β → m δ | d, nil => pure d | d, cons a b es => do foldlM f (← f d a b) es @[simp] theorem foldlM_eq [Monad m] (f : δ → α → β → m δ) (init l) : foldlM f init l = l.toList.foldlM (fun d (a, b) => f d a b) init := by induction l generalizing init <;> simp [*, foldlM] /-- `O(n)`. Fold a function over the list, from head to tail. -/ @[inline] def foldl (f : δ → α → β → δ) (init : δ) (as : AssocList α β) : δ := Id.run (foldlM (fun d a b => pure (f d a b)) init as) @[simp] theorem foldl_eq (f : δ → α → β → δ) (init l) : foldl f init l = l.toList.foldl (fun d (a, b) => f d a b) init := by simp [foldl, foldlM_eq] /-- Optimized version of `toList`. -/ def toListTR (as : AssocList α β) : List (α × β) := as.foldl (init := #[]) (fun r a b => r.push (a, b)) |>.toList @[csimp] theorem toList_eq_toListTR : @toList = @toListTR := by funext α β as; simp [toListTR] /-- `O(n)`. Run monadic function `f` on all elements in the list, from head to tail. -/ @[specialize] def forM [Monad m] (f : α → β → m PUnit) : AssocList α β → m PUnit | nil => pure ⟨⟩ | cons a b es => do f a b; forM f es @[simp] theorem forM_eq [Monad m] (f : α → β → m PUnit) (l) : forM f l = l.toList.forM (fun (a, b) => f a b) := by induction l <;> simp [*, forM] /-- `O(n)`. Map a function `f` over the keys of the list. -/ @[simp] def mapKey (f : α → δ) : AssocList α β → AssocList δ β | nil => nil | cons k v t => cons (f k) v (mapKey f t) @[simp] theorem toList_mapKey (f : α → δ) (l : AssocList α β) : (mapKey f l).toList = l.toList.map (fun (a, b) => (f a, b)) := by induction l <;> simp [*] @[simp] theorem length_mapKey : (mapKey f l).length = l.length := by induction l <;> simp_all /-- `O(n)`. Map a function `f` over the values of the list. -/ @[simp] def mapVal (f : α → β → δ) : AssocList α β → AssocList α δ | nil => nil | cons k v t => cons k (f k v) (mapVal f t) @[simp] theorem toList_mapVal (f : α → β → δ) (l : AssocList α β) : (mapVal f l).toList = l.toList.map (fun (a, b) => (a, f a b)) := by induction l <;> simp [*] @[simp] theorem length_mapVal : (mapVal f l).length = l.length := by induction l <;> simp_all /-- `O(n)`. Returns the first entry in the list whose entry satisfies `p`. -/ @[specialize] def findEntryP? (p : α → β → Bool) : AssocList α β → Option (α × β) | nil => none | cons k v es => bif p k v then some (k, v) else findEntryP? p es @[simp] theorem findEntryP?_eq (p : α → β → Bool) (l : AssocList α β) : findEntryP? p l = l.toList.find? fun (a, b) => p a b := by induction l <;> simp [findEntryP?, List.find?_cons]; split <;> simp [*] /-- `O(n)`. Returns the first entry in the list whose key is equal to `a`. -/ @[inline] def findEntry? [BEq α] (a : α) (l : AssocList α β) : Option (α × β) := findEntryP? (fun k _ => k == a) l @[simp] theorem findEntry?_eq [BEq α] (a : α) (l : AssocList α β) : findEntry? a l = l.toList.find? (·.1 == a) := findEntryP?_eq .. /-- `O(n)`. Returns the first value in the list whose key is equal to `a`. -/ def find? [BEq α] (a : α) : AssocList α β → Option β | nil => none | cons k v es => match k == a with | true => some v | false => find? a es theorem find?_eq_findEntry? [BEq α] (a : α) (l : AssocList α β) : find? a l = (l.findEntry? a).map (·.2) := by induction l <;> simp [find?, List.find?_cons]; split <;> simp [*] @[simp] theorem find?_eq [BEq α] (a : α) (l : AssocList α β) : find? a l = (l.toList.find? (·.1 == a)).map (·.2) := by simp [find?_eq_findEntry?] /-- `O(n)`. Returns true if any entry in the list satisfies `p`. -/ @[specialize] def any (p : α → β → Bool) : AssocList α β → Bool | nil => false | cons k v es => p k v || any p es @[simp] theorem any_eq (p : α → β → Bool) (l : AssocList α β) : any p l = l.toList.any fun (a, b) => p a b := by induction l <;> simp [any, *] /-- `O(n)`. Returns true if every entry in the list satisfies `p`. -/ @[specialize] def all (p : α → β → Bool) : AssocList α β → Bool | nil => true | cons k v es => p k v && all p es @[simp] theorem all_eq (p : α → β → Bool) (l : AssocList α β) : all p l = l.toList.all fun (a, b) => p a b := by induction l <;> simp [all, *] /-- Returns true if every entry in the list satisfies `p`. -/ def All (p : α → β → Prop) (l : AssocList α β) : Prop := ∀ a ∈ l.toList, p a.1 a.2 /-- `O(n)`. Returns true if there is an element in the list whose key is equal to `a`. -/ @[inline] def contains [BEq α] (a : α) (l : AssocList α β) : Bool := any (fun k _ => k == a) l @[simp] theorem contains_eq [BEq α] (a : α) (l : AssocList α β) : contains a l = l.toList.any (·.1 == a) := by induction l <;> simp [*, contains] /-- `O(n)`. Replace the first entry in the list with key equal to `a` to have key `a` and value `b`. -/ @[simp] def replace [BEq α] (a : α) (b : β) : AssocList α β → AssocList α β | nil => nil | cons k v es => match k == a with | true => cons a b es | false => cons k v (replace a b es) @[simp] theorem toList_replace [BEq α] (a : α) (b : β) (l : AssocList α β) : (replace a b l).toList = l.toList.replaceF (bif ·.1 == a then some (a, b) else none) := by induction l <;> simp [replace]; split <;> simp [*] @[simp] theorem length_replace [BEq α] {a : α} : (replace a b l).length = l.length := by induction l · rfl · simp only [replace, length_cons] split <;> simp_all /-- `O(n)`. Remove the first entry in the list with key equal to `a`. -/ @[specialize, simp] def eraseP (p : α → β → Bool) : AssocList α β → AssocList α β | nil => nil | cons k v es => bif p k v then es else cons k v (eraseP p es) @[simp] theorem toList_eraseP (p) (l : AssocList α β) : (eraseP p l).toList = l.toList.eraseP fun (a, b) => p a b := by induction l <;> simp [List.eraseP, cond]; split <;> simp [*] /-- `O(n)`. Remove the first entry in the list with key equal to `a`. -/ @[inline] def erase [BEq α] (a : α) (l : AssocList α β) : AssocList α β := eraseP (fun k _ => k == a) l @[simp] theorem toList_erase [BEq α] (a : α) (l : AssocList α β) : (erase a l).toList = l.toList.eraseP (·.1 == a) := toList_eraseP .. /-- `O(n)`. Replace the first entry `a', b` in the list with key equal to `a` to have key `a` and value `f a' b`. -/ @[simp] def modify [BEq α] (a : α) (f : α → β → β) : AssocList α β → AssocList α β | nil => nil | cons k v es => match k == a with | true => cons a (f k v) es | false => cons k v (modify a f es) @[simp] theorem toList_modify [BEq α] (a : α) (l : AssocList α β) : (modify a f l).toList = l.toList.replaceF fun (k, v) => bif k == a then some (a, f k v) else none := by simp [cond] induction l with simp [List.replaceF] | cons k v es ih => cases k == a <;> simp [ih] @[simp] theorem length_modify [BEq α] {a : α} : (modify a f l).length = l.length := by induction l · rfl · simp only [modify, length_cons] split <;> simp_all /-- The implementation of `ForIn`, which enables `for (k, v) in aList do ...` notation. -/ @[specialize] protected def forIn [Monad m] (as : AssocList α β) (init : δ) (f : (α × β) → δ → m (ForInStep δ)) : m δ := match as with | nil => pure init | cons k v es => do match (← f (k, v) init) with | ForInStep.done d => pure d | ForInStep.yield d => es.forIn d f instance [Monad m] : ForIn m (AssocList α β) (α × β) where forIn := AssocList.forIn @[simp] theorem forIn_eq [Monad m] (l : AssocList α β) (init : δ) (f : (α × β) → δ → m (ForInStep δ)) : forIn l init f = forIn l.toList init f := by simp only [forIn] induction l generalizing init <;> simp [AssocList.forIn] congr; funext a; split <;> simp [*] /-- Split the list into head and tail, if possible. -/ def pop? : AssocList α β → Option ((α × β) × AssocList α β) | nil => none | cons a b l => some ((a, b), l) instance : Std.ToStream (AssocList α β) (AssocList α β) := ⟨fun x => x⟩ instance : Std.Stream (AssocList α β) (α × β) := ⟨pop?⟩ /-- Converts a list into an `AssocList`. This is the inverse function to `AssocList.toList`. -/ @[simp] def _root_.List.toAssocList : List (α × β) → AssocList α β | [] => nil | (a,b) :: es => cons a b (toAssocList es) @[simp] theorem _root_.List.toList_toAssocList (l : List (α × β)) : l.toAssocList.toList = l := by induction l <;> simp [*] @[simp] theorem toList_toAssocList (l : AssocList α β) : l.toList.toAssocList = l := by induction l <;> simp [*] @[simp] theorem _root_.List.length_toAssocList (l : List (α × β)) : l.toAssocList.length = l.length := by induction l <;> simp [*] /-- Implementation of `==` on `AssocList`. -/ protected def beq [BEq α] [BEq β] : AssocList α β → AssocList α β → Bool | .nil, .nil => true | .cons _ _ _, .nil => false | .nil, .cons _ _ _ => false | .cons a b t, .cons a' b' t' => a == a' && b == b' && AssocList.beq t t' /-- Boolean equality for `AssocList`. (This relation cares about the ordering of the key-value pairs.) -/ instance [BEq α] [BEq β] : BEq (AssocList α β) where beq := AssocList.beq @[simp] theorem beq_nil₂ [BEq α] [BEq β] : ((.nil : AssocList α β) == .nil) = true := rfl @[simp] theorem beq_nil_cons [BEq α] [BEq β] : ((.nil : AssocList α β) == .cons a b t) = false := rfl @[simp] theorem beq_cons_nil [BEq α] [BEq β] : ((.cons a b t : AssocList α β) == .nil) = false := rfl @[simp] theorem beq_cons₂ [BEq α] [BEq β] : ((.cons a b t : AssocList α β) == .cons a' b' t') = (a == a' && b == b' && t == t') := rfl instance [BEq α] [LawfulBEq α] [BEq β] [LawfulBEq β] : LawfulBEq (AssocList α β) where rfl {L} := by induction L <;> simp_all eq_of_beq {L M} := by induction L generalizing M with | nil => cases M <;> simp_all | cons a b L ih => cases M with | nil => simp_all | cons a' b' M => simp_all only [beq_cons₂, Bool.and_eq_true, beq_iff_eq, cons.injEq, true_and, and_imp] exact fun _ _ => ih protected theorem beq_eq [BEq α] [BEq β] {l m : AssocList α β} : (l == m) = (l.toList == m.toList) := by simp [(· == ·)] induction l generalizing m <;> cases m <;> simp [*, (· == ·), AssocList.beq, List.beq] ================================================ FILE: Batteries/Data/BinaryHeap/Basic.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, François G. Dorais -/ module public section namespace Batteries /-- A max-heap data structure. -/ structure BinaryHeap (α) (lt : α → α → Bool) where /-- `O(1)`. Get data array for a `BinaryHeap`. -/ arr : Array α namespace BinaryHeap private def maxChild (lt : α → α → Bool) (a : Vector α sz) (i : Fin sz) : Option (Fin sz) := let left := 2 * i.1 + 1 let right := left + 1 if hleft : left < sz then if hright : right < sz then if lt a[left] a[right] then some ⟨right, hright⟩ else some ⟨left, hleft⟩ else some ⟨left, hleft⟩ else none /-- Core operation for binary heaps, expressed directly on arrays. Given an array which is a max-heap, push item `i` down to restore the max-heap property. -/ def heapifyDown (lt : α → α → Bool) (a : Vector α sz) (i : Fin sz) : Vector α sz := match h : maxChild lt a i with | none => a | some j => have : i < j := by cases i; cases j simp only [maxChild] at h split at h · split at h · split at h <;> (cases h; simp +arith) · cases h; simp +arith · contradiction if lt a[i] a[j] then heapifyDown lt (a.swap i j) j else a termination_by sz - i /-- Core operation for binary heaps, expressed directly on arrays. Construct a heap from an unsorted array, by heapifying all the elements. -/ def mkHeap (lt : α → α → Bool) (a : Vector α sz) : Vector α sz := loop (sz / 2) a (Nat.div_le_self ..) where /-- Inner loop for `mkHeap`. -/ loop : (i : Nat) → (a : Vector α sz) → i ≤ sz → Vector α sz | 0, a, _ => a | i+1, a, h => let a' := heapifyDown lt a ⟨i, Nat.lt_of_succ_le h⟩ loop i a' (Nat.le_trans (Nat.le_succ _) h) /-- Core operation for binary heaps, expressed directly on arrays. Given an array which is a max-heap, push item `i` up to restore the max-heap property. -/ def heapifyUp (lt : α → α → Bool) (a : Vector α sz) (i : Fin sz) : Vector α sz := match i with | ⟨0, _⟩ => a | ⟨i'+1, hi⟩ => let j := i'/2 if lt a[j] a[i] then heapifyUp lt (a.swap i j) ⟨j, by get_elem_tactic⟩ else a /-- `O(1)`. Build a new empty heap. -/ def empty (lt) : BinaryHeap α lt := ⟨#[]⟩ instance (lt) : Inhabited (BinaryHeap α lt) := ⟨empty _⟩ instance (lt) : EmptyCollection (BinaryHeap α lt) := ⟨empty _⟩ /-- `O(1)`. Build a one-element heap. -/ def singleton (lt) (x : α) : BinaryHeap α lt := ⟨#[x]⟩ /-- `O(1)`. Get the number of elements in a `BinaryHeap`. -/ def size (self : BinaryHeap α lt) : Nat := self.1.size /-- `O(1)`. Get data vector of a `BinaryHeap`. -/ def vector (self : BinaryHeap α lt) : Vector α self.size := ⟨self.1, rfl⟩ /-- `O(1)`. Get an element in the heap by index. -/ def get (self : BinaryHeap α lt) (i : Fin self.size) : α := self.1[i]'(i.2) /-- `O(log n)`. Insert an element into a `BinaryHeap`, preserving the max-heap property. -/ def insert (self : BinaryHeap α lt) (x : α) : BinaryHeap α lt where arr := heapifyUp lt (self.vector.push x) ⟨_, Nat.lt_succ_self _⟩ |>.toArray @[simp] theorem size_insert (self : BinaryHeap α lt) (x : α) : (self.insert x).size = self.size + 1 := by simp [size, insert] /-- `O(1)`. Get the maximum element in a `BinaryHeap`. -/ def max (self : BinaryHeap α lt) : Option α := self.1[0]? /-- `O(log n)`. Remove the maximum element from a `BinaryHeap`. Call `max` first to actually retrieve the maximum element. -/ def popMax (self : BinaryHeap α lt) : BinaryHeap α lt := if h0 : self.size = 0 then self else have hs : self.size - 1 < self.size := Nat.pred_lt h0 have h0 : 0 < self.size := Nat.zero_lt_of_ne_zero h0 let v := self.vector.swap _ _ h0 hs |>.pop if h : 0 < self.size - 1 then ⟨heapifyDown lt v ⟨0, h⟩ |>.toArray⟩ else ⟨v.toArray⟩ @[simp] theorem size_popMax (self : BinaryHeap α lt) : self.popMax.size = self.size - 1 := by simp only [popMax, size] split · simp +arith [*] · split <;> simp +arith /-- `O(log n)`. Return and remove the maximum element from a `BinaryHeap`. -/ def extractMax (self : BinaryHeap α lt) : Option α × BinaryHeap α lt := (self.max, self.popMax) theorem size_pos_of_max {self : BinaryHeap α lt} (h : self.max = some x) : 0 < self.size := by simp only [max, getElem?_def] at h split at h · assumption · contradiction /-- `O(log n)`. Equivalent to `extractMax (self.insert x)`, except that extraction cannot fail. -/ def insertExtractMax (self : BinaryHeap α lt) (x : α) : α × BinaryHeap α lt := match e : self.max with | none => (x, self) | some m => if lt x m then let v := self.vector.set 0 x (size_pos_of_max e) (m, ⟨heapifyDown lt v ⟨0, size_pos_of_max e⟩ |>.toArray⟩) else (x, self) /-- `O(log n)`. Equivalent to `(self.max, self.popMax.insert x)`. -/ def replaceMax (self : BinaryHeap α lt) (x : α) : Option α × BinaryHeap α lt := match e : self.max with | none => (none, ⟨self.vector.push x |>.toArray⟩) | some m => let v := self.vector.set 0 x (size_pos_of_max e) (some m, ⟨heapifyDown lt v ⟨0, size_pos_of_max e⟩ |>.toArray⟩) /-- `O(log n)`. Replace the value at index `i` by `x`. Assumes that `x ≤ self.get i`. -/ def decreaseKey (self : BinaryHeap α lt) (i : Fin self.size) (x : α) : BinaryHeap α lt where arr := heapifyDown lt (self.vector.set i x) i |>.toArray /-- `O(log n)`. Replace the value at index `i` by `x`. Assumes that `self.get i ≤ x`. -/ def increaseKey (self : BinaryHeap α lt) (i : Fin self.size) (x : α) : BinaryHeap α lt where arr := heapifyUp lt (self.vector.set i x) i |>.toArray end Batteries.BinaryHeap /-- `O(n)`. Convert an unsorted vector to a `BinaryHeap`. -/ def Batteries.Vector.toBinaryHeap (lt : α → α → Bool) (v : Vector α n) : Batteries.BinaryHeap α lt where arr := BinaryHeap.mkHeap lt v |>.toArray open Batteries in /-- `O(n)`. Convert an unsorted array to a `BinaryHeap`. -/ def Array.toBinaryHeap (lt : α → α → Bool) (a : Array α) : Batteries.BinaryHeap α lt where arr := BinaryHeap.mkHeap lt ⟨a, rfl⟩ |>.toArray open Batteries in /-- `O(n log n)`. Sort an array using a `BinaryHeap`. -/ @[specialize] def Array.heapSort (a : Array α) (lt : α → α → Bool) : Array α := loop (a.toBinaryHeap (flip lt)) #[] where /-- Inner loop for `heapSort`. -/ loop (a : Batteries.BinaryHeap α (flip lt)) (out : Array α) : Array α := match e: a.max with | none => out | some x => have : a.popMax.size < a.size := by simp; exact Nat.sub_lt (Batteries.BinaryHeap.size_pos_of_max e) Nat.zero_lt_one loop a.popMax (out.push x) termination_by a.size ================================================ FILE: Batteries/Data/BinaryHeap.lean ================================================ module public import Batteries.Data.BinaryHeap.Basic ================================================ FILE: Batteries/Data/BinomialHeap/Basic.lean ================================================ /- Copyright (c) 2019 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Jannis Limperg, Mario Carneiro -/ module public import Batteries.Classes.Order public import Batteries.Control.ForInStep.Basic @[expose] public section namespace Batteries namespace BinomialHeap namespace Imp /-- A `HeapNode` is one of the internal nodes of the binomial heap. It is always a perfect binary tree, with the depth of the tree stored in the `Heap`. However the interpretation of the two pointers is different: we view the `child` as going to the first child of this node, and `sibling` goes to the next sibling of this tree. So it actually encodes a forest where each node has children `node.child`, `node.child.sibling`, `node.child.sibling.sibling`, etc. Each edge in this forest denotes a `le a b` relation that has been checked, so the root is smaller than everything else under it. -/ inductive HeapNode (α : Type u) where /-- An empty forest, which has depth `0`. -/ | nil : HeapNode α /-- A forest of rank `r + 1` consists of a root `a`, a forest `child` of rank `r` elements greater than `a`, and another forest `sibling` of rank `r`. -/ | node (a : α) (child sibling : HeapNode α) : HeapNode α deriving Repr /-- The "real size" of the node, counting up how many values of type `α` are stored. This is `O(n)` and is intended mainly for specification purposes. For a well formed `HeapNode` the size is always `2^n - 1` where `n` is the depth. -/ @[simp] def HeapNode.realSize : HeapNode α → Nat | .nil => 0 | .node _ c s => c.realSize + 1 + s.realSize /-- A node containing a single element `a`. -/ def HeapNode.singleton (a : α) : HeapNode α := .node a .nil .nil /-- `O(log n)`. The rank, or the number of trees in the forest. It is also the depth of the forest. -/ def HeapNode.rank : HeapNode α → Nat | .nil => 0 | .node _ _ s => s.rank + 1 /-- Tail-recursive version of `HeapNode.rank`. -/ @[inline] def HeapNode.rankTR (s : HeapNode α) : Nat := go s 0 where /-- Computes `s.rank + r` -/ go : HeapNode α → Nat → Nat | .nil, r => r | .node _ _ s, r => go s (r + 1) @[csimp] theorem HeapNode.rankTR_eq : @rankTR = @rank := by funext α s; exact go s 0 where go {α} : ∀ s n, @rankTR.go α s n = rank s + n | .nil, _ => (Nat.zero_add ..).symm | .node .., _ => by simp +arith only [rankTR.go, go, rank] /-- A `Heap` is the top level structure in a binomial heap. It consists of a forest of `HeapNode`s with strictly increasing ranks. -/ inductive Heap (α : Type u) where /-- An empty heap. -/ | nil : Heap α /-- A cons node contains a tree of root `val`, children `node` and rank `rank`, and then `next` which is the rest of the forest. -/ | cons (rank : Nat) (val : α) (node : HeapNode α) (next : Heap α) : Heap α deriving Repr /-- `O(n)`. The "real size" of the heap, counting up how many values of type `α` are stored. This is intended mainly for specification purposes. Prefer `Heap.size`, which is the same for well formed heaps. -/ @[simp] def Heap.realSize : Heap α → Nat | .nil => 0 | .cons _ _ c s => c.realSize + 1 + s.realSize /-- `O(log n)`. The number of elements in the heap. -/ def Heap.size : Heap α → Nat | .nil => 0 | .cons r _ _ s => 1 <<< r + s.size /-- `O(1)`. Is the heap empty? -/ @[inline] def Heap.isEmpty : Heap α → Bool | .nil => true | _ => false /-- `O(1)`. The heap containing a single value `a`. -/ @[inline] def Heap.singleton (a : α) : Heap α := .cons 0 a .nil .nil /-- `O(1)`. Auxiliary for `Heap.merge`: Is the minimum rank in `Heap` strictly larger than `n`? -/ def Heap.rankGT : Heap α → Nat → Prop | .nil, _ => True | .cons r .., n => n < r instance : Decidable (Heap.rankGT s n) := match s with | .nil => inferInstanceAs (Decidable True) | .cons .. => inferInstanceAs (Decidable (_ < _)) /-- `O(log n)`. The number of trees in the forest. -/ @[simp] def Heap.length : Heap α → Nat | .nil => 0 | .cons _ _ _ r => r.length + 1 /-- `O(1)`. Auxiliary for `Heap.merge`: combines two heap nodes of the same rank into one with the next larger rank. -/ @[inline] def combine (le : α → α → Bool) (a₁ a₂ : α) (n₁ n₂ : HeapNode α) : α × HeapNode α := if le a₁ a₂ then (a₁, .node a₂ n₂ n₁) else (a₂, .node a₁ n₁ n₂) /-- Merge two forests of binomial trees. The forests are assumed to be ordered by rank and `merge` maintains this invariant. -/ @[specialize] def Heap.merge (le : α → α → Bool) : Heap α → Heap α → Heap α | .nil, h => h | h, .nil => h | s₁@(.cons r₁ a₁ n₁ t₁), s₂@(.cons r₂ a₂ n₂ t₂) => if r₁ < r₂ then .cons r₁ a₁ n₁ (merge le t₁ s₂) else if r₂ < r₁ then .cons r₂ a₂ n₂ (merge le s₁ t₂) else let (a, n) := combine le a₁ a₂ n₁ n₂ let r := r₁ + 1 if t₁.rankGT r then if t₂.rankGT r then .cons r a n (merge le t₁ t₂) else merge le (.cons r a n t₁) t₂ else if t₂.rankGT r then merge le t₁ (.cons r a n t₂) else .cons r a n (merge le t₁ t₂) termination_by s₁ s₂ => s₁.length + s₂.length /-- `O(log n)`. Convert a `HeapNode` to a `Heap` by reversing the order of the nodes along the `sibling` spine. -/ def HeapNode.toHeap (s : HeapNode α) : Heap α := go s s.rank .nil where /-- Computes `s.toHeap ++ res` tail-recursively, assuming `n = s.rank`. -/ go : HeapNode α → Nat → Heap α → Heap α | .nil, _, res => res | .node a c s, n, res => go s (n - 1) (.cons (n - 1) a c res) /-- `O(log n)`. Get the smallest element in the heap, including the passed in value `a`. -/ @[specialize] def Heap.headD (le : α → α → Bool) (a : α) : Heap α → α | .nil => a | .cons _ b _ hs => headD le (if le a b then a else b) hs /-- `O(log n)`. Get the smallest element in the heap, if it has an element. -/ @[inline] def Heap.head? (le : α → α → Bool) : Heap α → Option α | .nil => none | .cons _ h _ hs => some <| headD le h hs /-- The return type of `FindMin`, which encodes various quantities needed to reconstruct the tree in `deleteMin`. -/ structure FindMin (α) where /-- The list of elements prior to the minimum element, encoded as a "difference list". -/ before : Heap α → Heap α := id /-- The minimum element. -/ val : α /-- The children of the minimum element. -/ node : HeapNode α /-- The forest after the minimum element. -/ next : Heap α /-- `O(log n)`. Find the minimum element, and return a data structure `FindMin` with information needed to reconstruct the rest of the binomial heap. -/ @[specialize] def Heap.findMin (le : α → α → Bool) (k : Heap α → Heap α) : Heap α → FindMin α → FindMin α | .nil, res => res | .cons r a c s, res => -- It is important that we check `le res.val a` here, not the other way -- around. This ensures that head? and findMin find the same element even -- when we have `le res.val a` and `le a res.val` (i.e. le is not antisymmetric). findMin le (k ∘ .cons r a c) s <| if le res.val a then res else ⟨k, a, c, s⟩ /-- `O(log n)`. Find and remove the the minimum element from the binomial heap. -/ def Heap.deleteMin (le : α → α → Bool) : Heap α → Option (α × Heap α) | .nil => none | .cons r a c s => let { before, val, node, next } := findMin le (.cons r a c) s ⟨id, a, c, s⟩ some (val, node.toHeap.merge le (before next)) /-- `O(log n)`. Get the tail of the binomial heap after removing the minimum element. -/ @[inline] def Heap.tail? (le : α → α → Bool) (h : Heap α) : Option (Heap α) := deleteMin le h |>.map (·.snd) /-- `O(log n)`. Remove the minimum element of the heap. -/ @[inline] def Heap.tail (le : α → α → Bool) (h : Heap α) : Heap α := tail? le h |>.getD .nil theorem Heap.realSize_merge (le) (s₁ s₂ : Heap α) : (s₁.merge le s₂).realSize = s₁.realSize + s₂.realSize := by unfold merge; split · simp · simp · next r₁ a₁ n₁ t₁ r₂ a₂ n₂ t₂ => have IH₁ r a n := realSize_merge le t₁ (cons r a n t₂) have IH₂ r a n := realSize_merge le (cons r a n t₁) t₂ have IH₃ := realSize_merge le t₁ t₂ split; · simp [IH₁, Nat.add_assoc] split; · simp [IH₂, Nat.add_assoc, Nat.add_left_comm] split; simp only; rename_i a n eq have : n.realSize = n₁.realSize + 1 + n₂.realSize := by rw [combine] at eq; split at eq <;> cases eq <;> simp [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] split <;> split <;> simp [IH₁, IH₂, IH₃, this, Nat.add_assoc, Nat.add_left_comm] termination_by s₁.length + s₂.length private def FindMin.HasSize (res : FindMin α) (n : Nat) : Prop := ∃ m, (∀ s, (res.before s).realSize = m + s.realSize) ∧ n = m + res.node.realSize + res.next.realSize + 1 private theorem Heap.realSize_findMin {s : Heap α} (m) (hk : ∀ s, (k s).realSize = m + s.realSize) (eq : n = m + s.realSize) (hres : res.HasSize n) : (s.findMin le k res).HasSize n := match s with | .nil => hres | .cons r a c s => by simp [findMin] refine realSize_findMin (m + c.realSize + 1) (by simp [hk, Nat.add_assoc]) (by simp [eq, Nat.add_assoc]) ?_ split · exact hres · exact ⟨m, hk, by simp [eq, Nat.add_comm, Nat.add_left_comm]⟩ theorem HeapNode.realSize_toHeap (s : HeapNode α) : s.toHeap.realSize = s.realSize := go s where go {n res} : ∀ s : HeapNode α, (toHeap.go s n res).realSize = s.realSize + res.realSize | .nil => (Nat.zero_add _).symm | .node a c s => by simp [toHeap.go, go, Nat.add_assoc, Nat.add_left_comm] theorem Heap.realSize_deleteMin {s : Heap α} (eq : s.deleteMin le = some (a, s')) : s.realSize = s'.realSize + 1 := by cases s with cases eq | cons r a c s => ?_ have : (s.findMin le (cons r a c) ⟨id, a, c, s⟩).HasSize (c.realSize + s.realSize + 1) := Heap.realSize_findMin (c.realSize + 1) (by simp) (Nat.add_right_comm ..) ⟨0, by simp⟩ revert this match s.findMin le (cons r a c) ⟨id, a, c, s⟩ with | { before, val, node, next } => intro ⟨m, ih₁, ih₂⟩; dsimp only at ih₁ ih₂ rw [realSize, Nat.add_right_comm, ih₂] simp only [realSize_merge, HeapNode.realSize_toHeap, ih₁, Nat.add_assoc, Nat.add_left_comm] theorem Heap.realSize_tail? {s : Heap α} : s.tail? le = some s' → s.realSize = s'.realSize + 1 := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact realSize_deleteMin eq₂ theorem Heap.realSize_tail (le) (s : Heap α) : (s.tail le).realSize = s.realSize - 1 := by simp only [Heap.tail] match eq : s.tail? le with | none => cases s with cases eq | nil => rfl | some tl => simp [Heap.realSize_tail? eq] /-- `O(n log n)`. Monadic fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[specialize] def Heap.foldM [Monad m] (le : α → α → Bool) (s : Heap α) (init : β) (f : β → α → m β) : m β := match eq : s.deleteMin le with | none => pure init | some (hd, tl) => do have : tl.realSize < s.realSize := by simp +arith [Heap.realSize_deleteMin eq] foldM le tl (← f init hd) f termination_by s.realSize /-- `O(n log n)`. Fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[inline] def Heap.fold (le : α → α → Bool) (s : Heap α) (init : β) (f : β → α → β) : β := Id.run <| s.foldM le init f /-- `O(n log n)`. Convert the heap to an array in increasing order. -/ @[inline] def Heap.toArray (le : α → α → Bool) (s : Heap α) : Array α := fold le s #[] Array.push /-- `O(n log n)`. Convert the heap to a list in increasing order. -/ @[inline] def Heap.toList (le : α → α → Bool) (s : Heap α) : List α := (s.toArray le).toList section variable [Monad m] (nil : β) (join : α → β → β → m β) /-- `O(n)`. Fold a monadic function over the tree structure to accumulate a value. -/ @[specialize] def HeapNode.foldTreeM : HeapNode α → m β | .nil => pure nil | .node a c s => do join a (← c.foldTreeM) (← s.foldTreeM) /-- `O(n)`. Fold a monadic function over the tree structure to accumulate a value. -/ @[specialize] def Heap.foldTreeM : Heap α → m β | .nil => pure nil | .cons _ a c s => do join a (← c.foldTreeM nil join) (← s.foldTreeM) end /-- `O(n)`. Fold a function over the tree structure to accumulate a value. -/ @[inline] def Heap.foldTree (nil : β) (join : α → β → β → β) (s : Heap α) : β := Id.run <| s.foldTreeM nil join /-- `O(n)`. Convert the heap to a list in arbitrary order. -/ def Heap.toListUnordered (s : Heap α) : List α := s.foldTree id (fun a c s l => a :: c (s l)) [] /-- `O(n)`. Convert the heap to an array in arbitrary order. -/ def Heap.toArrayUnordered (s : Heap α) : Array α := s.foldTree id (fun a c s r => s (c (r.push a))) #[] /-- The well formedness predicate for a heap node. It asserts that: * If `a` is added at the top to make the forest into a tree, the resulting tree is a `le`-min-heap (if `le` is well-behaved) * When interpreting `child` and `sibling` as left and right children of a binary tree, it is a perfect binary tree with depth `r` -/ def HeapNode.WF (le : α → α → Bool) (a : α) : HeapNode α → Nat → Prop | .nil, r => r = 0 | .node b c s, r => ∃ r', r = r' + 1 ∧ (∀ [TotalBLE le], le a b) ∧ c.WF le b r' ∧ s.WF le a r' /-- The well formedness predicate for a binomial heap. It asserts that: * It consists of a list of well formed trees with the specified ranks * The ranks are in strictly increasing order, and all are at least `n` -/ def Heap.WF (le : α → α → Bool) (n : Nat) : Heap α → Prop | .nil => True | .cons r a c s => n ≤ r ∧ c.WF le a r ∧ s.WF le (r+1) theorem Heap.WF.nil : Heap.nil.WF le n := trivial theorem Heap.WF.singleton : (Heap.singleton a).WF le 0 := ⟨by decide, rfl, ⟨⟩⟩ theorem Heap.WF.of_rankGT (hlt : s.rankGT n) (h : Heap.WF le n' s) : s.WF le (n+1) := match s with | .nil => trivial | .cons .. => let ⟨_, h₂, h₃⟩ := h; ⟨hlt, h₂, h₃⟩ theorem Heap.WF.of_le (hle : n ≤ n') (h : Heap.WF le n' s) : s.WF le n := match s with | .nil => trivial | .cons .. => let ⟨h₁, h₂, h₃⟩ := h; ⟨Nat.le_trans hle h₁, h₂, h₃⟩ theorem Heap.rankGT.of_le (h : Heap.rankGT s n) (h' : n' ≤ n) : s.rankGT n' := match s with | .nil => trivial | .cons .. => Nat.lt_of_le_of_lt h' h theorem Heap.WF.rankGT (h : Heap.WF lt (n+1) s) : s.rankGT n := match s with | .nil => trivial | .cons .. => Nat.lt_of_succ_le h.1 theorem Heap.WF.merge' (h₁ : s₁.WF le n) (h₂ : s₂.WF le n) : (merge le s₁ s₂).WF le n ∧ ((s₁.rankGT n ↔ s₂.rankGT n) → (merge le s₁ s₂).rankGT n) := by unfold merge; split · exact ⟨h₂, fun h => h.1 h₁⟩ · exact ⟨h₁, fun h => h.2 h₂⟩ · rename_i r₁ a₁ n₁ t₁ r₂ a₂ n₂ t₂ let ⟨hr₁, hn₁, ht₁⟩ := h₁ let ⟨hr₂, hn₂, ht₂⟩ := h₂ split <;> rename_i lt₁ · refine ⟨⟨hr₁, hn₁, And.left (merge' ht₁ ⟨lt₁, hn₂, ht₂⟩)⟩, fun h => ?_⟩ exact h.2 <| Nat.lt_of_le_of_lt hr₁ lt₁ split <;> rename_i lt₂ · refine ⟨⟨hr₂, hn₂, And.left (merge' ⟨lt₂, hn₁, ht₁⟩ ht₂)⟩, fun h => ?_⟩ exact h.1 <| Nat.lt_of_le_of_lt hr₂ lt₂ cases Nat.le_antisymm (Nat.ge_of_not_lt lt₂) (Nat.ge_of_not_lt lt₁) split; rename_i a n eq have : n.WF le a (r₁+1) := by unfold combine at eq; split at eq <;> cases eq <;> rename_i h · exact ⟨r₁, rfl, h, hn₂, hn₁⟩ · exact ⟨r₁, rfl, TotalBLE.total.resolve_left h, hn₁, hn₂⟩ simp only; split <;> split <;> rename_i hl₁ hl₂ · exact ⟨⟨Nat.le_succ_of_le hr₁, this, (merge' (ht₁.of_rankGT hl₁) (ht₂.of_rankGT hl₂)).1⟩, fun _ => Nat.lt_succ_of_le hr₁⟩ · let ⟨ih₁, ih₂⟩ := merge' (s₁ := .cons ..) ⟨Nat.le_succ_of_le hr₁, this, ht₁.of_rankGT hl₁⟩ (ht₂.of_le (Nat.le_succ_of_le hr₁)) exact ⟨ih₁, fun _ => ih₂ ⟨fun _ => ht₂.rankGT.of_le hr₁, fun _ => Nat.lt_succ_of_le hr₁⟩⟩ · let ⟨ih₁, ih₂⟩ := merge' (s₂ := .cons ..) (ht₁.of_le (Nat.le_succ_of_le hr₁)) ⟨Nat.le_succ_of_le hr₁, this, ht₂.of_rankGT hl₂⟩ exact ⟨ih₁, fun _ => ih₂ ⟨fun _ => Nat.lt_succ_of_le hr₁, fun _ => ht₁.rankGT.of_le hr₁⟩⟩ · let ⟨ih₁, ih₂⟩ := merge' ht₁ ht₂ exact ⟨⟨Nat.le_succ_of_le hr₁, this, ih₁.of_rankGT (ih₂ (iff_of_false hl₁ hl₂))⟩, fun _ => Nat.lt_succ_of_le hr₁⟩ termination_by s₁.length + s₂.length theorem Heap.WF.merge (h₁ : s₁.WF le n) (h₂ : s₂.WF le n) : (merge le s₁ s₂).WF le n := (merge' h₁ h₂).1 theorem HeapNode.WF.rank_eq : ∀ {n} {s : HeapNode α}, s.WF le a n → s.rank = n | _, .nil, h => h.symm | _, .node .., ⟨_, rfl, _, _, h⟩ => congrArg Nat.succ (rank_eq h) theorem HeapNode.WF.toHeap {s : HeapNode α} (h : s.WF le a n) : s.toHeap.WF le 0 := go h trivial where go {res} : ∀ {n s}, s.WF le a n → res.WF le s.rank → (HeapNode.toHeap.go s s.rank res).WF le 0 | _, .nil, _, hr => hr | _, .node a c s, ⟨n, rfl, _, h, h'⟩, hr => go (s := s) h' ⟨Nat.le_refl _, by rw [← h'.rank_eq] at h; exact h, hr⟩ /-- The well formedness predicate for a `FindMin` value. This is not actually a predicate, as it contains an additional data value `rank` corresponding to the rank of the returned node, which is omitted from `findMin`. -/ structure FindMin.WF (le : α → α → Bool) (res : FindMin α) where /-- The rank of the minimum element -/ rank : Nat /-- `before` is a difference list which can be appended to a binomial heap with ranks at least `rank` to produce another well formed heap. -/ before : ∀ {s}, s.WF le rank → (res.before s).WF le 0 /-- `node` is a well formed forest of rank `rank` with `val` at the root. -/ node : res.node.WF le res.val rank /-- `next` is a binomial heap with ranks above `rank + 1`. -/ next : res.next.WF le (rank + 1) /-- The conditions under which `findMin` is well-formed. -/ def Heap.WF.findMin {s : Heap α} (h : s.WF le n) (hr : res.WF le) (hk : ∀ {s}, s.WF le n → (k s).WF le 0) : ((s : Heap α).findMin le k res).WF le := match s with | .nil => hr | .cons r a c s => by let ⟨h₁, h₂, h₃⟩ := h simp [Heap.findMin] cases le res.val a with | true => exact findMin h₃ hr (fun h => hk ⟨h₁, h₂, h⟩) | false => exact findMin h₃ ⟨_, fun h => hk (h.of_le h₁), h₂, h₃⟩ (fun h => hk ⟨h₁, h₂, h⟩) theorem Heap.WF.deleteMin {s : Heap α} (h : s.WF le n) (eq : s.deleteMin le = some (a, s')) : s'.WF le 0 := by cases s with cases eq | cons r a c s => ?_ have : (s.findMin le (cons r a c) ⟨id, a, c, s⟩).WF le := let ⟨_, h₂, h₃⟩ := h h₃.findMin ⟨_, fun h => h.of_le (Nat.zero_le _), h₂, h₃⟩ fun h => ⟨Nat.zero_le _, h₂, h⟩ revert this let { before, val, node, next } := s.findMin le (cons r a c) ⟨id, a, c, s⟩ intro ⟨_, hk, ih₁, ih₂⟩ exact ih₁.toHeap.merge <| hk (ih₂.of_le (Nat.le_succ _)) theorem Heap.WF.tail? (hwf : (s : Heap α).WF le n) : s.tail? le = some tl → tl.WF le 0 := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact hwf.deleteMin eq₂ theorem Heap.WF.tail (hwf : (s : Heap α).WF le n) : (s.tail le).WF le 0 := by simp only [Heap.tail] match eq : s.tail? le with | none => exact Heap.WF.nil | some tl => exact hwf.tail? eq end Imp end BinomialHeap open BinomialHeap.Imp /-- A [binomial heap](https://en.wikipedia.org/wiki/Binomial_heap) is a data structure which supports the following primary operations: * `insert : α → BinomialHeap α → BinomialHeap α`: add an element to the heap * `deleteMin : BinomialHeap α → Option (α × BinomialHeap α)`: remove the minimum element from the heap * `merge : BinomialHeap α → BinomialHeap α → BinomialHeap α`: combine two heaps The first two operations are known as a "priority queue", so this could be called a "mergeable priority queue". The standard choice for a priority queue is a binary heap, which supports `insert` and `deleteMin` in `O(log n)`, but `merge` is `O(n)`. With a `BinomialHeap`, all three operations are `O(log n)`. -/ def BinomialHeap (α : Type u) (le : α → α → Bool) := { h : Heap α // h.WF le 0 } /-- `O(1)`. Make a new empty binomial heap. -/ @[inline] def mkBinomialHeap (α : Type u) (le : α → α → Bool) : BinomialHeap α le := ⟨.nil, Heap.WF.nil⟩ namespace BinomialHeap variable {α : Type u} {le : α → α → Bool} /-- `O(1)`. Make a new empty binomial heap. -/ @[inline] def empty : BinomialHeap α le := mkBinomialHeap α le instance : EmptyCollection (BinomialHeap α le) := ⟨.empty⟩ instance : Inhabited (BinomialHeap α le) := ⟨.empty⟩ /-- `O(1)`. Is the heap empty? -/ @[inline] def isEmpty (b : BinomialHeap α le) : Bool := b.1.isEmpty /-- `O(log n)`. The number of elements in the heap. -/ @[inline] def size (b : BinomialHeap α le) : Nat := b.1.size /-- `O(1)`. Make a new heap containing `a`. -/ @[inline] def singleton (a : α) : BinomialHeap α le := ⟨Heap.singleton a, Heap.WF.singleton⟩ /-- `O(log n)`. Merge the contents of two heaps. -/ @[inline] def merge : BinomialHeap α le → BinomialHeap α le → BinomialHeap α le | ⟨b₁, h₁⟩, ⟨b₂, h₂⟩ => ⟨b₁.merge le b₂, h₁.merge h₂⟩ /-- `O(log n)`. Add element `a` to the given heap `h`. -/ @[inline] def insert (a : α) (h : BinomialHeap α le) : BinomialHeap α le := merge (singleton a) h /-- `O(n log n)`. Construct a heap from a list by inserting all the elements. -/ def ofList (le : α → α → Bool) (as : List α) : BinomialHeap α le := as.foldl (flip insert) empty /-- `O(n log n)`. Construct a heap from a list by inserting all the elements. -/ def ofArray (le : α → α → Bool) (as : Array α) : BinomialHeap α le := as.foldl (flip insert) empty /-- `O(log n)`. Remove and return the minimum element from the heap. -/ @[inline] def deleteMin (b : BinomialHeap α le) : Option (α × BinomialHeap α le) := match eq : b.1.deleteMin le with | none => none | some (a, tl) => some (a, ⟨tl, b.2.deleteMin eq⟩) instance : Std.Stream (BinomialHeap α le) α := ⟨deleteMin⟩ /-- `O(n log n)`. Implementation of `for x in (b : BinomialHeap α le) ...` notation, which iterates over the elements in the heap in increasing order. -/ protected def forIn [Monad m] (b : BinomialHeap α le) (x : β) (f : α → β → m (ForInStep β)) : m β := ForInStep.run <$> b.1.foldM le (.yield x) fun x a => x.bind (f a) instance [Monad m] : ForIn m (BinomialHeap α le) α := ⟨BinomialHeap.forIn⟩ /-- `O(log n)`. Returns the smallest element in the heap, or `none` if the heap is empty. -/ @[inline] def head? (b : BinomialHeap α le) : Option α := b.1.head? le /-- `O(log n)`. Returns the smallest element in the heap, or panics if the heap is empty. -/ @[inline] def head! [Inhabited α] (b : BinomialHeap α le) : α := b.head?.get! /-- `O(log n)`. Returns the smallest element in the heap, or `default` if the heap is empty. -/ @[inline] def headI [Inhabited α] (b : BinomialHeap α le) : α := b.head?.getD default /-- `O(log n)`. Removes the smallest element from the heap, or `none` if the heap is empty. -/ @[inline] def tail? (b : BinomialHeap α le) : Option (BinomialHeap α le) := match eq : b.1.tail? le with | none => none | some tl => some ⟨tl, b.2.tail? eq⟩ /-- `O(log n)`. Removes the smallest element from the heap, if possible. -/ @[inline] def tail (b : BinomialHeap α le) : BinomialHeap α le := ⟨b.1.tail le, b.2.tail⟩ /-- `O(n log n)`. Monadic fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[inline] def foldM [Monad m] (b : BinomialHeap α le) (init : β) (f : β → α → m β) : m β := b.1.foldM le init f /-- `O(n log n)`. Fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[inline] def fold (b : BinomialHeap α le) (init : β) (f : β → α → β) : β := b.1.fold le init f /-- `O(n log n)`. Convert the heap to a list in increasing order. -/ @[inline] def toList (b : BinomialHeap α le) : List α := b.1.toList le /-- `O(n log n)`. Convert the heap to an array in increasing order. -/ @[inline] def toArray (b : BinomialHeap α le) : Array α := b.1.toArray le /-- `O(n)`. Convert the heap to a list in arbitrary order. -/ @[inline] def toListUnordered (b : BinomialHeap α le) : List α := b.1.toListUnordered /-- `O(n)`. Convert the heap to an array in arbitrary order. -/ @[inline] def toArrayUnordered (b : BinomialHeap α le) : Array α := b.1.toArrayUnordered ================================================ FILE: Batteries/Data/BinomialHeap/Lemmas.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.BinomialHeap.Basic @[expose] public section namespace Batteries.BinomialHeap namespace Imp theorem Heap.findMin_val : ((s : Heap α).findMin le k res).val = s.headD le res.val := match s with | .nil => rfl | .cons r a c s => by rw [findMin, headD]; split <;> apply findMin_val theorem Heap.deleteMin_fst : ((s : Heap α).deleteMin le).map (·.1) = s.head? le := match s with | .nil => rfl | .cons r a c s => by simp only [deleteMin, findMin_val, Option.map, head?] theorem HeapNode.WF.realSize_eq : ∀ {n} {s : HeapNode α}, s.WF le a n → s.realSize + 1 = 2 ^ n | _, .nil, rfl => rfl | _, .node .., ⟨_, rfl, _, c, s⟩ => by rw [realSize, realSize_eq c, Nat.pow_succ, Nat.mul_succ] simp [Nat.add_assoc, realSize_eq s] theorem Heap.WF.size_eq : ∀ {s : Heap α}, s.WF le n → s.size = s.realSize | .nil, _ => rfl | .cons .., ⟨_, h₁, h₂⟩ => by simp [size, size_eq h₂] simp [Nat.one_shiftLeft, h₁.realSize_eq] end Imp ================================================ FILE: Batteries/Data/BinomialHeap.lean ================================================ module public import Batteries.Data.BinomialHeap.Basic public import Batteries.Data.BinomialHeap.Lemmas ================================================ FILE: Batteries/Data/BitVec/Basic.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section namespace BitVec /-- `ofFnLEAux f` returns the `BitVec m` whose `i`th bit is `f i` when `i < m`, little endian. -/ @[inline] def ofFnLEAux (m : Nat) (f : Fin n → Bool) : BitVec m := Fin.foldr n (fun i v => v.shiftConcat (f i)) 0 /-- `ofFnLE f` returns the `BitVec n` whose `i`th bit is `f i` with little endian ordering. -/ @[inline] def ofFnLE (f : Fin n → Bool) : BitVec n := ofFnLEAux n f /-- `ofFnBE f` returns the `BitVec n` whose `i`th bit is `f i` with big endian ordering. -/ @[inline] def ofFnBE (f : Fin n → Bool) : BitVec n := ofFnLE fun i => f i.rev ================================================ FILE: Batteries/Data/BitVec/Lemmas.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Tactic.Alias public import Batteries.Data.BitVec.Basic public import Batteries.Data.Fin.OfBits public import Batteries.Data.Nat.Lemmas public import Batteries.Data.Int @[expose] public section namespace BitVec @[simp] theorem toNat_pow (b : BitVec w) (n : Nat) : (b ^ n).toNat = (b.toNat ^ n) % (2 ^ w) := by induction n <;> simp_all [Lean.Grind.Semiring.pow_succ] @[simp] theorem ofNat_pow (w x n : Nat) : BitVec.ofNat w (x ^ n) = BitVec.ofNat w x ^ n := by rw [← toNat_inj, toNat_ofNat, toNat_pow, toNat_ofNat, Nat.pow_mod] @[simp] theorem toNat_ofFnLEAux (m : Nat) (f : Fin n → Bool) : (ofFnLEAux m f).toNat = Nat.ofBits f % 2 ^ m := by simp only [ofFnLEAux] induction n with | zero => rfl | succ n ih => rw [Fin.foldr_succ, toNat_shiftConcat, Nat.shiftLeft_eq, Nat.pow_one, Nat.ofBits_succ, ih, ← Nat.mod_add_div (Nat.ofBits (f ∘ Fin.succ)) (2 ^ m), Nat.mul_add 2, Nat.add_right_comm, Nat.mul_left_comm, Nat.add_mul_mod_self_left, Nat.mul_comm 2] rfl @[simp] theorem toFin_ofFnLEAux (m : Nat) (f : Fin n → Bool) : (ofFnLEAux m f).toFin = Fin.ofNat (2 ^ m) (Nat.ofBits f) := by ext; simp @[simp, grind =] theorem toNat_ofFnLE (f : Fin n → Bool) : (ofFnLE f).toNat = Nat.ofBits f := by rw [ofFnLE, toNat_ofFnLEAux, Nat.mod_eq_of_lt (Nat.ofBits_lt_two_pow f)] @[simp, grind =] theorem toFin_ofFnLE (f : Fin n → Bool) : (ofFnLE f).toFin = Fin.ofBits f := by ext; simp @[simp, grind =] theorem toInt_ofFnLE (f : Fin n → Bool) : (ofFnLE f).toInt = Int.ofBits f := by simp only [BitVec.toInt, Int.ofBits, toNat_ofFnLE, Int.subNatNat_eq_coe]; rfl -- TODO: consider these for global `grind` attributes. attribute [local grind =] Fin.succ Fin.rev Fin.last Fin.zero_eta theorem getElem_ofFnLEAux (f : Fin n → Bool) (i) (h : i < n) (h' : i < m) : (ofFnLEAux m f)[i] = f ⟨i, h⟩ := by simp only [ofFnLEAux] induction n generalizing i m with | zero => contradiction | succ n ih => simp only [Fin.foldr_succ, getElem_shiftConcat] cases i with | zero => grind | succ i => rw [ih] <;> grind @[simp, grind =] theorem getElem_ofFnLE (f : Fin n → Bool) (i) (h : i < n) : (ofFnLE f)[i] = f ⟨i, h⟩ := getElem_ofFnLEAux .. @[grind =] theorem getLsb_ofFnLE (f : Fin n → Bool) (i) : (ofFnLE f).getLsb i = f i := by simp @[deprecated (since := "2025-06-17")] alias getLsb'_ofFnLE := getLsb_ofFnLE theorem getLsbD_ofFnLE (f : Fin n → Bool) (i) : (ofFnLE f).getLsbD i = if h : i < n then f ⟨i, h⟩ else false := by grind @[simp, grind =] theorem getMsb_ofFnLE (f : Fin n → Bool) (i) : (ofFnLE f).getMsb i = f i.rev := by grind @[deprecated (since := "2025-06-17")] alias getMsb'_ofFnLE := getMsb_ofFnLE @[grind =] theorem getMsbD_ofFnLE (f : Fin n → Bool) (i) : (ofFnLE f).getMsbD i = if h : i < n then f (Fin.rev ⟨i, h⟩) else false := by grind theorem msb_ofFnLE (f : Fin n → Bool) : (ofFnLE f).msb = if h : n ≠ 0 then f ⟨n-1, Nat.sub_one_lt h⟩ else false := by grind @[simp, grind =] theorem toNat_ofFnBE (f : Fin n → Bool) : (ofFnBE f).toNat = Nat.ofBits (f ∘ Fin.rev) := by simp [ofFnBE]; rfl @[simp, grind =] theorem toFin_ofFnBE (f : Fin n → Bool) : (ofFnBE f).toFin = Fin.ofBits (f ∘ Fin.rev) := by ext; simp @[simp, grind =] theorem toInt_ofFnBE (f : Fin n → Bool) : (ofFnBE f).toInt = Int.ofBits (f ∘ Fin.rev) := by simp [ofFnBE]; rfl @[simp, grind =] theorem getElem_ofFnBE (f : Fin n → Bool) (i) (h : i < n) : (ofFnBE f)[i] = f (Fin.rev ⟨i, h⟩) := by simp [ofFnBE] @[grind =] theorem getLsb_ofFnBE (f : Fin n → Bool) (i) : (ofFnBE f).getLsb i = f i.rev := by simp @[deprecated (since := "2025-06-17")] alias getLsb'_ofFnBE := getLsb_ofFnBE theorem getLsbD_ofFnBE (f : Fin n → Bool) (i) : (ofFnBE f).getLsbD i = if h : i < n then f (Fin.rev ⟨i, h⟩) else false := by grind @[simp, grind =] theorem getMsb_ofFnBE (f : Fin n → Bool) (i) : (ofFnBE f).getMsb i = f i := by simp [ofFnBE] @[deprecated (since := "2025-06-17")] alias getMsb'_ofFnBE := getMsb_ofFnBE @[grind =] theorem getMsbD_ofFnBE (f : Fin n → Bool) (i) : (ofFnBE f).getMsbD i = if h : i < n then f ⟨i, h⟩ else false := by grind @[grind =] theorem msb_ofFnBE (f : Fin n → Bool) : (ofFnBE f).msb = if h : n ≠ 0 then f ⟨0, Nat.zero_lt_of_ne_zero h⟩ else false := by grind ================================================ FILE: Batteries/Data/BitVec.lean ================================================ module public import Batteries.Data.BitVec.Basic public import Batteries.Data.BitVec.Lemmas ================================================ FILE: Batteries/Data/Bool.lean ================================================ /- Copyright (c) 2026 Chad Sharp. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Chad Sharp -/ module @[expose] public section /-! This file contains `WellFoundedRelation` instances `Bool`. They are provided as defs rather than instances, despite WellFoundedRelation being a class, as we provide versions for both < and >. If you need instances, you may use the WellFoundedLT and WellFoundedGT classes available in Mathlib. -/ /-- Boolean '<' is well founded -/ @[implicit_reducible] def Bool.lt_wfRel : WellFoundedRelation Bool where rel := (· < ·) wf := ⟨fun | false => ⟨false, nofun⟩ | true => ⟨true, fun | false, _ => ⟨false, nofun⟩⟩⟩ /-- Boolean '>' is well founded -/ @[implicit_reducible] def Bool.gt_wfRel : WellFoundedRelation Bool where rel := (· > ·) wf := ⟨fun | true => ⟨true, nofun⟩ | false => ⟨false, fun | true, _ => ⟨true, nofun⟩⟩⟩ ================================================ FILE: Batteries/Data/ByteArray.lean ================================================ /- Copyright (c) 2023 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section namespace ByteArray attribute [ext] ByteArray instance : DecidableEq ByteArray := fun _ _ => decidable_of_decidable_of_iff ByteArray.ext_iff.symm theorem getElem_eq_data_getElem (a : ByteArray) (h : i < a.size) : a[i] = a.data[i] := rfl /-! ### uget/uset -/ @[simp] theorem uset_eq_set (a : ByteArray) {i : USize} (h : i.toNat < a.size) (v : UInt8) : a.uset i v h = a.set i.toNat v := rfl /-! ### empty -/ @[simp] theorem data_mkEmpty (cap) : (emptyWithCapacity cap).data = #[] := rfl /-! ### push -/ @[simp] theorem get_push_eq (a : ByteArray) (x : UInt8) : (a.push x)[a.size] = x := Array.getElem_push_eq .. theorem get_push_lt (a : ByteArray) (x : UInt8) (i : Nat) (h : i < a.size) : (a.push x)[i]'(size_push .. ▸ Nat.lt_succ_of_lt h) = a[i] := Array.getElem_push_lt .. /-! ### set -/ @[simp] theorem size_set (a : ByteArray) (i : Fin a.size) (v : UInt8) : (a.set i v).size = a.size := Array.size_set .. @[simp] theorem get_set_eq (a : ByteArray) (i : Fin a.size) (v : UInt8) : (a.set i v)[i.val] = v := Array.getElem_set_self _ theorem get_set_ne (a : ByteArray) (i : Fin a.size) (v : UInt8) (hj : j < a.size) (h : i.val ≠ j) : (a.set i v)[j]'(a.size_set .. ▸ hj) = a[j] := Array.getElem_set_ne (h := h) .. theorem set_set (a : ByteArray) (i : Fin a.size) (v v' : UInt8) : (a.set i v).set i v' = a.set i v' := ByteArray.ext <| Array.set_set .. /-! ### copySlice -/ @[simp] theorem data_copySlice (a i b j len exact) : (copySlice a i b j len exact).data = b.data.extract 0 j ++ a.data.extract i (i + len) ++ b.data.extract (j + min len (a.data.size - i)) b.data.size := rfl /-! ### append -/ theorem get_append_left {a b : ByteArray} (hlt : i < a.size) (h : i < (a ++ b).size := size_append .. ▸ Nat.lt_of_lt_of_le hlt (Nat.le_add_right ..)) : (a ++ b)[i] = a[i] := by simp [getElem_eq_data_getElem]; exact Array.getElem_append_left hlt theorem get_append_right {a b : ByteArray} (hle : a.size ≤ i) (h : i < (a ++ b).size) (h' : i - a.size < b.size := Nat.sub_lt_left_of_lt_add hle (size_append .. ▸ h)) : (a ++ b)[i] = b[i - a.size] := by simp [getElem_eq_data_getElem]; exact Array.getElem_append_right hle /-! ### extract -/ theorem get_extract_aux {a : ByteArray} {start stop} (h : i < (a.extract start stop).size) : start + i < a.size := by apply Nat.add_lt_of_lt_sub'; apply Nat.lt_of_lt_of_le h rw [size_extract, ← Nat.sub_min_sub_right]; exact Nat.min_le_right .. @[simp] theorem get_extract {a : ByteArray} {start stop} (h : i < (a.extract start stop).size) : (a.extract start stop)[i] = a[start+i]'(get_extract_aux h) := by simp [getElem_eq_data_getElem]; rfl /-! ### ofFn -/ /--- `ofFn f` with `f : Fin n → UInt8` returns the byte array whose `i`th element is `f i`. --/ @[inline] def ofFn (f : Fin n → UInt8) : ByteArray := Fin.foldl n (fun acc i => acc.push (f i)) (emptyWithCapacity n) @[simp] theorem ofFn_zero (f : Fin 0 → UInt8) : ofFn f = empty := by simp [ofFn] theorem ofFn_succ (f : Fin (n+1) → UInt8) : ofFn f = (ofFn fun i => f i.castSucc).push (f (Fin.last n)) := by simp [ofFn, Fin.foldl_succ_last, emptyWithCapacity] @[simp] theorem data_ofFn (f : Fin n → UInt8) : (ofFn f).data = .ofFn f := by induction n with | zero => simp | succ n ih => simp [ofFn_succ, Array.ofFn_succ, ih, Fin.last] @[simp] theorem size_ofFn (f : Fin n → UInt8) : (ofFn f).size = n := by simp [size] @[simp] theorem get_ofFn (f : Fin n → UInt8) (i : Fin (ofFn f).size) : (ofFn f).get i = f (i.cast (size_ofFn f)) := by simp [get, Fin.cast] @[simp] theorem getElem_ofFn (f : Fin n → UInt8) (i) (h : i < (ofFn f).size) : (ofFn f)[i] = f ⟨i, size_ofFn f ▸ h⟩ := get_ofFn f ⟨i, h⟩ /-! ### map/mapM -/ /-- Unsafe optimized implementation of `mapM`. This function is unsafe because it relies on the implementation limit that the size of an array is always less than `USize.size`. -/ @[inline] unsafe def mapMUnsafe [Monad m] (a : ByteArray) (f : UInt8 → m UInt8) : m ByteArray := loop a 0 a.usize where /-- Inner loop for `mapMUnsafe`. -/ @[specialize] loop (a : ByteArray) (k s : USize) := do if k < a.usize then let x := a.uget k lcProof let y ← f x let a := a.uset k y lcProof loop a (k+1) s else pure a /-- `mapM f a` applies the monadic function `f` to each element of the array. -/ @[implemented_by mapMUnsafe] def mapM [Monad m] (a : ByteArray) (f : UInt8 → m UInt8) : m ByteArray := do let mut r := a for i in [0:r.size] do r := r.set! i (← f r[i]!) return r /-- `map f a` applies the function `f` to each element of the array. -/ @[inline] def map (a : ByteArray) (f : UInt8 → UInt8) : ByteArray := mapM (m:=Id) a f ================================================ FILE: Batteries/Data/ByteSlice.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, François G. Dorais -/ module public import Std.Data.ByteSlice import all Std.Data.ByteSlice -- for unfolding `ByteSlice.size` @[expose] public section namespace ByteSlice /-- Test whether a byte slice is empty. -/ protected abbrev isEmpty (s : ByteSlice) := s.start == s.stop theorem stop_eq_start_add_size (s : ByteSlice) : s.stop = s.start + s.size := by rw [ByteSlice.size, Nat.add_sub_cancel' s.start_le_stop] /-- Returns the subslice obtained by removing the last element. -/ abbrev pop (s : ByteSlice) : ByteSlice := s.slice 0 (s.size - 1) /-- Returns the subslice obtained by removing the first element. -/ abbrev popFront (s : ByteSlice) : ByteSlice := s.slice 1 s.size /-- Folds a monadic function over a `ByteSubarray` from left to right. -/ @[inline] def foldlM [Monad m] (s : ByteSlice) (f : β → UInt8 → m β) (init : β) : m β := s.toByteArray.foldlM f init s.start s.stop /-- Folds a function over a `ByteSubarray` from left to right. -/ @[inline] def foldl (s : ByteSlice) (f : β → UInt8 → β) (init : β) : β := s.foldlM (m:=Id) f init /-- Implementation of `forIn` for a `ByteSlice`. -/ @[specialize] protected def forIn [Monad m] (s : ByteSlice) (init : β) (f : UInt8 → β → m (ForInStep β)) : m β := loop s.size (Nat.le_refl _) init where /-- Inner loop of the `forIn` implementation for `ByteSlice`. -/ loop (i : Nat) (h : i ≤ s.size) (b : β) : m β := do match i, h with | 0, _ => pure b | i+1, h => match (← f s[s.size - 1 - i] b) with | ForInStep.done b => pure b | ForInStep.yield b => loop i (Nat.le_of_succ_le h) b instance [Monad m] : ForIn m ByteSlice UInt8 where forIn := ByteSlice.forIn instance : Std.Stream ByteSlice UInt8 where next? s := s[0]? >>= (·, s.popFront) instance : Coe ByteArray ByteSlice where coe := ByteArray.toByteSlice end ByteSlice namespace Batteries /-- A subarray of a `ByteArray`. -/ @[deprecated ByteSlice (since := "2025-10-04")] structure ByteSubarray where /-- `O(1)`. Get data array of a `ByteSubarray`. -/ array : ByteArray /-- `O(1)`. Get start index of a `ByteSubarray`. -/ start : Nat /-- `O(1)`. Get stop index of a `ByteSubarray`. -/ stop : Nat /-- Start index is before stop index. -/ start_le_stop : start ≤ stop /-- Stop index is before end of data array. -/ stop_le_array_size : stop ≤ array.size namespace ByteSubarray set_option linter.deprecated false attribute [deprecated ByteSlice.byteArray (since := "2025-10-04")] ByteSubarray.array attribute [deprecated ByteSlice.start (since := "2025-10-04")] ByteSubarray.start attribute [deprecated ByteSlice.stop (since := "2025-10-04")] ByteSubarray.stop attribute [deprecated ByteSlice.start_le_stop (since := "2025-10-04")] ByteSubarray.start_le_stop attribute [deprecated ByteSlice.stop_le_size_byteArray (since := "2025-10-04")] ByteSubarray.stop_le_array_size /-- `O(1)`. Get the size of a `ByteSubarray`. -/ @[deprecated ByteSlice.size (since := "2025-10-04")] protected def size (self : ByteSubarray) := self.stop - self.start /-- `O(1)`. Test if a `ByteSubarray` is empty. -/ @[deprecated ByteSlice.isEmpty (since := "2025-10-04")] protected def isEmpty (self : ByteSubarray) := self.start == self.stop @[deprecated ByteSlice.stop_eq_start_add_size (since := "2025-10-04")] theorem stop_eq_start_add_size (self : ByteSubarray) : self.stop = self.start + self.size := by rw [ByteSubarray.size, Nat.add_sub_cancel' self.start_le_stop] /-- `O(n)`. Extract a `ByteSubarray` to a `ByteArray`. -/ @[deprecated ByteSlice.toByteArray (since := "2025-10-04")] def toByteArray (self : ByteSubarray) : ByteArray := self.array.extract self.start self.stop /-- `O(1)`. Get the element at index `i` from the start of a `ByteSubarray`. -/ @[deprecated ByteSlice.get (since := "2025-10-04"), inline] def get (self : ByteSubarray) (i : Fin self.size) : UInt8 := have : self.start + i.1 < self.array.size := by apply Nat.lt_of_lt_of_le _ self.stop_le_array_size rw [stop_eq_start_add_size] apply Nat.add_lt_add_left i.is_lt self.start self.array[self.start + i.1] instance : GetElem ByteSubarray Nat UInt8 fun self i => i < self.size where getElem self i h := self.get ⟨i, h⟩ /-- `O(1)`. Pop the last element of a `ByteSubarray`. -/ @[deprecated ByteSlice.pop (since := "2025-10-04"), inline] def pop (self : ByteSubarray) : ByteSubarray := if h : self.start = self.stop then self else {self with stop := self.stop - 1 start_le_stop := Nat.le_pred_of_lt (Nat.lt_of_le_of_ne self.start_le_stop h) stop_le_array_size := Nat.le_trans (Nat.pred_le _) self.stop_le_array_size } /-- `O(1)`. Pop the first element of a `ByteSubarray`. -/ @[deprecated ByteSlice.popFront (since := "2025-10-04"), inline] def popFront (self : ByteSubarray) : ByteSubarray := if h : self.start = self.stop then self else {self with start := self.start + 1 start_le_stop := Nat.succ_le_of_lt (Nat.lt_of_le_of_ne self.start_le_stop h) } /-- Folds a monadic function over a `ByteSubarray` from left to right. -/ @[deprecated ByteSlice.foldlM (since := "2025-10-04"), inline] def foldlM [Monad m] (self : ByteSubarray) (f : β → UInt8 → m β) (init : β) : m β := self.array.foldlM f init self.start self.stop /-- Folds a function over a `ByteSubarray` from left to right. -/ @[deprecated ByteSlice.foldl (since := "2025-10-04"), inline] def foldl (self : ByteSubarray) (f : β → UInt8 → β) (init : β) : β := self.foldlM (m:=Id) f init /-- Implementation of `forIn` for a `ByteSubarray`. -/ @[specialize] --@[deprecated ByteSlice.forIn (since := "2025-10-04"), specialize] protected def forIn [Monad m] (self : ByteSubarray) (init : β) (f : UInt8 → β → m (ForInStep β)) : m β := loop self.size (Nat.le_refl _) init where /-- Inner loop of the `forIn` implementation for `ByteSubarray`. -/ loop (i : Nat) (h : i ≤ self.size) (b : β) : m β := do match i, h with | 0, _ => pure b | i+1, h => match (← f self[self.size - 1 - i] b) with | ForInStep.done b => pure b | ForInStep.yield b => loop i (Nat.le_of_succ_le h) b instance [Monad m] : ForIn m ByteSubarray UInt8 where forIn := ByteSubarray.forIn instance : Std.Stream ByteSubarray UInt8 where next? s := s[0]? >>= fun x => (x, s.popFront) end Batteries.ByteSubarray set_option linter.deprecated false in /-- `O(1)`. Coerce a byte array into a byte slice. -/ @[deprecated ByteArray.toByteSlice (since := "2025-10-04")] def ByteArray.toByteSubarray (array : ByteArray) : Batteries.ByteSubarray where array := array start := 0 stop := array.size start_le_stop := Nat.zero_le _ stop_le_array_size := Nat.le_refl _ set_option linter.deprecated false in instance : Coe ByteArray Batteries.ByteSubarray where coe := ByteArray.toByteSubarray ================================================ FILE: Batteries/Data/Char/AsciiCasing.lean ================================================ /- Copyright (c) 2025 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Data.Char.Basic public import Batteries.Tactic.Basic @[expose] public section /-! # Lemmas for ASCII-casing These facts apply for ASCII characters only. Recall that `isAlpha`, `isLower`, `isUpper`, `toLower`, `toUpper` do not consider characters outside the ASCII character range (code points less than 128). -/ namespace Char theorem not_isLower_of_isUpper {c : Char} : c.isUpper → ¬ c.isLower := by simp [isUpper, UInt32.le_iff_toNat_le, isLower] omega theorem not_isUpper_of_isLower {c : Char} : c.isLower → ¬ c.isUpper := by simp [isUpper, UInt32.le_iff_toNat_le, isLower] omega theorem toLower_eq_of_not_isUpper {c : Char} (h : ¬ c.isUpper) : c.toLower = c := by simp_all [isUpper, UInt32.le_iff_toNat_le, toLower] omega theorem toLower_eq_of_isUpper {c : Char} (h : c.isUpper) : c.toLower = ofNat (c.toNat + 32) := by ext rw [val_ofNat, UInt32.ofNat_add] · simp_all [isUpper, toLower] · simp [isUpper, UInt32.le_iff_toNat_le] at h; grind theorem toUpper_eq_of_not_isLower {c : Char} (h : ¬ c.isLower) : c.toUpper = c := by simp only [isLower, Bool.and_eq_true, decide_eq_true_eq] at h simp only [toUpper, dif_neg h] theorem toUpper_eq_of_isLower {c : Char} (h : c.isLower) : c.toUpper = ofNat (c.toNat - 32) := by ext rw [val_ofNat, UInt32.ofNat_sub] · simp_all [toUpper, isLower]; grind · simp [isLower, UInt32.le_iff_toNat_le] at h; grind · simp [isLower, UInt32.le_iff_toNat_le] at h; grind @[simp] theorem isUpper_toLower_eq_false (c : Char) : c.toLower.isUpper = false := by simp only [isUpper, toLower] split <;> grind [UInt32.toNat_add, toNat_val] @[simp] theorem isLower_toUpper_eq_false (c : Char) : c.toUpper.isLower = false := by simp only [isLower, toUpper] split <;> grind [UInt32.toNat_add, toNat_val] @[simp] theorem isLower_toLower_eq_isAlpha (c : Char) : c.toLower.isLower = c.isAlpha := by rw [Bool.eq_iff_iff] by_cases h : c.isUpper · simp only [isLower, h, toLower_eq_of_isUpper, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.and_eq_true, decide_eq_true_eq, isAlpha, Bool.true_or, iff_true] simp only [isUpper, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.decide_and, Bool.and_eq_true, decide_eq_true_eq] at h have : (c.toNat + 32).isValidChar := by omega simp [toNat_ofNat, *] · simp [toLower_eq_of_not_isUpper, isAlpha, h] @[simp] theorem isUpper_toUpper_eq_isAlpha (c : Char) : c.toUpper.isUpper = c.isAlpha := by rw [Bool.eq_iff_iff] by_cases h : c.isLower · simp only [isUpper, h, toUpper_eq_of_isLower, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.decide_and, Bool.and_eq_true, decide_eq_true_eq, isAlpha, Bool.or_true, iff_true] simp only [isLower, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.and_eq_true, decide_eq_true_eq] at h have : (c.toNat - 32).isValidChar := by omega have : 32 ≤ c.toNat := by omega simp [toNat_ofNat, Nat.le_sub_iff_add_le, *] · simp [toUpper_eq_of_not_isLower, isAlpha, h] @[simp] theorem isAlpha_toLower_eq_isAlpha (c : Char) : c.toLower.isAlpha = c.isAlpha := by simp [isAlpha] @[simp] theorem isAlpha_toUpper_eq_isAlpha (c : Char) : c.toUpper.isAlpha = c.isAlpha := by simp [isAlpha] @[simp] theorem toLower_toLower_eq_toLower (c : Char) : c.toLower.toLower = c.toLower := by simp [toLower_eq_of_not_isUpper] @[simp] theorem toLower_toUpper_eq_toLower (c : Char) : c.toUpper.toLower = c.toLower := by by_cases hl : c.isLower · have hu : ¬ c.isUpper := not_isUpper_of_isLower hl have hu' : c.toUpper.isUpper := by simp [isAlpha, hl] have hv : (c.toNat - 32).isValidChar := by simp only [isLower, isUpper, UInt32.le_iff_toNat_le, toNat_val] at hl hu grind have h : 32 ≤ c.toNat := by simp only [isLower, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.and_eq_true, decide_eq_true_eq, isUpper, Bool.decide_and, not_and, Nat.not_le] at hl hu omega rw [toLower_eq_of_isUpper hu', toUpper_eq_of_isLower hl, toLower_eq_of_not_isUpper hu, toNat_ofNat, if_pos hv, Nat.sub_add_cancel h, ofNat_toNat] · rw [toUpper_eq_of_not_isLower hl] @[simp] theorem toUpper_toUpper_eq_toUpper (c : Char) : c.toUpper.toUpper = c.toUpper := by simp [toUpper_eq_of_not_isLower] @[simp] theorem toUpper_toLower_eq_toUpper (c : Char) : c.toLower.toUpper = c.toUpper := by by_cases hu : c.isUpper · have hl : ¬ c.isLower := not_isLower_of_isUpper hu have hl' : c.toLower.isLower := by simp [isAlpha, hu] have hv : (c.toNat + 32).isValidChar := by simp only [isUpper, ↓Char.isValue, Char.reduceVal, ge_iff_le, UInt32.le_iff_toNat_le, UInt32.reduceToNat, toNat_val, Bool.decide_and, Bool.and_eq_true, decide_eq_true_eq, isLower, not_and, Nat.not_le] at hu hl omega rw [toUpper_eq_of_isLower hl', toLower_eq_of_isUpper hu, toUpper_eq_of_not_isLower hl, toNat_ofNat, if_pos hv, Nat.add_sub_cancel, ofNat_toNat] · rw [toLower_eq_of_not_isUpper hu] /-- Case folding for ASCII characters only. Alphabetic ASCII characters are mapped to their lowercase form, all other characters are left unchanged. This agrees with the Unicode case folding algorithm for ASCII characters. ``` #eval caseFoldAsciiOnly 'A' == 'a' #eval caseFoldAsciiOnly 'a' == 'a' #eval caseFoldAsciiOnly 'À' == 'À' #eval caseFoldAsciiOnly 'à' == 'à' #eval caseFoldAsciiOnly '$' == '$' ``` -/ abbrev caseFoldAsciiOnly := Char.toLower /-- Bool-valued comparison of two `Char`s for *ASCII*-case insensitive equality. ``` #eval beqCaseInsensitiveAsciiOnly 'a' 'A' -- true #eval beqCaseInsensitiveAsciiOnly 'a' 'a' -- true #eval beqCaseInsensitiveAsciiOnly '$' '$' -- true #eval beqCaseInsensitiveAsciiOnly 'a' 'b' -- false #eval beqCaseInsensitiveAsciiOnly 'γ' 'Γ' -- false #eval beqCaseInsensitiveAsciiOnly 'ä' 'Ä' -- false ``` -/ def beqCaseInsensitiveAsciiOnly (c₁ c₂ : Char) : Bool := c₁.caseFoldAsciiOnly == c₂.caseFoldAsciiOnly theorem beqCaseInsensitiveAsciiOnly.eqv : Equivalence (beqCaseInsensitiveAsciiOnly · ·) := { refl _ := BEq.rfl trans _ _ := by simp_all [beqCaseInsensitiveAsciiOnly] symm := by simp_all [beqCaseInsensitiveAsciiOnly]} /-- Setoid structure on `Char` using `beqCaseInsensitiveAsciiOnly` -/ @[implicit_reducible] def beqCaseInsensitiveAsciiOnly.isSetoid : Setoid Char:= ⟨(beqCaseInsensitiveAsciiOnly · ·), beqCaseInsensitiveAsciiOnly.eqv⟩ /-- ASCII-case insensitive implementation comparison returning an `Ordering`. Useful for sorting. ``` #eval cmpCaseInsensitiveAsciiOnly 'a' 'A' -- eq #eval cmpCaseInsensitiveAsciiOnly 'a' 'a' -- eq #eval cmpCaseInsensitiveAsciiOnly '$' '$' -- eq #eval cmpCaseInsensitiveAsciiOnly 'a' 'b' -- lt #eval cmpCaseInsensitiveAsciiOnly 'γ' 'Γ' -- gt #eval cmpCaseInsensitiveAsciiOnly 'ä' 'Ä' -- gt ``` -/ def cmpCaseInsensitiveAsciiOnly (c₁ c₂ : Char) : Ordering := compare c₁.caseFoldAsciiOnly c₂.caseFoldAsciiOnly ================================================ FILE: Batteries/Data/Char/Basic.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg, François G. Dorais -/ module public import Batteries.Classes.Order public import Batteries.Data.List.Lemmas @[expose] public section namespace Char theorem le_antisymm_iff {x y : Char} : x = y ↔ x ≤ y ∧ y ≤ x := Char.ext_iff.trans UInt32.le_antisymm_iff instance : Std.LawfulOrd Char := .compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt Char.le_antisymm @[simp] theorem toNat_ofNatAux {n : Nat} (h : n.isValidChar) : toNat (ofNatAux n h) = n := by simp [ofNatAux, toNat] theorem toNat_ofNat (n : Nat) : toNat (ofNat n) = if n.isValidChar then n else 0 := by split · simp [ofNat, *] · simp [ofNat, toNat, *] @[simp] theorem val_ofNat (hn : Nat.isValidChar n) : (ofNat n).val = UInt32.ofNat n := by simp [ofNat, hn, ofNatAux, UInt32.ofNatLT_eq_ofNat] @[simp] theorem ofNat_toNat_eq_val {c : Char} : UInt32.ofNat c.toNat = c.val := by rw [← toNat_val, UInt32.ofNat_toNat] /-- Maximum character code point. (See [unicode scalar value](https://www.unicode.org/glossary/#unicode_scalar_value).) -/ protected abbrev max := 0x10FFFF /-- Maximum surrogate code point. (See [unicode scalar value](https://www.unicode.org/glossary/#unicode_scalar_value).) -/ protected abbrev maxSurrogate := 0xDFFF /-- Minimum surrogate code point. (See [unicode scalar value](https://www.unicode.org/glossary/#unicode_scalar_value).) -/ protected abbrev minSurrogate := 0xD800 /-- Number of valid character code points. (See [unicode scalar value](https://www.unicode.org/glossary/#unicode_scalar_value).) -/ protected abbrev count := Char.max - Char.maxSurrogate + Char.minSurrogate @[grind .] theorem toNat_le_max (c : Char) : c.toNat ≤ Char.max := by match c.valid with | .inl h => simp only [toNat_val] at h; grind | .inr ⟨_, h⟩ => simp only [toNat_val] at h; grind @[grind .] theorem toNat_not_surrogate (c : Char) : ¬(Char.minSurrogate ≤ c.toNat ∧ c.toNat ≤ Char.maxSurrogate) := by match c.valid with | .inl h => simp only [toNat_val] at h; grind | .inr ⟨h, _⟩ => simp only [toNat_val] at h; grind /-- Returns `true` if `p` returns true for every `Char`. -/ protected def all (p : Char → Bool) : Bool := Nat.all Char.minSurrogate (fun c h₁ => p <| Char.ofNatAux c <| .inl h₁) && Nat.all (Char.max - Char.maxSurrogate) fun c h₂ => p <| Char.ofNatAux (c + (Char.maxSurrogate + 1)) <| .inr (by grind) private theorem of_all_eq_true_aux (h : Char.all p) (n : Nat) (hn : n.isValidChar) : p (.ofNatAux n hn) := by simp only [Char.all, Nat.all_eq_finRange_all, List.all_eq_true, Bool.and_eq_true] at h match hn with | .inl hn => have := h.1 ⟨n, by grind⟩ grind | .inr ⟨hn, hn'⟩ => -- https://github.com/leanprover/lean4/issues/11059 have := h.2 ⟨n - (Char.maxSurrogate + 1), by rw [Char.maxSurrogate, Char.max]; omega ⟩ grind theorem eq_true_of_all_eq_true (h : Char.all p) (c : Char) : p c := by have : c.toNat.isValidChar := c.valid rw [← c.ofNat_toNat, ofNat, dif_pos this] exact of_all_eq_true_aux h c.toNat this theorem exists_eq_false_of_all_eq_false (h : Char.all p = false) : ∃ c, p c = false := by simp only [Char.all, Nat.all_eq_finRange_all, List.all_eq_false, Bool.and_eq_false_iff] at h simp only [Bool.eq_false_iff] match h with | .inl ⟨⟨n, hn⟩, _, h⟩ => exact ⟨Char.ofNatAux n (.inl hn), h⟩ | .inr ⟨⟨n, _⟩, _, h⟩ => exact ⟨Char.ofNatAux (n + (Char.maxSurrogate + 1)) (.inr (by grind)), h⟩ theorem all_eq_true_iff_forall_eq_true : Char.all p = true ↔ ∀ c, p c = true := by constructor · exact eq_true_of_all_eq_true · intro h cases heq : Char.all p · obtain ⟨c, hc⟩ := exists_eq_false_of_all_eq_false heq simp [h c] at hc · trivial /-- Returns `true` if `p` returns true for some `Char`. -/ protected def any (p : Char → Bool) : Bool := Nat.any Char.minSurrogate (fun c h₁ => p <| Char.ofNatAux c <| .inl h₁) || Nat.any (Char.max - Char.maxSurrogate) fun c h₂ => p <| Char.ofNatAux (c + Char.maxSurrogate + 1) <| .inr (by grind) theorem exists_eq_true_of_any_eq_true (h : Char.any p = true) : ∃ c, p c = true := by simp only [Char.any, Nat.any_eq_finRange_any, List.any_eq_true, Bool.or_eq_true] at h match h with | .inl ⟨⟨n, hn⟩, _, h⟩ => exact ⟨Char.ofNatAux n (.inl hn), h⟩ | .inr ⟨⟨n, _⟩, _, h⟩ => exact ⟨Char.ofNatAux (n + Char.maxSurrogate + 1) (.inr (by grind)), h⟩ private theorem of_any_eq_false_aux (h : Char.any p = false) (n : Nat) (hn : n.isValidChar) : p (.ofNatAux n hn) = false := by simp only [Char.any, Nat.any_eq_finRange_any, List.any_eq_false, Bool.or_eq_false_iff] at h match hn with | .inl hn => have := h.1 ⟨n, hn⟩ (List.mem_finRange _) grind | .inr ⟨hn, hn'⟩ => -- https://github.com/leanprover/lean4/issues/11059 have := h.2 ⟨n - (Char.maxSurrogate + 1), by rw [Char.maxSurrogate, Char.max]; omega⟩ (List.mem_finRange _) grind theorem eq_false_of_any_eq_false (h : Char.any p = false) (c : Char) : p c = false := by have : c.toNat.isValidChar := c.valid rw [← c.ofNat_toNat, ofNat, dif_pos this] exact of_any_eq_false_aux h c.toNat this theorem any_eq_true_iff_exists_eq_true : Char.any p = true ↔ ∃ c, p c = true := by constructor · exact exists_eq_true_of_any_eq_true · intro h cases heq : Char.any p · obtain ⟨c, hc⟩ := h simp [eq_false_of_any_eq_false heq] at hc · trivial instance (P : Char → Prop) [DecidablePred P] : Decidable (∀ c, P c) := match h : Char.all (P ·) with | true => isTrue <| fun c => of_decide_eq_true <| eq_true_of_all_eq_true h c | false => isFalse <| not_forall_of_exists_not <| match exists_eq_false_of_all_eq_false h with | ⟨c, hc⟩ => ⟨c, of_decide_eq_false hc⟩ instance (P : Char → Prop) [DecidablePred P] : Decidable (∃ c, P c) := match h : Char.any (P ·) with | false => isFalse <| not_exists_of_forall_not <| fun c => of_decide_eq_false <| eq_false_of_any_eq_false h c | true => isTrue <| match exists_eq_true_of_any_eq_true h with | ⟨c, hc⟩ => ⟨c, of_decide_eq_true hc⟩ ================================================ FILE: Batteries/Data/Char.lean ================================================ module public import Batteries.Data.Char.AsciiCasing public import Batteries.Data.Char.Basic ================================================ FILE: Batteries/Data/DList/Basic.lean ================================================ /- Copyright (c) 2018 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura -/ module @[expose] public section namespace Batteries /-- A difference List is a Function that, given a List, returns the original contents of the difference List prepended to the given List. This structure supports `O(1)` `append` and `push` operations on lists, making it useful for append-heavy uses such as logging and pretty printing. -/ structure DList (α : Type u) where /-- "Run" a `DList` by appending it on the right by a `List α` to get another `List α`. -/ apply : List α → List α /-- The `apply` function of a `DList` is completely determined by the list `apply []`. -/ invariant : ∀ l, apply l = apply [] ++ l attribute [simp] DList.apply namespace DList variable {α : Type u} open List /-- `O(1)` (`apply` is `O(|l|)`). Convert a `List α` into a `DList α`. -/ def ofList (l : List α) : DList α := ⟨(l ++ ·), fun t => by simp⟩ /-- `O(1)` (`apply` is `O(1)`). Return an empty `DList α`. -/ def empty : DList α := ⟨id, fun _ => rfl⟩ instance : EmptyCollection (DList α) := ⟨DList.empty⟩ instance : Inhabited (DList α) := ⟨DList.empty⟩ /-- `O(apply())`. Convert a `DList α` into a `List α` by running the `apply` function. -/ @[simp] def toList : DList α → List α | ⟨f, _⟩ => f [] /-- `O(1)` (`apply` is `O(1)`). A `DList α` corresponding to the list `[a]`. -/ def singleton (a : α) : DList α where apply := fun t => a :: t invariant := fun _ => rfl /-- `O(1)` (`apply` is `O(1)`). Prepend `a` on a `DList α`. -/ def cons : α → DList α → DList α | a, ⟨f, h⟩ => { apply := fun t => a :: f t invariant := by intro t; simp; rw [h] } /-- `O(1)` (`apply` is `O(1)`). Append two `DList α`. -/ def append : DList α → DList α → DList α | ⟨f, h₁⟩, ⟨g, h₂⟩ => { apply := f ∘ g invariant := by intro t show f (g t) = (f (g [])) ++ t rw [h₁ (g t), h₂ t, ← append_assoc (f []) (g []) t, ← h₁ (g [])] } /-- `O(1)` (`apply` is `O(1)`). Append an element at the end of a `DList α`. -/ def push : DList α → α → DList α | ⟨f, h⟩, a => { apply := fun t => f (a :: t) invariant := by intro t show f (a :: t) = f (a :: nil) ++ t rw [h [a], h (a::t), append_assoc (f []) [a] t] rfl } instance : Append (DList α) := ⟨DList.append⟩ /-- Convert a lazily-evaluated `List` to a `DList` -/ def ofThunk (l : Thunk (List α)) : DList α := ⟨fun xs => l.get ++ xs, fun t => by simp⟩ /-- Concatenates a list of difference lists to form a single difference list. Similar to `List.join`. -/ def join {α : Type _} : List (DList α) → DList α | [] => DList.empty | x :: xs => x ++ DList.join xs ================================================ FILE: Batteries/Data/DList/Lemmas.lean ================================================ /- Copyright (c) 2017 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura -/ module public import Batteries.Data.DList.Basic @[expose] public section /-! # Difference list This file provides a few results about `DList`. A difference list is a function that, given a list, returns the original content of the difference list prepended to the given list. It is useful to represent elements of a given type as `a₁ + ... + aₙ` where `+ : α → α → α` is any operation, without actually computing. This structure supports `O(1)` `append` and `push` operations on lists, making it useful for append-heavy uses such as logging and pretty printing. -/ namespace Batteries.DList open Function theorem toList_ofList (l : List α) : DList.toList (DList.ofList l) = l := by cases l; rfl; simp [ofList] theorem ofList_toList (l : DList α) : DList.ofList (DList.toList l) = l := by obtain ⟨app, inv⟩ := l simp only [ofList, toList, mk.injEq] funext x rw [(inv x)] theorem toList_empty : toList (@empty α) = [] := by simp [empty] theorem toList_singleton (x : α) : toList (singleton x) = [x] := by simp [singleton] theorem toList_append (l₁ l₂ : DList α) : toList (l₁ ++ l₂) = toList l₁ ++ toList l₂ := by simp only [toList, append, Function.comp]; rw [invariant] theorem toList_cons (x : α) (l : DList α) : toList (cons x l) = x :: toList l := by cases l; simp [cons] theorem toList_push (x : α) (l : DList α) : toList (push l x) = toList l ++ [x] := by simp only [toList, push]; rw [invariant] @[simp] theorem singleton_eq_ofThunk {α : Type _} {a : α} : singleton a = ofThunk [a] := rfl @[simp] theorem ofThunk_coe {α : Type _} {l : List α} : ofThunk l = ofList l := rfl end Batteries.DList ================================================ FILE: Batteries/Data/DList.lean ================================================ module public import Batteries.Data.DList.Basic public import Batteries.Data.DList.Lemmas ================================================ FILE: Batteries/Data/Fin/Basic.lean ================================================ /- Copyright (c) 2017 Robert Y. Lewis. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Robert Y. Lewis, Keeley Hoek, Mario Carneiro, François G. Dorais, Quang Dao -/ module public import Batteries.Data.Nat.Lemmas @[expose] public section namespace Fin /-- `min n m` as an element of `Fin (m + 1)` -/ def clamp (n m : Nat) : Fin (m + 1) := ⟨min n m, Nat.lt_succ_of_le (Nat.min_le_right ..)⟩ /-- Heterogeneous monadic fold over `Fin n` from right to left: ``` Fin.foldrM n f xₙ = do let xₙ₋₁ : α (n-1) ← f (n-1) xₙ let xₙ₋₂ : α (n-2) ← f (n-2) xₙ₋₁ ... let x₀ : α 0 ← f 0 x₁ pure x₀ ``` This is the dependent version of `Fin.foldrM`. -/ @[inline] def dfoldrM [Monad m] (n : Nat) (α : Fin (n + 1) → Type _) (f : ∀ (i : Fin n), α i.succ → m (α i.castSucc)) (init : α (last n)) : m (α 0) := loop n (Nat.lt_succ_self n) init where /-- Inner loop for `Fin.dfoldrM`. ``` Fin.dfoldrM.loop n f i h xᵢ = do let xᵢ₋₁ ← f (i-1) xᵢ ... let x₁ ← f 1 x₂ let x₀ ← f 0 x₁ pure x₀ ``` -/ @[specialize] loop (i : Nat) (h : i < n + 1) (x : α ⟨i, h⟩) : m (α 0) := match i with | i + 1 => (f ⟨i, Nat.lt_of_succ_lt_succ h⟩ x) >>= loop i (Nat.lt_of_succ_lt h) | 0 => pure x /-- Heterogeneous fold over `Fin n` from the right: `foldr 3 f x = f 0 (f 1 (f 2 x))`, where `f 2 : α 3 → α 2`, `f 1 : α 2 → α 1`, etc. This is the dependent version of `Fin.foldr`. -/ @[inline] def dfoldr (n : Nat) (α : Fin (n + 1) → Type _) (f : ∀ (i : Fin n), α i.succ → α i.castSucc) (init : α (last n)) : α 0 := dfoldrM (m := Id) n α f init /-- Heterogeneous monadic fold over `Fin n` from left to right: ``` Fin.foldlM n f x₀ = do let x₁ : α 1 ← f 0 x₀ let x₂ : α 2 ← f 1 x₁ ... let xₙ : α n ← f (n-1) xₙ₋₁ pure xₙ ``` This is the dependent version of `Fin.foldlM`. -/ @[inline] def dfoldlM [Monad m] (n : Nat) (α : Fin (n + 1) → Type _) (f : ∀ (i : Fin n), α i.castSucc → m (α i.succ)) (init : α 0) : m (α (last n)) := loop 0 (Nat.zero_lt_succ n) init where /-- Inner loop for `Fin.dfoldlM`. ``` Fin.foldM.loop n α f i h xᵢ = do let xᵢ₊₁ : α (i+1) ← f i xᵢ ... let xₙ : α n ← f (n-1) xₙ₋₁ pure xₙ ``` -/ @[specialize] loop (i : Nat) (h : i < n + 1) (x : α ⟨i, h⟩) : m (α (last n)) := if h' : i < n then (f ⟨i, h'⟩ x) >>= loop (i + 1) (Nat.succ_lt_succ h') else haveI : ⟨i, h⟩ = last n := by ext; simp; omega _root_.cast (congrArg (fun i => m (α i)) this) (pure x) /-- Heterogeneous fold over `Fin n` from the left: `foldl 3 f x = f 0 (f 1 (f 2 x))`, where `f 0 : α 0 → α 1`, `f 1 : α 1 → α 2`, etc. This is the dependent version of `Fin.foldl`. -/ @[inline] def dfoldl (n : Nat) (α : Fin (n + 1) → Type _) (f : ∀ (i : Fin n), α i.castSucc → α i.succ) (init : α 0) : α (last n) := dfoldlM (m := Id) n α f init /-- Sum of a tuple indexed by `Fin n`. -/ @[inline] protected def sum [Zero α] [Add α] (x : Fin n → α) : α := foldr n (x · + ·) 0 /-- Product of a tuple indexed by `Fin n`. -/ @[inline] protected def prod [One α] [Mul α] (x : Fin n → α) : α := foldr n (x · * ·) 1 /-- Count the number of true values of a decidable predicate on `Fin n`. -/ @[inline] protected def countP (p : Fin n → Bool) : Nat := Fin.sum (p · |>.toNat) /-- `findSome? f` returns `f i` for the first `i` for which `f i` is `some _`, or `none` if no such element is found. The function `f` is not evaluated on further inputs after the first `i` is found. -/ @[inline] def findSome? (f : Fin n → Option α) : Option α := foldl n (fun r i => r <|> f i) none /-- `findSomeRev? f` returns `f i` for the last `i` for which `f i` is `some _`, or `none` if no such element is found. The function `f` is not evaluated on further inputs after the first `i` is found. -/ @[inline] def findSomeRev? (f : Fin n → Option α) : Option α := findSome? (f ·.rev) /-- `find? p` returns the first `i` for which `p i = true`, or `none` if no such element is found. The function `p` is not evaluated on further inputs after the first `i` is found. -/ @[inline] abbrev find? (p : Fin n → Bool) : Option (Fin n) := findSome? <| Option.guard p /-- `find? p` returns the first `i` for which `p i = true`, or `none` if no such element is found. The function `p` is not evaluated on further inputs after the first `i` is found. -/ @[inline] abbrev findRev? (p : Fin n → Bool) : Option (Fin n) := findSomeRev? <| Option.guard p /-- Compute `i / n`, where `n` is a `Nat` and inferred the type of `i`. -/ def divNat (i : Fin (m * n)) : Fin m := ⟨i / n, Nat.div_lt_of_lt_mul <| Nat.mul_comm m n ▸ i.is_lt⟩ /-- Compute `i % n`, where `n` is a `Nat` and inferred the type of `i`. -/ def modNat (i : Fin (m * n)) : Fin n := ⟨i % n, Nat.mod_lt _ <| Nat.pos_of_mul_pos_left i.pos⟩ /-- Compute the element of `Fin (m * n)` with quotient `i : Fin m` and remainder `j : Fin n` when divided by `n`. -/ def mkDivMod (i : Fin m) (j : Fin n) : Fin (m * n) := ⟨n * i + j, Nat.mul_add_lt_mul_of_lt_of_lt i.is_lt j.is_lt⟩ ================================================ FILE: Batteries/Data/Fin/Fold.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais, Quang Dao -/ module public import Batteries.Tactic.Alias public import Batteries.Data.Fin.Basic @[expose] public section namespace Fin /-! ### dfoldrM -/ theorem dfoldrM_loop_zero [Monad m] (f : (i : Fin n) → α i.succ → m (α i.castSucc)) (x) : dfoldrM.loop n α f 0 h x = pure x := rfl theorem dfoldrM_loop_succ [Monad m] (f : (i : Fin n) → α i.succ → m (α i.castSucc)) (x) : dfoldrM.loop n α f (i+1) h x = f ⟨i, by omega⟩ x >>= dfoldrM.loop n α f i (by omega) := rfl -- TODO: This proof needs adjustment for lean4#12179 (backward.isDefEq.respectTransparency) set_option backward.isDefEq.respectTransparency false in theorem dfoldrM_loop [Monad m] [LawfulMonad m] (f : (i : Fin (n+1)) → α i.succ → m (α i.castSucc)) (x) : dfoldrM.loop (n+1) α f (i+1) h x = dfoldrM.loop n (α ∘ succ) (f ·.succ) i (by omega) x >>= f 0 := by induction i with | zero => rw [dfoldrM_loop_zero, dfoldrM_loop_succ, pure_bind] conv => rhs; rw [← bind_pure (f 0 x)] rfl | succ i ih => rw [dfoldrM_loop_succ, dfoldrM_loop_succ, bind_assoc] congr; funext; exact ih .. @[simp] theorem dfoldrM_zero [Monad m] (f : (i : Fin 0) → α i.succ → m (α i.castSucc)) (x) : dfoldrM 0 α f x = pure x := rfl theorem dfoldrM_succ [Monad m] [LawfulMonad m] (f : (i : Fin (n+1)) → α i.succ → m (α i.castSucc)) (x) : dfoldrM (n+1) α f x = dfoldrM n (α ∘ succ) (f ·.succ) x >>= f 0 := dfoldrM_loop .. theorem dfoldrM_eq_foldrM [Monad m] [LawfulMonad m] (f : (i : Fin n) → α → m α) (x) : dfoldrM n (fun _ => α) f x = foldrM n f x := by induction n with | zero => simp only [dfoldrM_zero, foldrM_zero] | succ n ih => simp only [dfoldrM_succ, foldrM_succ, Function.comp_def, ih] theorem dfoldr_eq_dfoldrM (f : (i : Fin n) → α i.succ → α i.castSucc) (x) : dfoldr n α f x = dfoldrM (m:=Id) n α f x := rfl /-! ### dfoldr -/ @[simp] theorem dfoldr_zero (f : (i : Fin 0) → α i.succ → α i.castSucc) (x) : dfoldr 0 α f x = x := rfl theorem dfoldr_succ (f : (i : Fin (n+1)) → α i.succ → α i.castSucc) (x) : dfoldr (n+1) α f x = f 0 (dfoldr n (α ∘ succ) (f ·.succ) x) := dfoldrM_succ .. theorem dfoldr_succ_last {n : Nat} {α : Fin (n+2) → Sort _} (f : (i : Fin (n+1)) → α i.succ → α i.castSucc) (x : α (last (n+1))) : dfoldr (n+1) α f x = dfoldr n (α ∘ castSucc) (f ·.castSucc) (f (last n) x) := by induction n with | zero => simp only [dfoldr_succ, dfoldr_zero, last, zero_eta] | succ n ih => rw [dfoldr_succ, ih (α := α ∘ succ) (f ·.succ), dfoldr_succ]; congr theorem dfoldr_eq_foldr (f : (i : Fin n) → α → α) (x) : dfoldr n (fun _ => α) f x = foldr n f x := by induction n with | zero => simp only [dfoldr_zero, foldr_zero] | succ n ih => simp only [dfoldr_succ, foldr_succ, Function.comp_def, ih] /-! ### dfoldlM -/ theorem dfoldlM_loop_lt [Monad m] (f : ∀ (i : Fin n), α i.castSucc → m (α i.succ)) (h : i < n) (x) : dfoldlM.loop n α f i (Nat.lt_add_right 1 h) x = (f ⟨i, h⟩ x) >>= (dfoldlM.loop n α f (i+1) (Nat.add_lt_add_right h 1)) := by rw [dfoldlM.loop, dif_pos h] theorem dfoldlM_loop_eq [Monad m] (f : ∀ (i : Fin n), α i.castSucc → m (α i.succ)) (x) : dfoldlM.loop n α f n (Nat.le_refl _) x = pure x := by rw [dfoldlM.loop, dif_neg (Nat.lt_irrefl _)]; rfl @[simp] theorem dfoldlM_zero [Monad m] (f : (i : Fin 0) → α i.castSucc → m (α i.succ)) (x) : dfoldlM 0 α f x = pure x := by simp [dfoldlM, dfoldlM.loop] theorem dfoldlM_loop [Monad m] (f : (i : Fin (n+1)) → α i.castSucc → m (α i.succ)) (h : i < n+1) (x) : dfoldlM.loop (n+1) α f i (Nat.lt_add_right 1 h) x = f ⟨i, h⟩ x >>= (dfoldlM.loop n (α ∘ succ) (f ·.succ ·) i h .) := by if h' : i < n then rw [dfoldlM_loop_lt _ h _] congr; funext rw [dfoldlM_loop_lt _ h' _, dfoldlM_loop]; rfl else cases Nat.le_antisymm (Nat.le_of_lt_succ h) (Nat.not_lt.1 h') rw [dfoldlM_loop_lt _ h] congr; funext rw [dfoldlM_loop_eq, dfoldlM_loop_eq]; rfl theorem dfoldlM_succ [Monad m] (f : (i : Fin (n+1)) → α i.castSucc → m (α i.succ)) (x) : dfoldlM (n+1) α f x = f 0 x >>= (dfoldlM n (α ∘ succ) (f ·.succ ·) .) := dfoldlM_loop .. theorem dfoldlM_eq_foldlM [Monad m] (f : (i : Fin n) → α → m α) (x : α) : dfoldlM n (fun _ => α) f x = foldlM n (fun x i => f i x) x := by induction n generalizing x with | zero => simp only [dfoldlM_zero, foldlM_zero] | succ n ih => simp only [dfoldlM_succ, foldlM_succ, Function.comp_apply, Function.comp_def] congr; ext; simp only [ih] /-! ### dfoldl -/ @[simp] theorem dfoldl_zero (f : (i : Fin 0) → α i.castSucc → α i.succ) (x) : dfoldl 0 α f x = x := by simp [dfoldl, pure] theorem dfoldl_succ (f : (i : Fin (n+1)) → α i.castSucc → α i.succ) (x) : dfoldl (n+1) α f x = dfoldl n (α ∘ succ) (f ·.succ ·) (f 0 x) := dfoldlM_succ .. theorem dfoldl_succ_last (f : (i : Fin (n+1)) → α i.castSucc → α i.succ) (x) : dfoldl (n+1) α f x = f (last n) (dfoldl n (α ∘ castSucc) (f ·.castSucc ·) x) := by rw [dfoldl_succ] induction n with | zero => simp [last] | succ n ih => rw [dfoldl_succ, @ih (α ∘ succ) (f ·.succ ·), dfoldl_succ]; congr theorem dfoldl_eq_dfoldlM (f : (i : Fin n) → α i.castSucc → α i.succ) (x) : dfoldl n α f x = dfoldlM (m := Id) n α f x := rfl theorem dfoldl_eq_foldl (f : Fin n → α → α) (x : α) : dfoldl n (fun _ => α) f x = foldl n (fun x i => f i x) x := by induction n generalizing x with | zero => simp only [dfoldl_zero, foldl_zero] | succ n ih => simp only [dfoldl_succ, foldl_succ, Function.comp_apply, Function.comp_def] congr; simp only [ih] /-! ### `Fin.fold{l/r}{M}` equals `List.fold{l/r}{M}` -/ theorem foldl_eq_foldl_finRange (f : α → Fin n → α) (x) : foldl n f x = (List.finRange n).foldl f x := by induction n generalizing x with | zero => rw [foldl_zero, List.finRange_zero, List.foldl_nil] | succ n ih => rw [foldl_succ, ih, List.finRange_succ, List.foldl_cons, List.foldl_map] theorem foldr_eq_foldr_finRange (f : Fin n → α → α) (x) : foldr n f x = (List.finRange n).foldr f x := by induction n with | zero => rw [foldr_zero, List.finRange_zero, List.foldr_nil] | succ n ih => rw [foldr_succ, ih, List.finRange_succ, List.foldr_cons, List.foldr_map] ================================================ FILE: Batteries/Data/Fin/Lemmas.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.Fin.Basic public import Batteries.Data.Nat.Lemmas public import Batteries.Data.List.Basic public import Batteries.Util.ProofWanted public import Batteries.Tactic.Alias @[expose] public section namespace Fin attribute [norm_cast] val_last /-! ### rev -/ -- Forward port of lean4#11065 attribute [grind =] rev_lt_rev rev_le_rev rev_rev /-! ### foldl/foldr -/ theorem foldl_assoc {op : α → α → α} [ha : Std.Associative op] {f : Fin n → α} {a₁ a₂} : foldl n (fun x i => op x (f i)) (op a₁ a₂) = op a₁ (foldl n (fun x i => op x (f i)) a₂) := by induction n generalizing a₂ with | zero => simp | succ n ih => simp only [foldl_succ, ha.assoc, ih] theorem foldr_assoc {op : α → α → α} [ha : Std.Associative op] {f : Fin n → α} {a₁ a₂} : foldr n (fun i x => op (f i) x) (op a₁ a₂) = op (foldr n (fun i x => op (f i) x) a₁) a₂ := by simp only [← Fin.foldl_rev] haveI : Std.Associative (flip op) := ⟨fun a b c => (ha.assoc c b a).symm⟩ exact foldl_assoc (op := flip op) /-! ### clamp -/ @[simp] theorem coe_clamp (n m : Nat) : (clamp n m : Nat) = min n m := rfl /-! ### sum -/ @[simp, grind =] theorem sum_zero [Zero α] [Add α] (x : Fin 0 → α) : Fin.sum x = 0 := by simp [Fin.sum] theorem sum_succ [Zero α] [Add α] (x : Fin (n + 1) → α) : Fin.sum x = x 0 + Fin.sum (x ·.succ) := by simp [Fin.sum, foldr_succ] @[simp, grind =] theorem sum_eq_sum_map_finRange [Zero α] [Add α] (x : Fin n → α) : Fin.sum x = (List.finRange n |>.map x).sum := by simp only [Fin.sum, foldr_eq_finRange_foldr, List.sum, List.foldr_map] /-! ### prod -/ @[simp, grind =] theorem prod_zero [One α] [Mul α] (x : Fin 0 → α) : Fin.prod x = 1 := by simp [Fin.prod] theorem prod_succ [One α] [Mul α] (x : Fin (n + 1) → α) : Fin.prod x = x 0 * Fin.prod (x ·.succ) := by simp [Fin.prod, foldr_succ] @[simp, grind =] theorem prod_eq_prod_map_finRange [One α] [Mul α] (x : Fin n → α) : Fin.prod x = (List.finRange n |>.map x).prod := by simp only [Fin.prod, foldr_eq_finRange_foldr, List.prod, List.foldr_map] /-! ### countP -/ @[simp, grind =] theorem countP_zero (p : Fin 0 → Bool) : Fin.countP p = 0 := by simp [Fin.countP] @[simp, grind =] theorem countP_one (p : Fin 1 → Bool) : Fin.countP p = (p 0).toNat := by simp [Fin.countP, List.finRange_succ] theorem countP_succ (p : Fin (n + 1) → Bool) : Fin.countP p = (p 0).toNat + Fin.countP (p ·.succ) := by simp [Fin.countP, List.finRange_succ]; rfl @[simp, grind =] theorem countP_eq_countP_map_finRange (x : Fin n → Bool) : Fin.countP x = (List.finRange n).countP x := by induction n with | zero => rfl | succ n ih => simp +arith [countP_succ, List.finRange_succ, List.countP_cons, List.countP_map, Bool.cond_eq_ite, Bool.toNat, ih]; rfl @[grind .] theorem countP_le (p : Fin n → Bool) : Fin.countP p ≤ n := by induction n with simp only [countP_zero, countP_succ, Nat.le_refl] | succ _ ih => rw [Nat.add_comm] apply Nat.add_le_add · exact ih .. · exact Bool.toNat_le .. /-! ### findSome? -/ @[simp] theorem findSome?_zero {f : Fin 0 → Option α} : findSome? f = none := by simp [findSome?] @[simp] theorem findSome?_one {f : Fin 1 → Option α} : findSome? f = f 0 := by simp [findSome?, foldl_succ] theorem findSome?_succ {f : Fin (n+1) → Option α} : findSome? f = (f 0).or (findSome? (f ·.succ)) := by simp only [findSome?, foldl_succ, Option.orElse_eq_orElse, Option.orElse_eq_or] exact Eq.trans (by cases (f 0) <;> rfl) foldl_assoc theorem findSome?_succ_of_some {f : Fin (n+1) → Option α} (h : f 0 = some x) : findSome? f = some x := findSome?_succ.trans (h ▸ Option.some_or) theorem findSome?_succ_of_isSome {f : Fin (n+1) → Option α} (h : (f 0).isSome) : findSome? f = f 0 := findSome?_succ.trans (Option.or_of_isSome h) theorem findSome?_succ_of_none {f : Fin (n+1) → Option α} (h : f 0 = none) : findSome? f = findSome? (f ·.succ) := findSome?_succ.trans (Option.or_eq_right_of_none h) theorem findSome?_succ_of_isNone {f : Fin (n+1) → Option α} (h : (f 0).isNone) : findSome? f = findSome? (f ·.succ) := findSome?_succ.trans (Option.or_of_isNone h) @[simp, grind =] theorem findSome?_eq_some_iff {f : Fin n → Option α} : findSome? f = some a ↔ ∃ i, f i = some a ∧ ∀ j < i, f j = none := by induction n with | zero => simp only [findSome?_zero, reduceCtorEq, forall_fin_zero, and_true, exists_fin_zero] | succ n ih => simp only [findSome?_succ, Option.or_eq_some_iff, exists_fin_succ, forall_fin_succ, succ_lt_succ_iff, succ_pos, not_lt_zero, ih] grind @[simp, grind =] theorem findSome?_eq_none_iff {f : Fin n → Option α} : findSome? f = none ↔ ∀ i, f i = none := by induction n with | zero => simp only [findSome?_zero, forall_fin_zero] | succ n ih => simp only [findSome?_succ, Option.or_eq_none_iff, ih, forall_fin_succ] theorem isNone_findSome?_iff {f : Fin n → Option α} : (findSome? f).isNone ↔ ∀ i, (f i).isNone := by simp @[deprecated (since := "2025-09-28")] alias findSome?_isNone_iff := isNone_findSome?_iff @[simp] theorem isSome_findSome?_iff {f : Fin n → Option α} : (findSome? f).isSome ↔ ∃ i, (f i).isSome := by cases h : findSome? f <;> grind @[deprecated (since := "2025-09-28")] alias findSome?_isSome_iff := isSome_findSome?_iff theorem exists_minimal_of_findSome?_eq_some {f : Fin n → Option α} (h : findSome? f = some x) : ∃ i, f i = some x ∧ ∀ j < i, f j = none := findSome?_eq_some_iff.1 h theorem exists_eq_some_of_findSome?_eq_some {f : Fin n → Option α} (h : findSome? f = some x) : ∃ i, f i = some x := by grind @[deprecated (since := "2025-09-28")] alias exists_of_findSome?_eq_some := exists_eq_some_of_findSome?_eq_some theorem eq_none_of_findSome?_eq_none {f : Fin n → Option α} (h : findSome? f = none) (i) : f i = none := findSome?_eq_none_iff.1 h i theorem exists_isSome_of_isSome_findSome? {f : Fin n → Option α} (h : (findSome? f).isSome) : ∃ i, (f i).isSome := isSome_findSome?_iff.1 h theorem isNone_of_isNone_findSome? {f : Fin n → Option α} (h : (findSome? f).isNone) : (f i).isNone := isNone_findSome?_iff.1 h i theorem isSome_findSome?_of_isSome {f : Fin n → Option α} (h : (f i).isSome) : (findSome? f).isSome := isSome_findSome?_iff.2 ⟨_, h⟩ theorem map_findSome? (f : Fin n → Option α) (g : α → β) : (findSome? f).map g = findSome? (Option.map g <| f ·) := by induction n with | zero => simp | succ n ih => simp [findSome?_succ, Option.map_or, ih] theorem findSome?_guard {p : Fin n → Bool} : findSome? (Option.guard p) = find? p := rfl theorem bind_findSome?_guard_isSome {f : Fin n → Option α} : (findSome? (Option.guard fun i => (f i).isSome)).bind f = findSome? f := by cases hf : findSome? f with | none => grind | some x => simp only [Option.bind_eq_some_iff, findSome?_eq_some_iff, Option.guard_eq_some_iff] grind theorem findSome?_eq_findSome?_finRange (f : Fin n → Option α) : findSome? f = (List.finRange n).findSome? f := by induction n with | zero => simp | succ n ih => rw [findSome?_succ, List.finRange_succ, List.findSome?_cons] cases f 0 <;> simp [ih, List.findSome?_map, Function.comp_def] /-! ### findSomeRev? -/ @[simp] theorem findSome?_rev {f : Fin n → Option α} : findSome? (f ·.rev) = findSomeRev? f := rfl @[simp] theorem findSomeRev?_rev {f : Fin n → Option α} : findSomeRev? (f ·.rev) = findSome? f := by simp only [findSomeRev?, rev_rev] @[simp] theorem findSomeRev?_zero {f : Fin 0 → Option α} : findSomeRev? f = none := by simp [findSomeRev?] @[simp] theorem findSomeRev?_one {f : Fin 1 → Option α} : findSomeRev? f = f 0 := by simp [findSomeRev?] theorem findSomeRev?_succ {f : Fin (n+1) → Option α} : findSomeRev? f = (f (last n)).or (findSomeRev? fun i => f i.castSucc) := by unfold findSomeRev? simp only [findSome?_succ, rev_succ, rev_zero] @[simp, grind =] theorem findSomeRev?_eq_some_iff {f : Fin n → Option α} : findSomeRev? f = some a ↔ ∃ i, f i = some a ∧ ∀ j, i < j → f j = none := findSome?_eq_some_iff.trans <| ⟨fun ⟨i, h⟩ => ⟨i.rev, by grind, fun j hj => have := h.2 j.rev; by grind⟩, fun ⟨i, _⟩ => ⟨i.rev, by grind⟩⟩ @[simp, grind =] theorem findSomeRev?_eq_none_iff {f : Fin n → Option α} : findSomeRev? f = none ↔ ∀ i, f i = none := findSome?_eq_none_iff.trans <| ⟨fun h i => have := h i.rev; by grind, by grind⟩ theorem isNone_findSomeRev?_iff {f : Fin n → Option α} : (findSomeRev? f).isNone ↔ ∀ i, (f i).isNone := by simp @[simp] theorem isSome_findSomeRev?_iff {f : Fin n → Option α} : (findSomeRev? f).isSome ↔ ∃ i, (f i).isSome := by cases h : findSomeRev? f <;> grind theorem exists_minimal_of_findSomeRev?_eq_some {f : Fin n → Option α} (h : findSomeRev? f = some x) : ∃ i, f i = some x ∧ ∀ j, i < j → f j = none := findSomeRev?_eq_some_iff.1 h theorem exists_eq_some_of_findSomeRev?_eq_some {f : Fin n → Option α} (h : findSomeRev? f = some x) : ∃ i, f i = some x := by grind theorem eq_none_of_findSomeRev?_eq_none {f : Fin n → Option α} (h : findSomeRev? f = none) (i) : f i = none := findSomeRev?_eq_none_iff.1 h i theorem exists_isSome_of_isSome_findSomeRev? {f : Fin n → Option α} (h : (findSomeRev? f).isSome) : ∃ i, (f i).isSome := isSome_findSomeRev?_iff.1 h theorem isNone_of_isNone_findSomeRev? {f : Fin n → Option α} (h : (findSomeRev? f).isNone) : (f i).isNone := isNone_findSomeRev?_iff.1 h i theorem isSome_findSomeRev?_of_isSome {f : Fin n → Option α} (h : (f i).isSome) : (findSomeRev? f).isSome := isSome_findSomeRev?_iff.2 ⟨_, h⟩ theorem map_findSomeRev? (f : Fin n → Option α) (g : α → β) : (findSomeRev? f).map g = findSomeRev? (Option.map g <| f ·) := by induction n with | zero => grind [findSomeRev?_zero] | succ n ih => grind [findSomeRev?_succ] @[grind =_] theorem findSomeRev?_guard {p : Fin n → Bool} : findSomeRev? (Option.guard p) = findRev? p := rfl theorem bind_findSomeRev?_guard_isSome {f : Fin n → Option α} : (findSomeRev? (Option.guard fun i => (f i).isSome)).bind f = findSomeRev? f := by cases hf : findSomeRev? f with | none => grind | some x => simp only [Option.bind_eq_some_iff, findSomeRev?_eq_some_iff, Option.guard_eq_some_iff] grind /-! ### find? -/ theorem find?_zero {p : Fin 0 → Bool} : find? p = none := by simp theorem find?_one {p : Fin 1 → Bool} : find? p = if p 0 then some 0 else none := by simp [Option.guard] theorem find?_succ {p : Fin (n+1) → Bool} : find? p = if p 0 then some 0 else (find? (p ·.succ)).map Fin.succ := by simp only [findSome?_succ, Option.guard, fun a => apply_ite (Option.or · a), Option.some_or, Option.none_or, map_findSome?, Option.map_if] @[grind =] theorem find?_eq_some_iff {p : Fin n → Bool} : find? p = some i ↔ p i ∧ ∀ j, j < i → p j = false := by simp [and_assoc] theorem isSome_find?_iff {p : Fin n → Bool} : (find? p).isSome ↔ ∃ i, p i := by simp @[deprecated (since := "2025-09-28")] alias find?_isSome_iff := isSome_find?_iff @[grind =] theorem find?_eq_none_iff {p : Fin n → Bool} : find? p = none ↔ ∀ i, p i = false := by simp theorem isNone_find?_iff {p : Fin n → Bool} : (find? p).isNone ↔ ∀ i, p i = false := by simp @[deprecated (since := "2025-09-28")] alias find?_isNone_iff := isNone_find?_iff theorem eq_true_of_find?_eq_some {p : Fin n → Bool} (h : find? p = some i) : p i := (find?_eq_some_iff.mp h).1 theorem eq_false_of_find?_eq_some_of_lt {p : Fin n → Bool} (h : find? p = some i) : ∀ j < i, p j = false := (find?_eq_some_iff.mp h).2 theorem eq_false_of_find?_eq_none {p : Fin n → Bool} (h : find? p = none) (i) : p i = false := find?_eq_none_iff.1 h i theorem exists_eq_true_of_isSome_find? {p : Fin n → Bool} (h : (find? p).isSome) : ∃ i, p i := isSome_find?_iff.1 h theorem eq_false_of_isNone_find? {p : Fin n → Bool} (h : (find? p).isNone) : p i = false := isNone_find?_iff.1 h i theorem isSome_find?_of_eq_true {p : Fin n → Bool} (h : p i) : (find? p).isSome := isSome_find?_iff.2 ⟨_, h⟩ theorem get_find?_eq_true {p : Fin n → Bool} (h : (find? p).isSome) : p ((find? p).get h) := eq_true_of_find?_eq_some (Option.some_get _).symm theorem get_find?_minimal {p : Fin n → Bool} (h : (find? p).isSome) : ∀ j, j < (find? p).get h → p j = false := eq_false_of_find?_eq_some_of_lt (Option.some_get _).symm theorem bind_find?_isSome {f : Fin n → Option α} : (find? (fun i => (f i).isSome)).bind f = findSome? f := bind_findSome?_guard_isSome theorem find?_eq_find?_finRange {p : Fin n → Bool} : find? p = (List.finRange n).find? p := (findSome?_eq_findSome?_finRange _).trans (List.findSome?_guard) theorem exists_eq_true_iff_exists_minimal_eq_true (p : Fin n → Bool): (∃ i, p i) ↔ ∃ i, p i ∧ ∀ j < i, p j = false := by cases h : find? p <;> grind theorem exists_iff_exists_minimal (p : Fin n → Prop) [DecidablePred p] : (∃ i, p i) ↔ ∃ i, p i ∧ ∀ j < i, ¬ p j := by cases h : find? (p ·) <;> grind theorem find?_rev {p : Fin n → Bool} : find? (p ·.rev) = (findRev? p).map rev := by simp [← findSomeRev?_rev, map_findSomeRev?, Option.guard_eq_ite] theorem map_rev_findRev? {p : Fin n → Bool} : (findRev? (p ·.rev)).map rev = find? p := by simp only [← find?_rev, rev_rev] /-! ### findRev? -/ theorem findRev?_zero {p : Fin 0 → Bool} : findRev? p = none := by grind theorem findRev?_succ {p : Fin (n+1) → Bool} : findRev? p = if p (last n) then some (last n) else (findRev? fun i => p i.castSucc).map Fin.castSucc := by simp only [findSomeRev?_succ, Option.guard, fun a => apply_ite (Option.or · a), Option.some_or, Option.none_or, map_findSomeRev?, Option.map_if] theorem findRev?_one {p : Fin 1 → Bool} : findRev? p = if p 0 then some 0 else none := by grind [findRev?_succ] @[grind =] theorem findRev?_eq_some_iff {p : Fin n → Bool} : findRev? p = some i ↔ p i ∧ ∀ j, i < j → p j = false := by simp [and_assoc] @[grind =] theorem findRev?_eq_none_iff {p : Fin n → Bool} : findRev? p = none ↔ ∀ i, p i = false := by simp theorem isSome_findRev?_iff {p : Fin n → Bool} : (findRev? p).isSome ↔ ∃ i, p i := by simp theorem isNone_findRev?_iff {p : Fin n → Bool} : (findRev? p).isNone ↔ ∀ i, p i = false := by simp theorem eq_true_of_findRev?_eq_some {p : Fin n → Bool} (h : findRev? p = some i) : p i := (findRev?_eq_some_iff.mp h).1 theorem eq_false_of_findRev?_eq_some_of_lt {p : Fin n → Bool} (h : findRev? p = some i) : ∀ j, i < j → p j = false := (findRev?_eq_some_iff.mp h).2 theorem eq_false_of_findRev?_eq_none {p : Fin n → Bool} (h : findRev? p = none) (i) : p i = false := findRev?_eq_none_iff.1 h i theorem exists_eq_true_of_isSome_findRev? {p : Fin n → Bool} (h : (findRev? p).isSome) : ∃ i, p i := isSome_findRev?_iff.1 h theorem eq_false_of_isNone_findRev? {p : Fin n → Bool} (h : (findRev? p).isNone) : p i = false := isNone_findRev?_iff.1 h i theorem isSome_findRev?_of_eq_true {p : Fin n → Bool} (h : p i) : (findRev? p).isSome := isSome_findRev?_iff.2 ⟨_, h⟩ theorem get_findRev?_eq_true {p : Fin n → Bool} (h : (findRev? p).isSome) : p ((findRev? p).get h) := eq_true_of_findRev?_eq_some (Option.some_get _).symm theorem get_findRev?_maximal {p : Fin n → Bool} (h : (findRev? p).isSome) : ∀ j, (findRev? p).get h < j → p j = false := eq_false_of_findRev?_eq_some_of_lt (Option.some_get _).symm theorem exists_eq_true_iff_exists_maximal_eq_true (p : Fin n → Bool): (∃ i, p i) ↔ ∃ i, p i ∧ ∀ j , i < j → p j = false := by cases h : findRev? p <;> grind theorem exists_iff_exists_maximal (p : Fin n → Prop) [DecidablePred p] : (∃ i, p i) ↔ ∃ i, p i ∧ ∀ j, i < j → ¬ p j := by cases h : findRev? (p ·) <;> grind theorem bind_findRev?_isSome {f : Fin n → Option α} : (findRev? (fun i => (f i).isSome)).bind f = findSomeRev? f := bind_findSomeRev?_guard_isSome theorem findRev?_rev {p : Fin n → Bool} : findRev? (p ·.rev) = (find? p).map rev := by simp [← findSome?_rev, map_findSome?, Option.guard_eq_ite] theorem map_rev_find? {p : Fin n → Bool} : (find? (p ·.rev)).map rev = findRev? p := by simp only [← findRev?_rev, rev_rev] theorem find?_le_findRev? {p : Fin n → Bool} : find? p ≤ findRev? p := by cases hl : find? p <;> cases hu : findRev? p <;> grind theorem find?_eq_findRev?_iff {p : Fin n → Bool} : find? p = findRev? p ↔ ∀ i j, p i = true → p j = true → i = j := by cases h : findRev? p <;> grind /-! ### divNat / modNat / mkDivMod -/ @[simp] theorem coe_divNat (i : Fin (m * n)) : (i.divNat : Nat) = i / n := rfl @[simp] theorem coe_modNat (i : Fin (m * n)) : (i.modNat : Nat) = i % n := rfl @[simp] theorem coe_mkDivMod (i : Fin m) (j : Fin n) : (mkDivMod i j : Nat) = n * i + j := rfl @[simp] theorem divNat_mkDivMod (i : Fin m) (j : Fin n) : (mkDivMod i j).divNat = i := by ext; simp [Nat.mul_add_div (Nat.zero_lt_of_lt j.is_lt)] @[simp] theorem modNat_mkDivMod (i : Fin m) (j : Fin n) : (mkDivMod i j).modNat = j := by ext; simp [Nat.mod_eq_of_lt] @[simp] theorem divNat_mkDivMod_modNat (k : Fin (m * n)) : mkDivMod k.divNat k.modNat = k := by ext; simp [Nat.div_add_mod] ================================================ FILE: Batteries/Data/Fin/OfBits.lean ================================================ /- Copyright (c) 2025 François G. Dorais. All rights reserved. Released under Apache 2. license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Data.Nat.Lemmas @[expose] public section namespace Fin /-- Construct an element of `Fin (2 ^ n)` from a sequence of bits (little endian). -/ abbrev ofBits (f : Fin n → Bool) : Fin (2 ^ n) := ⟨Nat.ofBits f, Nat.ofBits_lt_two_pow f⟩ @[simp] theorem val_ofBits (f : Fin n → Bool) : (ofBits f).val = Nat.ofBits f := rfl ================================================ FILE: Batteries/Data/Fin.lean ================================================ module public import Batteries.Data.Fin.Basic public import Batteries.Data.Fin.Fold public import Batteries.Data.Fin.Lemmas public import Batteries.Data.Fin.OfBits ================================================ FILE: Batteries/Data/FloatArray.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2. license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section namespace FloatArray attribute [ext] FloatArray /-- Unsafe optimized implementation of `mapM`. This function is unsafe because it relies on the implementation limit that the size of an array is always less than `USize.size`. -/ @[inline] unsafe def mapMUnsafe [Monad m] (a : FloatArray) (f : Float → m Float) : m FloatArray := loop a 0 a.usize where /-- Inner loop for `mapMUnsafe`. -/ @[specialize] loop (a : FloatArray) (k s : USize) := do if k < s then let x := a.uget k lcProof let y ← f x let a := a.uset k y lcProof loop a (k+1) s else pure a /-- `mapM f a` applies the monadic function `f` to each element of the array. -/ @[implemented_by mapMUnsafe] def mapM [Monad m] (a : FloatArray) (f : Float → m Float) : m FloatArray := do let mut r := a for i in [0:r.size] do r := r.set! i (← f r[i]!) return r /-- `map f a` applies the function `f` to each element of the array. -/ @[inline] def map (a : FloatArray) (f : Float → Float) : FloatArray := mapM (m:=Id) a f ================================================ FILE: Batteries/Data/HashMap/Basic.lean ================================================ /- Copyright (c) 2018 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Mario Carneiro -/ module public import Batteries.Lean.HashMap public import Batteries.Tactic.Alias @[expose] public section namespace Std.HashMap variable [BEq α] [Hashable α] /-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. Note that the returned key may not be identical to the input, if `==` ignores some part of the value. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.findEntry? "one" = some ("one", 1) hashMap.findEntry? "three" = none ``` -/ -- This could be given a more efficient low level implementation. @[inline] def findEntry? [BEq α] [Hashable α] (m : Std.HashMap α β) (k : α) : Option (α × β) := if h : k ∈ m then some (m.getKey k h, m.get k h) else none /-- Variant of `ofList` which accepts a function that combines values of duplicated keys. ``` ofListWith [("one", 1), ("one", 2)] (fun v₁ v₂ => v₁ + v₂) = {"one" => 3} ``` -/ def ofListWith [BEq α] [Hashable α] (l : List (α × β)) (f : β → β → β) : HashMap α β := l.foldl (init := ∅) fun m p => match m[p.1]? with | none => m.insert p.1 p.2 | some v => m.insert p.1 <| f v p.2 end Std.HashMap namespace Batteries.HashMap @[reducible, deprecated (since := "2025-05-31")] alias LawfulHashable := LawfulHashable /-- `HashMap α β` is a key-value map which stores elements in an array using a hash function to find the values. This allows it to have very good performance for lookups (average `O(1)` for a perfectly random hash function), but it is not a persistent data structure, meaning that one should take care to use the map linearly when performing updates. Copies are `O(n)`. -/ @[deprecated Std.HashMap (since := "2025-04-09")] structure _root_.Batteries.HashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] where /-- The inner `Std.HashMap` powering the `Batteries.HashMap`. -/ inner : Std.HashMap α β set_option linter.deprecated false /-- Make a new hash map with the specified capacity. -/ @[inline] def _root_.Batteries.mkHashMap [BEq α] [Hashable α] (capacity := 0) : HashMap α β := ⟨.emptyWithCapacity capacity, .emptyWithCapacity⟩ instance [BEq α] [Hashable α] : Inhabited (HashMap α β) where default := mkHashMap instance [BEq α] [Hashable α] : EmptyCollection (HashMap α β) := ⟨mkHashMap⟩ /-- Make a new empty hash map. ``` (empty : Batteries.HashMap Int Int).toList = [] ``` -/ @[inline] def empty [BEq α] [Hashable α] : HashMap α β := mkHashMap variable {_ : BEq α} {_ : Hashable α} /-- The number of elements in the hash map. ``` (ofList [("one", 1), ("two", 2)]).size = 2 ``` -/ @[inline] def size (self : HashMap α β) : Nat := self.inner.size /-- Is the map empty? ``` (empty : Batteries.HashMap Int Int).isEmpty = true (ofList [("one", 1), ("two", 2)]).isEmpty = false ``` -/ @[inline] def isEmpty (self : HashMap α β) : Bool := self.inner.isEmpty /-- Inserts key-value pair `a, b` into the map. If an element equal to `a` is already in the map, it is replaced by `b`. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.insert "three" 3 = {"one" => 1, "two" => 2, "three" => 3} hashMap.insert "two" 0 = {"one" => 1, "two" => 0} ``` -/ @[inline] def insert (self : HashMap α β) (a : α) (b : β) : HashMap α β := ⟨Std.HashMap.insert self.inner a b⟩ /-- Similar to `insert`, but also returns a boolean flag indicating whether an existing entry has been replaced with `a => b`. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.insert' "three" 3 = ({"one" => 1, "two" => 2, "three" => 3}, false) hashMap.insert' "two" 0 = ({"one" => 1, "two" => 0}, true) ``` -/ @[inline] def insert' (m : HashMap α β) (a : α) (b : β) : HashMap α β × Bool := let ⟨contains, insert⟩ := m.inner.containsThenInsert a b ⟨⟨insert⟩, contains⟩ /-- Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.erase "one" = {"two" => 2} hashMap.erase "three" = {"one" => 1, "two" => 2} ``` -/ @[inline] def erase (self : HashMap α β) (a : α) : HashMap α β := ⟨self.inner.erase a⟩ /-- Performs an in-place edit of the value, ensuring that the value is used linearly. The function `f` is passed the original key of the entry, along with the value in the map. ``` (ofList [("one", 1), ("two", 2)]).modify "one" (fun _ v => v + 1) = {"one" => 2, "two" => 2} (ofList [("one", 1), ("two", 2)]).modify "three" (fun _ v => v + 1) = {"one" => 1, "two" => 2} ``` -/ @[inline] def modify (self : HashMap α β) (a : α) (f : α → β → β) : HashMap α β := ⟨self.inner.modify a (f a)⟩ /-- Looks up an element in the map with key `a`. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.find? "one" = some 1 hashMap.find? "three" = none ``` -/ @[inline] def find? (self : HashMap α β) (a : α) : Option β := self.inner[a]? /-- Looks up an element in the map with key `a`. Returns `b₀` if the element is not found. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.findD "one" 0 = 1 hashMap.findD "three" 0 = 0 ``` -/ @[inline] def findD (self : HashMap α β) (a : α) (b₀ : β) : β := self.inner.getD a b₀ /-- Looks up an element in the map with key `a`. Panics if the element is not found. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.find! "one" = 1 hashMap.find! "three" => panic! ``` -/ @[inline] def find! [Inhabited β] (self : HashMap α β) (a : α) : β := self.inner.getD a (panic! "key is not in the map") instance : GetElem (HashMap α β) α (Option β) fun _ _ => True where getElem m k _ := m.inner[k]? /-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. Note that the returned key may not be identical to the input, if `==` ignores some part of the value. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.findEntry? "one" = some ("one", 1) hashMap.findEntry? "three" = none ``` -/ -- This could be given a more efficient low level implementation. @[inline] def findEntry? [BEq α] [Hashable α] (m : HashMap α β) (k : α) : Option (α × β) := m.inner.findEntry? k /-- Returns true if the element `a` is in the map. ``` def hashMap := ofList [("one", 1), ("two", 2)] hashMap.contains "one" = true hashMap.contains "three" = false ``` -/ @[inline] def contains (self : HashMap α β) (a : α) : Bool := self.inner.contains a /-- Folds a monadic function over the elements in the map (in arbitrary order). ``` def sumEven (sum: Nat) (k : String) (v : Nat) : Except String Nat := if v % 2 == 0 then pure (sum + v) else throw s!"value {v} at key {k} is not even" foldM sumEven 0 (ofList [("one", 1), ("three", 3)]) = Except.error "value 3 at key three is not even" foldM sumEven 0 (ofList [("two", 2), ("four", 4)]) = Except.ok 6 ``` -/ @[inline] def foldM [Monad m] (f : δ → α → β → m δ) (init : δ) (self : HashMap α β) : m δ := Std.HashMap.foldM f init self.inner /-- Folds a function over the elements in the map (in arbitrary order). ``` fold (fun sum _ v => sum + v) 0 (ofList [("one", 1), ("two", 2)]) = 3 ``` -/ @[inline] def fold (f : δ → α → β → δ) (init : δ) (self : HashMap α β) : δ := Std.HashMap.fold f init self.inner /-- Combines two hashmaps using a monadic function `f` to combine two values at a key. ``` def map1 := ofList [("one", 1), ("two", 2)] def map2 := ofList [("two", 2), ("three", 3)] def map3 := ofList [("two", 3), ("three", 3)] def mergeIfNoConflict? (_ : String) (v₁ v₂ : Nat) : Option Nat := if v₁ != v₂ then none else some v₁ mergeWithM mergeIfNoConflict? map1 map2 = some {"one" => 1, "two" => 2, "three" => 3} mergeWithM mergeIfNoConflict? map1 map3 = none ``` -/ @[specialize] def mergeWithM [Monad m] (f : α → β → β → m β) (self other : HashMap α β) : m (HashMap α β) := HashMap.mk <$> self.inner.mergeWithM f other.inner /-- Combines two hashmaps using function `f` to combine two values at a key. ``` mergeWith (fun _ v₁ v₂ => v₁ + v₂ ) (ofList [("one", 1), ("two", 2)]) (ofList [("two", 2), ("three", 3)]) = {"one" => 1, "two" => 4, "three" => 3} ``` -/ @[inline] def mergeWith (f : α → β → β → β) (self other : HashMap α β) : HashMap α β := ⟨self.inner.mergeWith f other.inner⟩ /-- Runs a monadic function over the elements in the map (in arbitrary order). ``` def checkEven (k : String) (v : Nat) : Except String Unit := if v % 2 == 0 then pure () else throw s!"value {v} at key {k} is not even" forM checkEven (ofList [("one", 1), ("three", 3)]) = Except.error "value 3 at key three is not even" forM checkEven (ofList [("two", 2), ("four", 4)]) = Except.ok () ``` -/ @[inline] def forM [Monad m] (f : α → β → m PUnit) (self : HashMap α β) : m PUnit := Std.HashMap.forM f self.inner /-- Converts the map into a list of key-value pairs. ``` open List (ofList [("one", 1), ("two", 2)]).toList ~ [("one", 1), ("two", 2)] ``` -/ def toList (self : HashMap α β) : List (α × β) := self.inner.toList /-- Converts the map into an array of key-value pairs. ``` open List (ofList [("one", 1), ("two", 2)]).toArray.data ~ #[("one", 1), ("two", 2)].data ``` -/ def toArray (self : HashMap α β) : Array (α × β) := self.inner.toArray /-- The number of buckets in the hash map. -/ def numBuckets (self : HashMap α β) : Nat := Std.HashMap.Internal.numBuckets self.inner /-- Builds a `HashMap` from a list of key-value pairs. Values of duplicated keys are replaced by their respective last occurrences. ``` ofList [("one", 1), ("one", 2)] = {"one" => 2} ``` -/ def ofList [BEq α] [Hashable α] (l : List (α × β)) : HashMap α β := ⟨Std.HashMap.ofList l⟩ /-- Variant of `ofList` which accepts a function that combines values of duplicated keys. ``` ofListWith [("one", 1), ("one", 2)] (fun v₁ v₂ => v₁ + v₂) = {"one" => 3} ``` -/ def ofListWith [BEq α] [Hashable α] (l : List (α × β)) (f : β → β → β) : HashMap α β := ⟨Std.HashMap.ofListWith l f⟩ ================================================ FILE: Batteries/Data/HashMap.lean ================================================ module public import Batteries.Data.HashMap.Basic ================================================ FILE: Batteries/Data/Int.lean ================================================ /- Copyright (c) 2025 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Data.Nat.Lemmas @[expose] public section namespace Int /-- `testBit m n` returns whether the `(n+1)` least significant bit is `1` or `0`, using the two's complement convention for negative `m`. -/ def testBit : Int → Nat → Bool | ofNat m, n => Nat.testBit m n | negSucc m, n => !(Nat.testBit m n) /-- Construct an integer from a sequence of bits using little endian convention. The sign is determined using the two's complement convention: the result is negative if and only if `n > 0` and `f (n-1) = true`. -/ def ofBits (f : Fin n → Bool) := if 2 * Nat.ofBits f < 2 ^ n then ofNat (Nat.ofBits f) else subNatNat (Nat.ofBits f) (2 ^ n) @[simp] theorem ofBits_zero (f : Fin 0 → Bool) : ofBits f = 0 := by simp [ofBits] @[simp] theorem testBit_ofBits_lt {f : Fin n → Bool} (h : i < n) : (ofBits f).testBit i = f ⟨i, h⟩ := by simp only [ofBits] split · simp only [testBit, Nat.testBit_ofBits_lt, h] · have hlt := Nat.ofBits_lt_two_pow f simp [subNatNat_of_lt hlt, testBit, Nat.sub_sub, Nat.testBit_two_pow_sub_succ hlt, h] @[simp] theorem testBit_ofBits_ge {f : Fin n → Bool} (h : i ≥ n) : (ofBits f).testBit i = decide (ofBits f < 0) := by simp only [ofBits] split · have hge : ¬ ofNat (Nat.ofBits f) < 0 := by rw [Int.not_lt]; exact natCast_nonneg .. simp only [testBit, Nat.testBit_ofBits_ge _ _ h, hge, decide_false] · have hlt := Nat.ofBits_lt_two_pow f have h : 2 ^ n - Nat.ofBits f - 1 < 2 ^ i := Nat.lt_of_lt_of_le (by omega) (Nat.pow_le_pow_right Nat.zero_lt_two h) simp [testBit, subNatNat_of_lt hlt, Nat.testBit_lt_two_pow h, negSucc_lt_zero] theorem testBit_ofBits (f : Fin n → Bool) : (ofBits f).testBit i = if h : i < n then f ⟨i, h⟩ else decide (ofBits f < 0) := by split <;> simp_all ================================================ FILE: Batteries/Data/List/ArrayMap.lean ================================================ /- Copyright (c) 2024 Michael Rothgang. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Michael Rothgang -/ module @[expose] public section universe u v w variable {α : Type u} {β : Type v} namespace List /-- This function is provided as a more efficient runtime alternative to `(l.map f).toArray`. (It avoids the intermediate memory allocation of creating an intermediate list first.) For verification purposes, we immediately simplify it to that form. -/ def toArrayMap (l : List α) (f : α → β) : Array β := l.foldl (init := #[]) fun acc x => acc.push (f x) -- Future: a toArrayMapM version could be useful (e.g. in mathlib's DeriveToExpr) -- def toArrayMapM {m : Type v → Type w} [Monad m] (l : List α) (f : α → m β) : m (Array β) := -- l.foldlM (init := #[]) fun acc x => acc.push (f x) theorem toArrayMap_toList (l : List α) (f : α → β ) : (l.toArrayMap f).toList = l.map f := by suffices ∀ arr : Array β, (l.foldl (init := arr) fun acc x => acc.push (f x)).toList = arr.toList ++ l.map f from this #[] induction l with | nil => simp | cons head tail tail_ih => intro arr have : arr.toList ++ f head :: map f tail = (arr.push (f head)).toList ++ map f tail := by simp rw [List.foldl_cons, List.map_cons, this, ← tail_ih] @[simp, grind =] theorem toArrayMap_eq_toArray_map (l : List α) (f : α → β) : l.toArrayMap f = (l.map f).toArray := Array.ext' (by simpa using toArrayMap_toList l f) end List ================================================ FILE: Batteries/Data/List/Basic.lean ================================================ /- Copyright (c) 2016 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura -/ module public import Batteries.Tactic.Alias @[expose] public section namespace List /-! ## New definitions -/ /-- Computes the "bag intersection" of `l₁` and `l₂`, that is, the collection of elements of `l₁` which are also in `l₂`. As each element is identified, it is removed from `l₂`, so elements are counted with multiplicity. -/ protected def bagInter {α} [BEq α] : List α → List α → List α | [], _ => [] | _, [] => [] | a :: l₁, l₂ => if l₂.elem a then a :: List.bagInter l₁ (l₂.erase a) else List.bagInter l₁ l₂ /-- Computes the difference of `l₁` and `l₂`, by removing each element in `l₂` from `l₁`. -/ protected def diff {α} [BEq α] : List α → List α → List α | l, [] => l | l₁, a :: l₂ => if l₁.elem a then List.diff (l₁.erase a) l₂ else List.diff l₁ l₂ open Option Nat /-- Get the head and tail of a list, if it is nonempty. -/ @[inline] def next? : List α → Option (α × List α) | [] => none | a :: l => some (a, l) /-- `after p xs` is the suffix of `xs` after the first element that satisfies `p`, not including that element. ```lean after (· == 1) [0, 1, 2, 3] = [2, 3] drop_while (· != 1) [0, 1, 2, 3] = [1, 2, 3] ``` -/ @[specialize] def after (p : α → Bool) : List α → List α | [] => [] | x :: xs => bif p x then xs else after p xs /-- Replaces the first element of the list for which `f` returns `some` with the returned value. -/ @[simp] def replaceF (f : α → Option α) : List α → List α | [] => [] | x :: xs => match f x with | none => x :: replaceF f xs | some a => a :: xs /-- Tail-recursive version of `replaceF`. -/ @[inline] def replaceFTR (f : α → Option α) (l : List α) : List α := go l #[] where /-- Auxiliary for `replaceFTR`: `replaceFTR.go f xs acc = acc.toList ++ replaceF f xs`. -/ @[specialize] go : List α → Array α → List α | [], acc => acc.toList | x :: xs, acc => match f x with | none => go xs (acc.push x) | some a' => acc.toListAppend (a' :: xs) @[csimp] theorem replaceF_eq_replaceFTR : @replaceF = @replaceFTR := by funext α p l; simp [replaceFTR] let rec go (acc) : ∀ xs, replaceFTR.go p xs acc = acc.toList ++ xs.replaceF p | [] => by simp [replaceFTR.go, replaceF] | x::xs => by simp [replaceFTR.go, replaceF]; cases p x <;> simp · rw [go _ xs]; simp exact (go #[] _).symm /-- Constructs the union of two lists, by inserting the elements of `l₁` in reverse order to `l₂`. As a result, `l₂` will always be a suffix, but only the last occurrence of each element in `l₁` will be retained (but order will otherwise be preserved). -/ @[inline] protected def union [BEq α] (l₁ l₂ : List α) : List α := foldr .insert l₂ l₁ instance [BEq α] : Union (List α) := ⟨List.union⟩ /-- Constructs the intersection of two lists, by filtering the elements of `l₁` that are in `l₂`. Unlike `bagInter` this does not preserve multiplicity: `[1, 1].inter [1]` is `[1, 1]`. -/ @[inline] protected def inter [BEq α] (l₁ l₂ : List α) : List α := filter (elem · l₂) l₁ instance [BEq α] : Inter (List α) := ⟨List.inter⟩ /-- Split a list at an index. Ensures the left list always has the specified length by right padding with the provided default element. ``` splitAtD 2 [a, b, c] x = ([a, b], [c]) splitAtD 4 [a, b, c] x = ([a, b, c, x], []) ``` -/ def splitAtD (n : Nat) (l : List α) (dflt : α) : List α × List α := go n l [] where /-- Auxiliary for `splitAtD`: `splitAtD.go dflt n l acc = (acc.reverse ++ left, right)` if `splitAtD n l dflt = (left, right)`. -/ go : Nat → List α → List α → List α × List α | n+1, x :: xs, acc => go n xs (x :: acc) | 0, xs, acc => (acc.reverse, xs) | n, [], acc => (acc.reverseAux (replicate n dflt), []) /-- Apply `f` to the last element of `l`, if it exists. -/ @[inline] def modifyLast (f : α → α) (l : List α) : List α := go l #[] where /-- Auxiliary for `modifyLast`: `modifyLast.go f l acc = acc.toList ++ modifyLast f l`. -/ @[specialize] go : List α → Array α → List α | [], _ => [] | [x], acc => acc.toListAppend [f x] | x :: xs, acc => go xs (acc.push x) theorem headD_eq_head? (l) (a : α) : headD l a = (head? l).getD a := by cases l <;> rfl /-- Take `n` elements from a list `l`. If `l` has less than `n` elements, append `n - length l` elements `x`. -/ def takeD : Nat → List α → α → List α | 0, _, _ => [] | n+1, l, x => l.headD x :: takeD n l.tail x @[simp] theorem takeD_zero (l) (a : α) : takeD 0 l a = [] := rfl @[simp] theorem takeD_succ (l) (a : α) : takeD (n+1) l a = l.head?.getD a :: takeD n l.tail a := by simp [takeD] @[simp] theorem takeD_nil (n) (a : α) : takeD n [] a = replicate n a := by induction n <;> simp [*, replicate_succ] /-- Tail-recursive version of `takeD`. -/ def takeDTR (n : Nat) (l : List α) (dflt : α) : List α := go n l #[] where /-- Auxiliary for `takeDTR`: `takeDTR.go dflt n l acc = acc.toList ++ takeD n l dflt`. -/ go : Nat → List α → Array α → List α | n+1, x :: xs, acc => go n xs (acc.push x) | 0, _, acc => acc.toList | n, [], acc => acc.toListAppend (replicate n dflt) theorem takeDTR_go_eq : ∀ n l, takeDTR.go dflt n l acc = acc.toList ++ takeD n l dflt | 0, _ => by simp [takeDTR.go] | _+1, [] => by simp [takeDTR.go, replicate_succ] | _+1, _::l => by simp [takeDTR.go, takeDTR_go_eq _ l] @[csimp] theorem takeD_eq_takeDTR : @takeD = @takeDTR := by funext α f n l; simp [takeDTR, takeDTR_go_eq] /-- Tail-recursive helper function for `scanlM` and `scanrM` -/ @[inline] def scanAuxM [Monad m] (f : β → α → m β) (init : β) (l : List α) : m (List β) := go l init [] where /-- Auxiliary for `scanAuxM` -/ @[specialize] go : List α → β → List β → m (List β) | [], last, acc => pure <| last :: acc | x :: xs, last, acc => do go xs (← f last x) (last :: acc) /-- Fold a list from left to right as with `foldl`, but the combining function also receives each element's index added to an optional parameter `start` (i.e. the numbers that `f` takes as its first argument will be greater than or equal to `start` and less than `start + l.length`). -/ @[specialize] def foldlIdx (f : Nat → α → β → α) (init : α) : List β → (start : Nat := 0) → α | [], _ => init | b :: l, s => foldlIdx f (f s init b) l (s + 1) /-- Fold a list from right to left as with `foldr`, but the combining function also receives each element's index added to an optional parameter `start` (i.e. the numbers that `f` takes as its first argument will be greater than or equal to `start` and less than `start + l.length`). -/ def foldrIdx {α : Type u} {β : Type v} (f : Nat → α → β → β) (init : β) : (l : List α) → (start : Nat := 0) → β | [], _ => init | a :: l, s => f s a (foldrIdx f init l (s + 1)) /-- A tail-recursive version of `foldrIdx`. -/ @[inline] def foldrIdxTR (f : Nat → α → β → β) (init : β) (l : List α) (start : Nat := 0) : β := l.foldr (fun a (acc, n) => (f (n - 1) a acc, n - 1)) (init, start + l.length) |>.1 @[csimp] theorem foldrIdx_eq_foldrIdxTR : @foldrIdx = @foldrIdxTR := by funext _ _ f have go i xs s : xs.foldr (fun a xa => (f (xa.2 - 1) a xa.1, xa.2 - 1)) (i, s + xs.length) = (foldrIdx f i xs s, s) := by induction xs generalizing s <;> grind [foldrIdx] grind [foldrIdxTR] /-- `findIdxs p l s` is the list of indexes of elements of `l` that satisfy `p`, added to an optional parameter `s` (so that the members of `findIdxs p l s` will be greater than or equal to `s` and less than `l.length + s`). -/ @[inline] def findIdxs (p : α → Bool) (l : List α) (start : Nat := 0) : List Nat := foldrIdx (fun i a is => bif p a then i :: is else is) [] l start /-- Returns the elements of `l` that satisfy `p` together with their indexes in `l` added to an optional parameter `start`. The returned list is ordered by index. We have `l.findIdxsValues p s = (l.findIdxs p s).zip (l.filter p)`. -/ @[inline] def findIdxsValues (p : α → Bool) (l : List α) (start : Nat := 0) : List (Nat × α) := foldrIdx (fun i a l => if p a then (i, a) :: l else l) [] l start @[deprecated (since := "2025-11-06")] alias indexsValues := findIdxsValues /-- `findIdxNth p xs n` returns the index of the `n`th element for which `p` returns `true`. For example: ``` findIdxNth (· < 3) [5, 1, 3, 2, 4, 0, 1, 4] 2 = 5 ``` -/ @[inline] def findIdxNth (p : α → Bool) (xs : List α) (n : Nat) : Nat := go xs n 0 where /-- Auxiliary for `findIdxNth`: `findIdxNth.go p l n acc = findIdxNth p l n + acc`. -/ @[specialize] go : (xs : List α) → (n : Nat) → (s : Nat) → Nat | [], _, s => s | a :: xs, 0, s => bif p a then s else go xs 0 (s + 1) | a :: xs, n + 1, s => bif !(p a) then go xs (n + 1) (s + 1) else go xs n (s + 1) /-- `idxsOf a l s` is the list of all indexes of `a` in `l`, added to an optional parameter `s`. For example: ``` idxsOf b [a, b, a, a] = [1] idxsOf a [a, b, a, a] 5 = [5, 7, 8] ``` -/ @[inline] def idxsOf [BEq α] (a : α) (xs : List α) (start : Nat := 0) : List Nat := xs.findIdxs (· == a) start @[deprecated (since := "2025-11-06")] alias indexesOf := idxsOf /-- `idxOfNth a xs n` returns the index of the `n`th instance of `a` in `xs`, counting from `0`. For example: ``` idxOfNth 1 [5, 1, 3, 2, 4, 0, 1, 4] 1 = 6 ``` -/ def idxOfNth [BEq α] (a : α) (xs : List α) (n : Nat) : Nat := xs.findIdxNth (· == a) n /-- `countPBefore p xs i hip` counts the number of `x` in `xs` before the `i`th index for which `p x = true`. For example: ``` countPBefore (· < 3) [5, 1, 3, 2, 4, 0, 1, 4] 5 = 2 ``` -/ def countPBefore (p : α → Bool) (xs : List α) (i : Nat) : Nat := go xs i 0 where /-- Auxiliary for `countPBefore`: `countPBefore.go p l i acc = countPBefore p l i + acc`. -/ @[specialize] go : (xs : List α) → (i : Nat) → (s : Nat) → Nat | _ :: _, 0, s => s | a :: xs, i + 1, s => bif p a then go xs i (s + 1) else go xs i s | [], _, s => s /-- `countBefore a xs n` counts the number of `x` in `xs` before the `i`th index for which `x == a` is true. For example: ``` countBefore 1 [5, 1, 3, 2, 4, 0, 1, 4] 6 = 1 ``` -/ def countBefore [BEq α] (a : α) : List α → Nat → Nat := countPBefore (· == a) /-- `lookmap` is a combination of `lookup` and `filterMap`. `lookmap f l` will apply `f : α → Option α` to each element of the list, replacing `a → b` at the first value `a` in the list such that `f a = some b`. -/ @[inline] def lookmap (f : α → Option α) (l : List α) : List α := go l #[] where /-- Auxiliary for `lookmap`: `lookmap.go f l acc = acc.toList ++ lookmap f l`. -/ @[specialize] go : List α → Array α → List α | [], acc => acc.toList | a :: l, acc => match f a with | some b => acc.toListAppend (b :: l) | none => go l (acc.push a) /-- `inits l` is the list of initial segments of `l`. ``` inits [1, 2, 3] = [[], [1], [1, 2], [1, 2, 3]] ``` -/ @[simp] def inits : List α → List (List α) | [] => [[]] | a :: l => [] :: map (fun t => a :: t) (inits l) /-- Tail-recursive version of `inits`. -/ def initsTR (l : List α) : List (List α) := l.foldr (fun a arrs => (arrs.map fun t => a :: t).push []) #[[]] |>.toListRev @[csimp] theorem inits_eq_initsTR : @inits = @initsTR := by funext α l; simp [initsTR]; induction l <;> simp [*, map_reverse] /-- `tails l` is the list of terminal segments of `l`. ``` tails [1, 2, 3] = [[1, 2, 3], [2, 3], [3], []] ``` -/ @[simp] def tails : List α → List (List α) | [] => [[]] | a :: l => (a :: l) :: tails l /-- Tail-recursive version of `tails`. -/ def tailsTR (l : List α) : List (List α) := go l #[] where /-- Auxiliary for `tailsTR`: `tailsTR.go l acc = acc.toList ++ tails l`. -/ go (l : List α) (acc : Array (List α)) : List (List α) := match l with | [] => acc.toListAppend [[]] | _::xs => go xs (acc.push l) @[csimp] theorem tails_eq_tailsTR : @tails = @tailsTR := by funext α have H (l : List α) : ∀ acc, tailsTR.go l acc = acc.toList ++ tails l := by induction l <;> simp [*, tailsTR.go] simp (config := { unfoldPartialApp := true }) [tailsTR, H] /-- `sublists' l` is the list of all (non-contiguous) sublists of `l`. It differs from `sublists` only in the order of appearance of the sublists; `sublists'` uses the first element of the list as the MSB, `sublists` uses the first element of the list as the LSB. ``` sublists' [1, 2, 3] = [[], [3], [2], [2, 3], [1], [1, 3], [1, 2], [1, 2, 3]] ``` -/ def sublists' (l : List α) : List (List α) := let f a arr := arr.foldl (init := arr) fun r l => r.push (a :: l) (l.foldr f #[[]]).toList /-- `sublists l` is the list of all (non-contiguous) sublists of `l`; cf. `sublists'` for a different ordering. ``` sublists [1, 2, 3] = [[], [1], [2], [1, 2], [3], [1, 3], [2, 3], [1, 2, 3]] ``` -/ def sublists (l : List α) : List (List α) := l.foldr (fun a acc => acc.flatMap fun x => [x, a :: x]) [[]] /-- A version of `List.sublists` that has faster runtime performance but worse kernel performance -/ def sublistsFast (l : List α) : List (List α) := let f a arr := arr.foldl (init := Array.mkEmpty (arr.size * 2)) fun r l => (r.push l).push (a :: l) (l.foldr f #[[]]).toList @[csimp] theorem sublists_eq_sublistsFast : @sublists = @sublistsFast := funext <| fun _ => funext fun _ => foldr_hom Array.toList fun _ r => flatMap_eq_foldl.trans <| (foldl_toArray _ _ _).symm.trans <| r.foldl_hom Array.toList <| fun r _ => r.toList_append.symm section Forall₂ variable {r : α → β → Prop} {p : γ → δ → Prop} /-- `Forall₂ R l₁ l₂` means that `l₁` and `l₂` have the same length, and whenever `a` is the nth element of `l₁`, and `b` is the nth element of `l₂`, then `R a b` is satisfied. -/ inductive Forall₂ (R : α → β → Prop) : List α → List β → Prop /-- Two nil lists are `Forall₂`-related -/ | nil : Forall₂ R [] [] /-- Two cons lists are related by `Forall₂ R` if the heads are related by `R` and the tails are related by `Forall₂ R` -/ | cons {a b l₁ l₂} : R a b → Forall₂ R l₁ l₂ → Forall₂ R (a :: l₁) (b :: l₂) attribute [simp] Forall₂.nil @[simp] theorem forall₂_cons {R : α → β → Prop} {a b l₁ l₂} : Forall₂ R (a :: l₁) (b :: l₂) ↔ R a b ∧ Forall₂ R l₁ l₂ := ⟨fun | .cons h tail => ⟨h, tail⟩, fun ⟨head, tail⟩ => .cons head tail⟩ /-- Check for all elements `a`, `b`, where `a` and `b` are the nth element of the first and second List respectively, that `r a b = true`. -/ def all₂ (r : α → β → Bool) : List α → List β → Bool | [], [] => true | a::as, b::bs => if r a b then all₂ r as bs else false | _, _ => false @[simp] theorem all₂_eq_true {r : α → β → Bool} : ∀ l₁ l₂, all₂ r l₁ l₂ ↔ Forall₂ (r · ·) l₁ l₂ | [], [] => by simp [all₂] | a::as, b::bs => by by_cases h : r a b <;> simp [all₂, h, all₂_eq_true, forall₂_cons] | _::_, [] | [], _::_ => by simp [all₂] exact nofun instance {R : α → β → Prop} [∀ a b, Decidable (R a b)] : ∀ l₁ l₂, Decidable (Forall₂ R l₁ l₂) := fun l₁ l₂ => decidable_of_iff (all₂ (R · ·) l₁ l₂) (by simp [all₂_eq_true]) end Forall₂ /-- Transpose of a list of lists, treated as a matrix. ``` transpose [[1, 2], [3, 4], [5, 6]] = [[1, 3, 5], [2, 4, 6]] ``` -/ def transpose (l : List (List α)) : List (List α) := (l.foldr go #[]).toList where /-- `pop : List α → StateM (List α) (List α)` transforms the input list `old` by taking the head of the current state and pushing it on the head of `old`. If the state list is empty, then `old` is left unchanged. -/ pop (old : List α) : StateM (List α) (List α) | [] => (old, []) | a :: l => (a :: old, l) /-- `go : List α → Array (List α) → Array (List α)` handles the insertion of a new list into all the lists in the array: `go [a, b, c] #[l₁, l₂, l₃] = #[a::l₁, b::l₂, c::l₃]`. If the new list is too short, the later lists are unchanged, and if it is too long the array is extended: ``` go [a] #[l₁, l₂, l₃] = #[a::l₁, l₂, l₃] go [a, b, c, d] #[l₁, l₂, l₃] = #[a::l₁, b::l₂, c::l₃, [d]] ``` -/ go (l : List α) (acc : Array (List α)) : Array (List α) := let (acc, l) := acc.mapM pop l l.foldl (init := acc) fun arr a => arr.push [a] /-- List of all sections through a list of lists. A section of `[L₁, L₂, ..., Lₙ]` is a list whose first element comes from `L₁`, whose second element comes from `L₂`, and so on. -/ @[simp] def sections : List (List α) → List (List α) | [] => [[]] | l :: L => (sections L).flatMap fun s => l.map fun a => a :: s /-- Optimized version of `sections`. -/ def sectionsTR (L : List (List α)) : List (List α) := bif L.any isEmpty then [] else (L.foldr go #[[]]).toList where /-- `go : List α → Array (List α) → Array (List α)` inserts one list into the accumulated list of sections `acc`: `go [a, b] #[l₁, l₂] = [a::l₁, b::l₁, a::l₂, b::l₂]`. -/ go (l : List α) (acc : Array (List α)) : Array (List α) := acc.foldl (init := #[]) fun acc' l' => l.foldl (init := acc') fun acc' a => acc'.push (a :: l') theorem sections_eq_nil_of_isEmpty : ∀ {L}, L.any isEmpty → @sections α L = [] | l :: L, h => by simp only [any, Bool.or_eq_true] at h match l, h with | [], .inl rfl => simp | l, .inr h => simp [sections, sections_eq_nil_of_isEmpty h] @[csimp] theorem sections_eq_sectionsTR : @sections = @sectionsTR := by funext α L; simp [sectionsTR] cases e : L.any isEmpty <;> simp [sections_eq_nil_of_isEmpty, *] clear e; induction L with | nil => rfl | cons l L IH => ?_ simp [IH, sectionsTR.go] rfl /-- `extractP p l` returns a pair of an element `a` of `l` satisfying the predicate `p`, and `l`, with `a` removed. If there is no such element `a` it returns `(none, l)`. -/ def extractP (p : α → Bool) (l : List α) : Option α × List α := go l #[] where /-- Auxiliary for `extractP`: `extractP.go p l xs acc = (some a, acc.toList ++ out)` if `extractP p xs = (some a, out)`, and `extractP.go p l xs acc = (none, l)` if `extractP p xs = (none, _)`. -/ go : List α → Array α → Option α × List α | [], _ => (none, l) | a :: l, acc => bif p a then (some a, acc.toListAppend l) else go l (acc.push a) /-- `revzip l` returns a list of pairs of the elements of `l` paired with the elements of `l` in reverse order. ``` revzip [1, 2, 3, 4, 5] = [(1, 5), (2, 4), (3, 3), (4, 2), (5, 1)] ``` -/ def revzip (l : List α) : List (α × α) := zip l l.reverse /-- `product l₁ l₂` is the list of pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂`. ``` product [1, 2] [5, 6] = [(1, 5), (1, 6), (2, 5), (2, 6)] ``` -/ def product (l₁ : List α) (l₂ : List β) : List (α × β) := l₁.flatMap fun a => l₂.map (Prod.mk a) /-- Optimized version of `product`. -/ def productTR (l₁ : List α) (l₂ : List β) : List (α × β) := l₁.foldl (fun acc a => l₂.foldl (fun acc b => acc.push (a, b)) acc) #[] |>.toList @[csimp] theorem product_eq_productTR : @product = @productTR := by funext α β l₁ l₂; simp only [product, productTR] rw [Array.foldl_toList_eq_flatMap]; rfl simp /-- `sigma l₁ l₂` is the list of dependent pairs `(a, b)` where `a ∈ l₁` and `b ∈ l₂ a`. ``` sigma [1, 2] (λ_, [(5 : Nat), 6]) = [(1, 5), (1, 6), (2, 5), (2, 6)] ``` -/ protected def sigma {σ : α → Type _} (l₁ : List α) (l₂ : ∀ a, List (σ a)) : List (Σ a, σ a) := l₁.flatMap fun a => (l₂ a).map (Sigma.mk a) /-- Optimized version of `sigma`. -/ def sigmaTR {σ : α → Type _} (l₁ : List α) (l₂ : ∀ a, List (σ a)) : List (Σ a, σ a) := l₁.foldl (fun acc a => (l₂ a).foldl (fun acc b => acc.push ⟨a, b⟩) acc) #[] |>.toList @[csimp] theorem sigma_eq_sigmaTR : @List.sigma = @sigmaTR := by funext α β l₁ l₂; simp only [List.sigma, sigmaTR] rw [Array.foldl_toList_eq_flatMap]; rfl simp /-- `ofFnNthVal f i` returns `some (f i)` if `i < n` and `none` otherwise. -/ def ofFnNthVal {n} (f : Fin n → α) (i : Nat) : Option α := if h : i < n then some (f ⟨i, h⟩) else none /-- `Disjoint l₁ l₂` means that `l₁` and `l₂` have no elements in common. -/ def Disjoint (l₁ l₂ : List α) : Prop := ∀ ⦃a⦄, a ∈ l₁ → a ∈ l₂ → False /-- Returns the longest initial prefix of two lists such that they are pairwise related by `R`. ``` takeWhile₂ (· < ·) [1, 2, 4, 5] [5, 4, 3, 6] = ([1, 2], [5, 4]) ``` -/ def takeWhile₂ (R : α → β → Bool) : List α → List β → List α × List β | a::as, b::bs => if R a b then let (as', bs') := takeWhile₂ R as bs (a::as', b::bs') else ([], []) | _, _ => ([], []) /-- Tail-recursive version of `takeWhile₂`. -/ @[inline] def takeWhile₂TR (R : α → β → Bool) (as : List α) (bs : List β) : List α × List β := go as bs [] [] where /-- Auxiliary for `takeWhile₂TR`: `takeWhile₂TR.go R as bs acca accb = (acca.reverse ++ as', acca.reverse ++ bs')` if `takeWhile₂ R as bs = (as', bs')`. -/ @[specialize] go : List α → List β → List α → List β → List α × List β | a::as, b::bs, acca, accb => bif R a b then go as bs (a::acca) (b::accb) else (acca.reverse, accb.reverse) | _, _, acca, accb => (acca.reverse, accb.reverse) @[csimp] theorem takeWhile₂_eq_takeWhile₂TR : @takeWhile₂ = @takeWhile₂TR := by funext α β R as bs; simp [takeWhile₂TR] let rec go (as bs acca accb) : takeWhile₂TR.go R as bs acca accb = (acca.reverse ++ (as.takeWhile₂ R bs).1, accb.reverse ++ (as.takeWhile₂ R bs).2) := by unfold takeWhile₂TR.go takeWhile₂; split <;> simp rename_i a as b bs; unfold cond; cases R a b <;> simp [go as bs] exact (go as bs [] []).symm /-- `pwFilter R l` is a maximal sublist of `l` which is `Pairwise R`. `pwFilter (·≠·)` is the erase duplicates function (cf. `eraseDups`), and `pwFilter (·<·)` finds a maximal increasing subsequence in `l`. For example, ``` pwFilter (·<·) [0, 1, 5, 2, 6, 3, 4] = [0, 1, 2, 3, 4] ``` -/ def pwFilter (R : α → α → Prop) [DecidableRel R] (l : List α) : List α := l.foldr (fun x IH => if ∀ y ∈ IH, R x y then x :: IH else IH) [] /-- `IsChain R l` means that `R` holds between adjacent elements of `l`. Example: ``` IsChain R [a, b, c, d] ↔ R a b ∧ R b c ∧ R c d ``` -/ inductive IsChain (R : α → α → Prop) : List α → Prop where /-- A list of length 0 is a chain. -/ | nil : IsChain R [] /-- A list of length 1 is a chain. -/ | singleton (a : α) : IsChain R [a] /-- If `a` relates to `b` and `b::l` is a chain, then `a :: b :: l` is also a chain. -/ | cons_cons (hr : R a b) (h : IsChain R (b :: l)) : IsChain R (a :: b :: l) attribute [simp, grind ←] IsChain.nil attribute [simp, grind ←] IsChain.singleton @[simp, grind =] theorem isChain_cons_cons : IsChain R (a :: b :: l) ↔ R a b ∧ IsChain R (b :: l) := ⟨fun | .cons_cons hr h => ⟨hr, h⟩, fun ⟨hr, h⟩ => .cons_cons hr h⟩ instance {R : α → α → Prop} [h : DecidableRel R] : (l : List α) → Decidable (l.IsChain R) | [] => isTrue .nil | a :: l => go a l where go (a : α) (l : List α) : Decidable ((a :: l).IsChain R) := match l with | [] => isTrue <| .singleton a | b :: l => haveI := (go b l); decidable_of_iff' _ isChain_cons_cons /-- `Chain R a l` means that `R` holds between adjacent elements of `a::l`. ``` Chain R a [b, c, d] ↔ R a b ∧ R b c ∧ R c d ``` -/ @[deprecated IsChain (since := "2025-09-19")] def Chain : (α → α → Prop) → α → List α → Prop := (IsChain · <| · :: ·) set_option linter.deprecated false in /-- A list of length 1 is a chain. -/ @[deprecated IsChain.singleton (since := "2025-09-19")] theorem Chain.nil {a : α} : Chain R a [] := IsChain.singleton a set_option linter.deprecated false in /-- If `a` relates to `b` and `b::l` is a chain, then `a :: b :: l` is also a chain. -/ @[deprecated IsChain.cons_cons (since := "2025-09-19")] theorem Chain.cons : R a b → Chain R b l → Chain R a (b :: l) := IsChain.cons_cons /-- `Chain' R l` means that `R` holds between adjacent elements of `l`. ``` Chain' R [a, b, c, d] ↔ R a b ∧ R b c ∧ R c d ``` -/ @[deprecated IsChain (since := "2025-09-19")] def Chain' : (α → α → Prop) → List α → Prop := (IsChain · ·) /-- **Deprecated:** Use `reverse ∘ eraseDups ∘ reverse` or just `eraseDups` instead. -/ @[deprecated "use `reverse ∘ eraseDups ∘ reverse` or just `eraseDups`" (since := "2026-01-03")] abbrev eraseDup [BEq α] : List α → List α := pwFilter (· != ·) /-- `rotate l n` rotates the elements of `l` to the left by `n` ``` rotate [0, 1, 2, 3, 4, 5] 2 = [2, 3, 4, 5, 0, 1] ``` -/ @[inline] def rotate (l : List α) (n : Nat) : List α := let (l₁, l₂) := List.splitAt (n % l.length) l l₂ ++ l₁ /-- `rotate'` is the same as `rotate`, but slower. Used for proofs about `rotate` -/ @[simp] def rotate' : List α → Nat → List α | [], _ => [] | l, 0 => l | a :: l, n+1 => rotate' (l ++ [a]) n /-- `mapDiagM f l` calls `f` on all elements in the upper triangular part of `l × l`. That is, for each `e ∈ l`, it will run `f e e` and then `f e e'` for each `e'` that appears after `e` in `l`. ``` mapDiagM f [1, 2, 3] = return [← f 1 1, ← f 1 2, ← f 1 3, ← f 2 2, ← f 2 3, ← f 3 3] ``` -/ def mapDiagM [Monad m] (f : α → α → m β) (l : List α) : m (List β) := go l #[] where /-- Auxiliary for `mapDiagM`: `mapDiagM.go as f acc = (acc.toList ++ ·) <$> mapDiagM f as` -/ go : List α → Array β → m (List β) | [], acc => pure acc.toList | x::xs, acc => do let b ← f x x let acc ← xs.foldlM (·.push <$> f x ·) (acc.push b) go xs acc /-- `forDiagM f l` calls `f` on all elements in the upper triangular part of `l × l`. That is, for each `e ∈ l`, it will run `f e e` and then `f e e'` for each `e'` that appears after `e` in `l`. ``` forDiagM f [1, 2, 3] = do f 1 1; f 1 2; f 1 3; f 2 2; f 2 3; f 3 3 ``` -/ @[simp] def forDiagM [Monad m] (f : α → α → m PUnit) : List α → m PUnit | [] => pure ⟨⟩ | x :: xs => do f x x; xs.forM (f x); xs.forDiagM f /-- `getRest l l₁` returns `some l₂` if `l = l₁ ++ l₂`. If `l₁` is not a prefix of `l`, returns `none` -/ def getRest [DecidableEq α] : List α → List α → Option (List α) | l, [] => some l | [], _ => none | x :: l, y :: l₁ => if x = y then getRest l l₁ else none /-- `List.dropSlice n m xs` removes a slice of length `m` at index `n` in list `xs`. -/ @[simp] def dropSlice : Nat → Nat → List α → List α | _, _, [] => [] | 0, m, xs => xs.drop m | n+1, m, x :: xs => x :: dropSlice n m xs /-- Optimized version of `dropSlice`. -/ @[inline] def dropSliceTR (n m : Nat) (l : List α) : List α := match m with | 0 => l | m+1 => go m l n #[] where /-- Auxiliary for `dropSliceTR`: `dropSliceTR.go l m xs n acc = acc.toList ++ dropSlice n m xs` unless `n ≥ length xs`, in which case it is `l`. -/ go (m : Nat) : List α → Nat → Array α → List α | [], _, _ => l | _::xs, 0, acc => acc.toListAppend (xs.drop m) | x::xs, n+1, acc => go m xs n (acc.push x) theorem dropSlice_zero₂ : ∀ n l, @dropSlice α n 0 l = l | 0, [] | 0, _::_ | _+1, [] => rfl | n+1, x::xs => by simp [dropSlice, dropSlice_zero₂] @[csimp] theorem dropSlice_eq_dropSliceTR : @dropSlice = @dropSliceTR := by funext α n m l; simp [dropSliceTR] split; { rw [dropSlice_zero₂] } rename_i m let rec go (acc) : ∀ xs n, l = acc.toList ++ xs → dropSliceTR.go l m xs n acc = acc.toList ++ xs.dropSlice n (m+1) | [], n | _::xs, 0 => fun h => by simp [dropSliceTR.go, dropSlice, h] | x::xs, n+1 => by simp [dropSliceTR.go, dropSlice]; intro h; rw [go _ xs]; {simp}; simp [h] exact (go #[] _ _ rfl).symm /-- Left-biased version of `List.zipWith`. `zipWithLeft' f as bs` applies `f` to each pair of elements `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, `f` is applied to `none` for the remaining `aᵢ`. Returns the results of the `f` applications and the remaining `bs`. ``` zipWithLeft' prod.mk [1, 2] ['a'] = ([(1, some 'a'), (2, none)], []) zipWithLeft' prod.mk [1] ['a', 'b'] = ([(1, some 'a')], ['b']) ``` -/ @[simp] def zipWithLeft' (f : α → Option β → γ) : List α → List β → List γ × List β | [], bs => ([], bs) | a :: as, [] => ((a :: as).map fun a => f a none, []) | a :: as, b :: bs => let r := zipWithLeft' f as bs; (f a (some b) :: r.1, r.2) /-- Tail-recursive version of `zipWithLeft'`. -/ @[inline] def zipWithLeft'TR (f : α → Option β → γ) (as : List α) (bs : List β) : List γ × List β := go as bs #[] where /-- Auxiliary for `zipWithLeft'TR`: `zipWithLeft'TR.go l acc = acc.toList ++ zipWithLeft' l`. -/ go : List α → List β → Array γ → List γ × List β | [], bs, acc => (acc.toList, bs) | as, [], acc => (as.foldl (fun acc a => acc.push (f a none)) acc |>.toList, []) | a :: as, b :: bs, acc => go as bs (acc.push (f a (some b))) @[csimp] theorem zipWithLeft'_eq_zipWithLeft'TR : @zipWithLeft' = @zipWithLeft'TR := by funext α β γ f as bs; simp [zipWithLeft'TR] let rec go (acc) : ∀ as bs, zipWithLeft'TR.go f as bs acc = let (l, r) := as.zipWithLeft' f bs; (acc.toList ++ l, r) | [], bs => by simp [zipWithLeft'TR.go] | _::_, [] => by simp [zipWithLeft'TR.go] | a::as, b::bs => by simp [zipWithLeft'TR.go, go _ as bs] simp [go] /-- Right-biased version of `List.zipWith`. `zipWithRight' f as bs` applies `f` to each pair of elements `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, `f` is applied to `none` for the remaining `bᵢ`. Returns the results of the `f` applications and the remaining `as`. ``` zipWithRight' prod.mk [1] ['a', 'b'] = ([(some 1, 'a'), (none, 'b')], []) zipWithRight' prod.mk [1, 2] ['a'] = ([(some 1, 'a')], [2]) ``` -/ @[inline] def zipWithRight' (f : Option α → β → γ) (as : List α) (bs : List β) : List γ × List α := zipWithLeft' (flip f) bs as /-- Left-biased version of `List.zip`. `zipLeft' as bs` returns the list of pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, the remaining `aᵢ` are paired with `none`. Also returns the remaining `bs`. ``` zipLeft' [1, 2] ['a'] = ([(1, some 'a'), (2, none)], []) zipLeft' [1] ['a', 'b'] = ([(1, some 'a')], ['b']) zipLeft' = zipWithLeft' prod.mk ``` -/ @[inline] def zipLeft' : List α → List β → List (α × Option β) × List β := zipWithLeft' Prod.mk /-- Right-biased version of `List.zip`. `zipRight' as bs` returns the list of pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, the remaining `bᵢ` are paired with `none`. Also returns the remaining `as`. ``` zipRight' [1] ['a', 'b'] = ([(some 1, 'a'), (none, 'b')], []) zipRight' [1, 2] ['a'] = ([(some 1, 'a')], [2]) zipRight' = zipWithRight' prod.mk ``` -/ @[inline] def zipRight' : List α → List β → List (Option α × β) × List α := zipWithRight' Prod.mk /-- Left-biased version of `List.zipWith`. `zipWithLeft f as bs` applies `f` to each pair `aᵢ ∈ as` and `bᵢ ‌∈ bs`. If `bs` is shorter than `as`, `f` is applied to `none` for the remaining `aᵢ`. ``` zipWithLeft prod.mk [1, 2] ['a'] = [(1, some 'a'), (2, none)] zipWithLeft prod.mk [1] ['a', 'b'] = [(1, some 'a')] zipWithLeft f as bs = (zipWithLeft' f as bs).fst ``` -/ @[simp] def zipWithLeft (f : α → Option β → γ) : List α → List β → List γ | [], _ => [] | a :: as, [] => (a :: as).map fun a => f a none | a :: as, b :: bs => f a (some b) :: zipWithLeft f as bs /-- Tail-recursive version of `zipWithLeft`. -/ @[inline] def zipWithLeftTR (f : α → Option β → γ) (as : List α) (bs : List β) : List γ := go as bs #[] where /-- Auxiliary for `zipWithLeftTR`: `zipWithLeftTR.go l acc = acc.toList ++ zipWithLeft l`. -/ go : List α → List β → Array γ → List γ | [], _, acc => acc.toList | as, [], acc => as.foldl (fun acc a => acc.push (f a none)) acc |>.toList | a :: as, b :: bs, acc => go as bs (acc.push (f a (some b))) @[csimp] theorem zipWithLeft_eq_zipWithLeftTR : @zipWithLeft = @zipWithLeftTR := by funext α β γ f as bs; simp [zipWithLeftTR] let rec go (acc) : ∀ as bs, zipWithLeftTR.go f as bs acc = acc.toList ++ as.zipWithLeft f bs | [], bs => by simp [zipWithLeftTR.go] | _::_, [] => by simp [zipWithLeftTR.go] | a::as, b::bs => by simp [zipWithLeftTR.go, go _ as bs] simp [go] /-- Right-biased version of `List.zipWith`. `zipWithRight f as bs` applies `f` to each pair `aᵢ ∈ as` and `bᵢ ‌∈ bs`. If `as` is shorter than `bs`, `f` is applied to `none` for the remaining `bᵢ`. ``` zipWithRight prod.mk [1, 2] ['a'] = [(some 1, 'a')] zipWithRight prod.mk [1] ['a', 'b'] = [(some 1, 'a'), (none, 'b')] zipWithRight f as bs = (zipWithRight' f as bs).fst ``` -/ @[inline] def zipWithRight (f : Option α → β → γ) (as : List α) (bs : List β) : List γ := zipWithLeft (flip f) bs as /-- Left-biased version of `List.zip`. `zipLeft as bs` returns the list of pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `bs` is shorter than `as`, the remaining `aᵢ` are paired with `none`. ``` zipLeft [1, 2] ['a'] = [(1, some 'a'), (2, none)] zipLeft [1] ['a', 'b'] = [(1, some 'a')] zipLeft = zipWithLeft prod.mk ``` -/ @[inline] def zipLeft : List α → List β → List (α × Option β) := zipWithLeft Prod.mk /-- Right-biased version of `List.zip`. `zipRight as bs` returns the list of pairs `(aᵢ, bᵢ)` for `aᵢ ∈ as` and `bᵢ ∈ bs`. If `as` is shorter than `bs`, the remaining `bᵢ` are paired with `none`. ``` zipRight [1, 2] ['a'] = [(some 1, 'a')] zipRight [1] ['a', 'b'] = [(some 1, 'a'), (none, 'b')] zipRight = zipWithRight prod.mk ``` -/ @[inline] def zipRight : List α → List β → List (Option α × β) := zipWithRight Prod.mk /-- If all elements of `xs` are `some xᵢ`, `allSome xs` returns the `xᵢ`. Otherwise it returns `none`. ``` allSome [some 1, some 2] = some [1, 2] allSome [some 1, none ] = none ``` -/ @[inline] def allSome (l : List (Option α)) : Option (List α) := l.mapM id /-- `fillNones xs ys` replaces the `none`s in `xs` with elements of `ys`. If there are not enough `ys` to replace all the `none`s, the remaining `none`s are dropped from `xs`. ``` fillNones [none, some 1, none, none] [2, 3] = [2, 1, 3] ``` -/ @[simp, deprecated "Deprecated without replacement." (since := "2025-08-07")] def fillNones {α} : List (Option α) → List α → List α | [], _ => [] | some a :: as, as' => a :: fillNones as as' | none :: as, [] => as.reduceOption | none :: as, a :: as' => a :: fillNones as as' /-- `takeList as ns` extracts successive sublists from `as`. For `ns = n₁ ... nₘ`, it first takes the `n₁` initial elements from `as`, then the next `n₂` ones, etc. It returns the sublists of `as` -- one for each `nᵢ` -- and the remaining elements of `as`. If `as` does not have at least as many elements as the sum of the `nᵢ`, the corresponding sublists will have less than `nᵢ` elements. ``` takeList ['a', 'b', 'c', 'd', 'e'] [2, 1, 1] = ([['a', 'b'], ['c'], ['d']], ['e']) takeList ['a', 'b'] [3, 1] = ([['a', 'b'], []], []) ``` -/ def takeList {α} : List α → List Nat → List (List α) × List α | xs, [] => ([], xs) | xs, n :: ns => let (xs₁, xs₂) := xs.splitAt n let (xss, rest) := takeList xs₂ ns (xs₁ :: xss, rest) /-- Tail-recursive version of `takeList`. -/ @[inline] def takeListTR (xs : List α) (ns : List Nat) : List (List α) × List α := go ns xs #[] where /-- Auxiliary for `takeListTR`: `takeListTR.go as as' acc = acc.toList ++ takeList as as'`. -/ go : List Nat → List α → Array (List α) → List (List α) × List α | [], xs, acc => (acc.toList, xs) | n :: ns, xs, acc => let (xs₁, xs₂) := xs.splitAt n go ns xs₂ (acc.push xs₁) @[csimp] theorem takeList_eq_takeListTR : @takeList = @takeListTR := by funext α xs ns; simp [takeListTR] let rec go (acc) : ∀ ns xs, @takeListTR.go α ns xs acc = let (l, r) := xs.takeList ns; (acc.toList ++ l, r) | [], xs => by simp [takeListTR.go, takeList] | n::ns, xs => by simp [takeListTR.go, takeList, go _ ns] simp [go] /-- Auxliary definition used to define `toChunks`. `toChunksAux n xs i` returns `(xs.take i, (xs.drop i).toChunks (n+1))`, that is, the first `i` elements of `xs`, and the remaining elements chunked into sublists of length `n+1`. -/ def toChunksAux {α} (n : Nat) : List α → Nat → List α × List (List α) | [], _ => ([], []) | x :: xs, 0 => let (l, L) := toChunksAux n xs n ([], (x :: l) :: L) | x :: xs, i+1 => let (l, L) := toChunksAux n xs i (x :: l, L) /-- `xs.toChunks n` splits the list into sublists of size at most `n`, such that `(xs.toChunks n).join = xs`. ``` [1, 2, 3, 4, 5, 6, 7, 8].toChunks 10 = [[1, 2, 3, 4, 5, 6, 7, 8]] [1, 2, 3, 4, 5, 6, 7, 8].toChunks 3 = [[1, 2, 3], [4, 5, 6], [7, 8]] [1, 2, 3, 4, 5, 6, 7, 8].toChunks 2 = [[1, 2], [3, 4], [5, 6], [7, 8]] [1, 2, 3, 4, 5, 6, 7, 8].toChunks 0 = [[1, 2, 3, 4, 5, 6, 7, 8]] ``` -/ def toChunks {α} : Nat → List α → List (List α) | _, [] => [] | 0, xs => [xs] | n, x :: xs => let rec /-- Auxliary definition used to define `toChunks`. `toChunks.go xs acc₁ acc₂` pushes elements into `acc₁` until it reaches size `n`, then it pushes the resulting list to `acc₂` and continues until `xs` is exhausted. -/ go : List α → Array α → Array (List α) → List (List α) | [], acc₁, acc₂ => acc₂.push acc₁.toList |>.toList | x :: xs, acc₁, acc₂ => if acc₁.size == n then go xs ((Array.mkEmpty n).push x) (acc₂.push acc₁.toList) else go xs (acc₁.push x) acc₂ go xs #[x] #[] /-! We add some n-ary versions of `List.zipWith` for functions with more than two arguments. These can also be written in terms of `List.zip` or `List.zipWith`. For example, `zipWith₃ f xs ys zs` could also be written as `zipWith id (zipWith f xs ys) zs` or as `(zip xs <| zip ys zs).map fun ⟨x, y, z⟩ => f x y z`. -/ -- TODO(Mario): tail recursive /-- Ternary version of `List.zipWith`. -/ def zipWith₃ (f : α → β → γ → δ) : List α → List β → List γ → List δ | x :: xs, y :: ys, z :: zs => f x y z :: zipWith₃ f xs ys zs | _, _, _ => [] /-- Quaternary version of `List.zipWith`. -/ def zipWith₄ (f : α → β → γ → δ → ε) : List α → List β → List γ → List δ → List ε | x :: xs, y :: ys, z :: zs, u :: us => f x y z u :: zipWith₄ f xs ys zs us | _, _, _, _ => [] /-- Quinary version of `List.zipWith`. -/ def zipWith₅ (f : α → β → γ → δ → ε → ζ) : List α → List β → List γ → List δ → List ε → List ζ | x :: xs, y :: ys, z :: zs, u :: us, v :: vs => f x y z u v :: zipWith₅ f xs ys zs us vs | _, _, _, _, _ => [] /-- An auxiliary function for `List.mapWithPrefixSuffix`. -/ -- TODO(Mario): tail recursive def mapWithPrefixSuffixAux {α β} (f : List α → α → List α → β) : List α → List α → List β | _, [] => [] | prev, h :: t => f prev h t :: mapWithPrefixSuffixAux f (prev.concat h) t /-- `List.mapWithPrefixSuffix f l` maps `f` across a list `l`. For each `a ∈ l` with `l = pref ++ [a] ++ suff`, `a` is mapped to `f pref a suff`. Example: if `f : list Nat → Nat → list Nat → β`, `List.mapWithPrefixSuffix f [1, 2, 3]` will produce the list `[f [] 1 [2, 3], f [1] 2 [3], f [1, 2] 3 []]`. -/ def mapWithPrefixSuffix {α β} (f : List α → α → List α → β) (l : List α) : List β := mapWithPrefixSuffixAux f [] l /-- `List.mapWithComplement f l` is a variant of `List.mapWithPrefixSuffix` that maps `f` across a list `l`. For each `a ∈ l` with `l = pref ++ [a] ++ suff`, `a` is mapped to `f a (pref ++ suff)`, i.e., the list input to `f` is `l` with `a` removed. Example: if `f : Nat → list Nat → β`, `List.mapWithComplement f [1, 2, 3]` will produce the list `[f 1 [2, 3], f 2 [1, 3], f 3 [1, 2]]`. -/ def mapWithComplement {α β} (f : α → List α → β) : List α → List β := mapWithPrefixSuffix fun pref a suff => f a (pref ++ suff) /-- Map each element of a `List` to an action, evaluate these actions in order, and collect the results. -/ protected def traverse [Applicative F] (f : α → F β) : List α → F (List β) | [] => pure [] | x :: xs => List.cons <$> f x <*> List.traverse f xs /-- `Subperm l₁ l₂`, denoted `l₁ <+~ l₂`, means that `l₁` is a sublist of a permutation of `l₂`. This is an analogue of `l₁ ⊆ l₂` which respects multiplicities of elements, and is used for the `≤` relation on multisets. -/ def Subperm (l₁ l₂ : List α) : Prop := ∃ l, l ~ l₁ ∧ l <+ l₂ @[inherit_doc] scoped infixl:50 " <+~ " => Subperm /-- `O(|l₁| * (|l₁| + |l₂|))`. Computes whether `l₁` is a sublist of a permutation of `l₂`. See `isSubperm_iff` for a characterization in terms of `List.Subperm`. -/ def isSubperm [BEq α] (l₁ l₂ : List α) : Bool := ∀ x ∈ l₁, count x l₁ ≤ count x l₂ /-- `O(|l|)`. Inserts `a` in `l` right before the first element such that `p` is true, or at the end of the list if `p` always false on `l`. -/ def insertP (p : α → Bool) (a : α) (l : List α) : List α := loop l [] where /-- Inner loop for `insertP`. Tail recursive. -/ loop : List α → List α → List α | [], r => reverseAux (a :: r) [] -- Note: `reverseAux` is tail recursive. | b :: l, r => bif p b then reverseAux (a :: r) (b :: l) else loop l (b :: r) /-- `dropPrefix? l p` returns `some r` if `l = p' ++ r` for some `p'` which is paiwise `==` to `p`, and `none` otherwise. -/ def dropPrefix? [BEq α] : List α → List α → Option (List α) | list, [] => some list | [], _ :: _ => none | a :: as, b :: bs => if a == b then dropPrefix? as bs else none /-- `dropSuffix? l s` returns `some r` if `l = r ++ s'` for some `s'` which is paiwise `==` to `s`, and `none` otherwise. -/ def dropSuffix? [BEq α] (l s : List α) : Option (List α) := let (r, s') := l.splitAt (l.length - s.length) if s' == s then some r else none /-- `dropInfix? l i` returns `some (p, s)` if `l = p ++ i' ++ s` for some `i'` which is paiwise `==` to `i`, and `none` otherwise. Note that this is an inefficient implementation, and if computation time is a concern you should be using the Knuth-Morris-Pratt algorithm as implemented in `Batteries.Data.List.Matcher`. -/ def dropInfix? [BEq α] (l i : List α) : Option (List α × List α) := go l [] where /-- Inner loop for `dropInfix?`. -/ go : List α → List α → Option (List α × List α) | [], acc => if i.isEmpty then some (acc.reverse, []) else none | a :: as, acc => match (a :: as).dropPrefix? i with | none => go as (a :: acc) | some s => (acc.reverse, s) /-- Computes the product of the elements of a list. Examples: [a, b, c].prod = a * (b * (c * 1)) [2, 3, 5].prod = 30 -/ @[expose] def prod [Mul α] [One α] (xs : List α) : α := xs.foldr (· * ·) 1 /-- Computes the partial sums of the elements of a list. Examples: `[a, b, c].partialSums = [0, 0 + a, (0 + a) + b, ((0 + a) + b) + c]` `[1, 2, 3].partialSums = [0, 1, 3, 6]` -/ def partialSums [Add α] [Zero α] (l : List α) : List α := l.scanl (· + ·) 0 /-- Computes the partial products of the elements of a list. Examples: `[a, b, c].partialProds = [1, 1 * a, (1 * a) * b, ((1 * a) * b) * c]` `[2, 3, 5].partialProds = [1, 2, 6, 30]` -/ def partialProds [Mul α] [One α] (l : List α) : List α := l.scanl (· * ·) 1 ================================================ FILE: Batteries/Data/List/Count.lean ================================================ /- Copyright (c) 2014 Parikshit Khanna. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro -/ module public import Batteries.Data.List.Lemmas @[expose] public section /-! # Counting in lists This file proves basic properties of `List.countP` and `List.count`, which count the number of elements of a list satisfying a predicate and equal to a given element respectively. Their definitions can be found in `Batteries.Data.List.Basic`. -/ open Nat namespace List /-! ### count -/ section count theorem count_singleton' [DecidableEq α] (a b : α) : count a [b] = if b = a then 1 else 0 := count_singleton.trans (by grind) theorem count_concat [BEq α] [LawfulBEq α] (a : α) (l : List α) : count a (concat l a) = count a l + 1 := by simp /-! ### idxToSigmaCount, sigmaCountToIdx -/ /-- `idxToSigmaCount` is essentially a `Fin`-to-`Fin` wrapper for `countBefore` that also includes the corresponding element. For example: ``` idxToSigmaCount [5, 1, 3, 2, 4, 0, 1, 4] 5 = ⟨0, 0⟩ ``` -/ def idxToSigmaCount [BEq α] [ReflBEq α] (xs : List α) (i : Fin xs.length) : (x : α) × Fin (xs.count x) := ⟨xs[i.1], xs.countBefore xs[i.1] i, by grind⟩ @[simp, grind =] theorem fst_idxToSigmaCount [BEq α] [ReflBEq α] {xs: List α} {i : Fin xs.length} : (xs.idxToSigmaCount i).1 = xs[i.1] := rfl @[simp, grind =] theorem snd_idxToSigmaCount [BEq α] [ReflBEq α] {xs: List α} {i : Fin xs.length} : (xs.idxToSigmaCount i).2 = ⟨xs.countBefore xs[i.1] i, by grind⟩ := rfl @[simp, grind =] theorem coe_snd_idxToSigmaCount [BEq α] [ReflBEq α] {xs: List α} {i : Fin xs.length} : ((xs.idxToSigmaCount i).2 : Nat) = xs.countBefore xs[i.1] i := rfl /-- `sigmaCountToIdx` is a `_ × Fin`-to-`Fin` wrapper for `countBefore`. For example: ``` sigmaCountToIdx [5, 1, 3, 2, 4, 0, 1, 4] ⟨0, 0⟩ = 5 ``` -/ def sigmaCountToIdx [BEq α] (xs : List α) (xc : (x : α) × Fin (xs.count x)) : Fin xs.length := ⟨xs.idxOfNth xc.1 xc.2, by grind⟩ @[simp, grind =] theorem coe_sigmaCountToIdx [BEq α] {xs: List α} {xc : (x : α) × Fin (xs.count x)} : (xs.sigmaCountToIdx xc : Nat) = xs.idxOfNth xc.1 xc.2 := rfl @[simp, grind =] theorem sigmaCountToIdx_idxToSigmaCount [BEq α] [ReflBEq α] {xs : List α} {i : Fin xs.length} : xs.sigmaCountToIdx (xs.idxToSigmaCount i) = i := by grind theorem leftInverse_sigmaCountToIdx_idxToSigmaCount [BEq α] [ReflBEq α] {xs : List α} : xs.sigmaCountToIdx.LeftInverse xs.idxToSigmaCount := by grind theorem rightInverse_idxToSigmaCount_sigmaCountToIdx [BEq α] [ReflBEq α] {xs : List α} : xs.idxToSigmaCount.RightInverse xs.sigmaCountToIdx := by grind theorem injective_idxToSigmaCount [BEq α] [ReflBEq α] {xs : List α} : xs.idxToSigmaCount.Injective := leftInverse_sigmaCountToIdx_idxToSigmaCount.injective theorem surjective_sigmaCountToIdx [BEq α] [ReflBEq α] {xs : List α} : xs.sigmaCountToIdx.Surjective := rightInverse_idxToSigmaCount_sigmaCountToIdx.surjective @[simp, grind =] theorem idxToSigmaCount_sigmaCountToIdx [BEq α] [LawfulBEq α] {xs : List α} {xc : (x : α) × Fin (xs.count x)} : xs.idxToSigmaCount (xs.sigmaCountToIdx xc) = xc := Sigma.ext getElem_idxOfNth_eq (heq_of_eqRec_eq (by grind) (by grind)) theorem leftInverse_idxToSigmaCount_sigmaCountToIdx [BEq α] [LawfulBEq α] {xs : List α} : xs.idxToSigmaCount.LeftInverse xs.sigmaCountToIdx := by grind theorem rightInverse_sigmaCountToIdx_idxToSigmaCount [BEq α] [LawfulBEq α] {xs : List α} : xs.sigmaCountToIdx.RightInverse xs.idxToSigmaCount := by grind theorem injective_sigmaCountToIdx [BEq α] [LawfulBEq α] {xs : List α} : xs.sigmaCountToIdx.Injective := leftInverse_idxToSigmaCount_sigmaCountToIdx.injective theorem surjective_idxToSigmaCount [BEq α] [LawfulBEq α] {xs : List α} : xs.idxToSigmaCount.Surjective := rightInverse_sigmaCountToIdx_idxToSigmaCount.surjective ================================================ FILE: Batteries/Data/List/Init/Lemmas.lean ================================================ /- Copyright (c) 2024 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module @[expose] public section /-! While this file is currently empty, it is intended as a home for any lemmas which are required for definitions in `Batteries.Data.List.Basic`, but which are not provided by Lean. -/ ================================================ FILE: Batteries/Data/List/Lemmas.lean ================================================ /- Copyright (c) 2014 Parikshit Khanna. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro -/ module public import Batteries.Control.ForInStep.Lemmas public import Batteries.Data.List.Basic @[expose] public section namespace List instance instNeZeroNatLengthCons {a : α} {l : List α} : NeZero (a :: l).length := ⟨Nat.succ_ne_zero _⟩ /-! ### count -/ theorem count_getElem_take_succ [BEq α] [EquivBEq α] {xs : List α} {i : Nat} {hi} : (xs.take (i + 1)).count xs[i] = (xs.take i).count xs[i] + 1 := by grind [take_append_getElem] theorem count_getElem_take_lt_count [BEq α] [EquivBEq α] {xs : List α} {i : Nat} {hi} : (xs.take i).count (xs[i]'hi) < xs.count xs[i] := Nat.lt_of_succ_le (Nat.le_trans (Nat.le_of_eq count_getElem_take_succ.symm) <| (take_sublist _ _).count_le _) /-! ### zip -/ attribute [grind =] zip_nil_left zip_nil_right zip_cons_cons /-! ### zipIdx -/ attribute [grind =] zipIdx_nil zipIdx_cons /-! ### toArray-/ @[deprecated List.getElem_toArray (since := "2025-09-11")] theorem getElem_mk {xs : List α} {i : Nat} (h : i < xs.length) : (Array.mk xs)[i] = xs[i] := List.getElem_toArray h /-! ### next? -/ @[simp, grind =] theorem next?_nil : @next? α [] = none := rfl @[simp, grind =] theorem next?_cons (a l) : @next? α (a :: l) = some (a, l) := rfl /-! ### dropLast -/ theorem dropLast_eq_eraseIdx {xs : List α} {i : Nat} (last_idx : i + 1 = xs.length) : xs.dropLast = List.eraseIdx xs i := by ext grind /-! ### set -/ theorem set_eq_modify (a : α) : ∀ n (l : List α), l.set n a = l.modify n (fun _ => a) | 0, l => by cases l <;> rfl | _+1, [] => rfl | _+1, _ :: _ => congrArg (cons _) (set_eq_modify _ _ _) theorem set_eq_take_cons_drop (a : α) {n l} (h : n < length l) : set l n a = take n l ++ a :: drop (n + 1) l := by rw [set_eq_modify, modify_eq_take_cons_drop h] theorem modify_eq_set_getElem? (f : α → α) : ∀ n (l : List α), l.modify n f = ((fun a => l.set n (f a)) <$> l[n]?).getD l | 0, l => by cases l <;> simp | _+1, [] => rfl | n+1, b :: l => (congrArg (cons _) (modify_eq_set_getElem? ..)).trans <| by cases h : l[n]? <;> simp [h] @[deprecated (since := "2025-02-15")] alias modify_eq_set_get? := modify_eq_set_getElem? theorem modify_eq_set_get (f : α → α) {n} {l : List α} (h) : l.modify n f = l.set n (f (l.get ⟨n, h⟩)) := by rw [modify_eq_set_getElem?, getElem?_eq_getElem h]; rfl theorem getElem?_set_eq_of_lt (a : α) {n} {l : List α} (h : n < length l) : (set l n a)[n]? = some a := by rw [getElem?_set_self', getElem?_eq_getElem h]; rfl theorem getElem?_set_of_lt (a : α) {m n} (l : List α) (h : n < length l) : (set l m a)[n]? = if m = n then some a else l[n]? := by simp [getElem?_set', getElem?_eq_getElem h] @[deprecated (since := "2025-02-15")] alias get?_set_of_lt := getElem?_set_of_lt theorem getElem?_set_of_lt' (a : α) {m n} (l : List α) (h : m < length l) : (set l m a)[n]? = if m = n then some a else l[n]? := by simp [getElem?_set]; split <;> subst_vars <;> simp [*] @[deprecated (since := "2025-02-15")] alias get?_set_of_lt' := getElem?_set_of_lt' /-! ### tail -/ theorem length_tail_add_one (l : List α) (h : 0 < length l) : (length (tail l)) + 1 = length l := by grind /-! ### eraseP -/ @[simp] theorem extractP_eq_find?_eraseP (l : List α) : extractP p l = (find? p l, eraseP p l) := by suffices ∀ (acc) (xs) (h : l = acc.toList ++ xs), extractP.go p l xs acc = (xs.find? p, acc.toList ++ xs.eraseP p) from this #[] _ rfl intros fun_induction extractP.go with grind /-! ### erase -/ theorem erase_eq_self_iff_forall_bne [BEq α] (a : α) (xs : List α) : xs.erase a = xs ↔ ∀ (x : α), x ∈ xs → ¬x == a := by rw [erase_eq_eraseP', eraseP_eq_self_iff] /-! ### findIdx? -/ @[deprecated findIdx_eq_getD_findIdx? (since := "2025-11-06")] theorem findIdx_eq_findIdx? (p : α → Bool) (l : List α) : l.findIdx p = (match l.findIdx? p with | some i => i | none => l.length) := by rw [findIdx_eq_getD_findIdx?] cases findIdx? p l <;> rfl /-! ### replaceF -/ theorem replaceF_nil : [].replaceF p = [] := rfl theorem replaceF_cons (a : α) (l : List α) : (a :: l).replaceF p = match p a with | none => a :: replaceF p l | some a' => a' :: l := rfl theorem replaceF_cons_of_some {l : List α} (p) (h : p a = some a') : (a :: l).replaceF p = a' :: l := by simp [h] theorem replaceF_cons_of_none {l : List α} (p) (h : p a = none) : (a :: l).replaceF p = a :: l.replaceF p := by simp [h] theorem replaceF_of_forall_none {l : List α} (h : ∀ a, a ∈ l → p a = none) : l.replaceF p = l := by induction l with | nil => rfl | cons _ _ ih => simp [h _ (.head ..), ih (forall_mem_cons.1 h).2] theorem exists_of_replaceF : ∀ {l : List α} {a a'} (_ : a ∈ l) (_ : p a = some a'), ∃ a a' l₁ l₂, (∀ b ∈ l₁, p b = none) ∧ p a = some a' ∧ l = l₁ ++ a :: l₂ ∧ l.replaceF p = l₁ ++ a' :: l₂ | b :: l, _, _, al, pa => match pb : p b with | some b' => ⟨b, b', [], l, forall_mem_nil _, pb, by simp [pb]⟩ | none => match al with | .head .. => nomatch pb.symm.trans pa | .tail _ al => let ⟨c, c', l₁, l₂, h₁, h₂, h₃, h₄⟩ := exists_of_replaceF al pa ⟨c, c', b::l₁, l₂, (forall_mem_cons ..).2 ⟨pb, h₁⟩, h₂, by rw [h₃, cons_append], by simp [pb, h₄]⟩ theorem exists_or_eq_self_of_replaceF (p) (l : List α) : l.replaceF p = l ∨ ∃ a a' l₁ l₂, (∀ b ∈ l₁, p b = none) ∧ p a = some a' ∧ l = l₁ ++ a :: l₂ ∧ l.replaceF p = l₁ ++ a' :: l₂ := if h : ∃ a ∈ l, (p a).isSome then let ⟨_, ha, pa⟩ := h .inr (exists_of_replaceF ha (Option.get_mem pa)) else .inl <| replaceF_of_forall_none fun a ha => Option.not_isSome_iff_eq_none.1 fun h' => h ⟨a, ha, h'⟩ @[simp] theorem length_replaceF : length (replaceF f l) = length l := by induction l <;> simp [replaceF]; split <;> simp [*] /-! ### disjoint -/ theorem disjoint_symm (d : Disjoint l₁ l₂) : Disjoint l₂ l₁ := fun _ i₂ i₁ => d i₁ i₂ theorem disjoint_comm : Disjoint l₁ l₂ ↔ Disjoint l₂ l₁ := ⟨disjoint_symm, disjoint_symm⟩ theorem disjoint_left : Disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₁ → a ∉ l₂ := by simp [Disjoint] theorem disjoint_right : Disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₂ → a ∉ l₁ := disjoint_comm theorem disjoint_iff_ne : Disjoint l₁ l₂ ↔ ∀ a ∈ l₁, ∀ b ∈ l₂, a ≠ b := ⟨fun h _ al1 _ bl2 ab => h al1 (ab ▸ bl2), fun h _ al1 al2 => h _ al1 _ al2 rfl⟩ theorem disjoint_of_subset_left (ss : l₁ ⊆ l) (d : Disjoint l l₂) : Disjoint l₁ l₂ := fun _ m => d (ss m) theorem disjoint_of_subset_right (ss : l₂ ⊆ l) (d : Disjoint l₁ l) : Disjoint l₁ l₂ := fun _ m m₁ => d m (ss m₁) theorem disjoint_of_disjoint_cons_left {l₁ l₂} : Disjoint (a :: l₁) l₂ → Disjoint l₁ l₂ := disjoint_of_subset_left (subset_cons_self _ _) theorem disjoint_of_disjoint_cons_right {l₁ l₂} : Disjoint l₁ (a :: l₂) → Disjoint l₁ l₂ := disjoint_of_subset_right (subset_cons_self _ _) @[simp] theorem disjoint_nil_left (l : List α) : Disjoint [] l := fun _ => not_mem_nil.elim @[simp] theorem disjoint_nil_right (l : List α) : Disjoint l [] := by rw [disjoint_comm]; exact disjoint_nil_left _ @[simp 1100] theorem singleton_disjoint : Disjoint [a] l ↔ a ∉ l := by simp [Disjoint] @[simp 1100] theorem disjoint_singleton : Disjoint l [a] ↔ a ∉ l := by rw [disjoint_comm, singleton_disjoint] @[simp] theorem disjoint_append_left : Disjoint (l₁ ++ l₂) l ↔ Disjoint l₁ l ∧ Disjoint l₂ l := by simp [Disjoint, or_imp, forall_and] @[simp] theorem disjoint_append_right : Disjoint l (l₁ ++ l₂) ↔ Disjoint l l₁ ∧ Disjoint l l₂ := disjoint_comm.trans <| by rw [disjoint_append_left]; simp [disjoint_comm] @[simp] theorem disjoint_cons_left : Disjoint (a::l₁) l₂ ↔ (a ∉ l₂) ∧ Disjoint l₁ l₂ := (disjoint_append_left (l₁ := [a])).trans <| by simp [singleton_disjoint] @[simp] theorem disjoint_cons_right : Disjoint l₁ (a :: l₂) ↔ (a ∉ l₁) ∧ Disjoint l₁ l₂ := disjoint_comm.trans <| by rw [disjoint_cons_left]; simp [disjoint_comm] theorem disjoint_of_disjoint_append_left_left (d : Disjoint (l₁ ++ l₂) l) : Disjoint l₁ l := (disjoint_append_left.1 d).1 theorem disjoint_of_disjoint_append_left_right (d : Disjoint (l₁ ++ l₂) l) : Disjoint l₂ l := (disjoint_append_left.1 d).2 theorem disjoint_of_disjoint_append_right_left (d : Disjoint l (l₁ ++ l₂)) : Disjoint l l₁ := (disjoint_append_right.1 d).1 theorem disjoint_of_disjoint_append_right_right (d : Disjoint l (l₁ ++ l₂)) : Disjoint l l₂ := (disjoint_append_right.1 d).2 /-! ### union -/ section union variable [BEq α] theorem union_def (l₁ l₂ : List α) : l₁ ∪ l₂ = foldr .insert l₂ l₁ := rfl @[simp, grind =] theorem nil_union (l : List α) : nil ∪ l = l := by simp [List.union_def, foldr] @[simp, grind =] theorem cons_union (a : α) (l₁ l₂ : List α) : (a :: l₁) ∪ l₂ = (l₁ ∪ l₂).insert a := by simp [List.union_def, foldr] @[simp, grind =] theorem mem_union_iff [LawfulBEq α] {x : α} {l₁ l₂ : List α} : x ∈ l₁ ∪ l₂ ↔ x ∈ l₁ ∨ x ∈ l₂ := by induction l₁ <;> simp [*, or_assoc] end union /-! ### inter -/ theorem inter_def [BEq α] (l₁ l₂ : List α) : l₁ ∩ l₂ = filter (elem · l₂) l₁ := rfl @[simp, grind =] theorem mem_inter_iff [BEq α] [LawfulBEq α] {x : α} {l₁ l₂ : List α} : x ∈ l₁ ∩ l₂ ↔ x ∈ l₁ ∧ x ∈ l₂ := by cases l₁ <;> simp [List.inter_def, mem_filter] /-! ### product -/ /-- List.prod satisfies a specification of cartesian product on lists. -/ @[simp] theorem pair_mem_product {xs : List α} {ys : List β} {x : α} {y : β} : (x, y) ∈ product xs ys ↔ x ∈ xs ∧ y ∈ ys := by simp only [product, mem_map, Prod.mk.injEq, exists_eq_right_right, mem_flatMap, iff_self] /-! ### monadic operations -/ theorem forIn_eq_bindList [Monad m] [LawfulMonad m] (f : α → β → m (ForInStep β)) (l : List α) (init : β) : forIn l init f = ForInStep.run <$> (ForInStep.yield init).bindList f l := by induction l generalizing init <;> simp [*] congr; ext (b | b) <;> simp /-! ### diff -/ section Diff variable [BEq α] @[simp] theorem diff_nil (l : List α) : l.diff [] = l := rfl variable [LawfulBEq α] @[simp] theorem diff_cons (l₁ l₂ : List α) (a : α) : l₁.diff (a :: l₂) = (l₁.erase a).diff l₂ := by simp_all [List.diff, erase_of_not_mem] theorem diff_cons_right (l₁ l₂ : List α) (a : α) : l₁.diff (a :: l₂) = (l₁.diff l₂).erase a := by apply Eq.symm; induction l₂ generalizing l₁ <;> simp [erase_comm, *] theorem diff_erase (l₁ l₂ : List α) (a : α) : (l₁.diff l₂).erase a = (l₁.erase a).diff l₂ := by rw [← diff_cons_right, diff_cons] @[simp] theorem nil_diff (l : List α) : [].diff l = [] := by induction l <;> simp [*, erase_of_not_mem] theorem cons_diff (a : α) (l₁ l₂ : List α) : (a :: l₁).diff l₂ = if a ∈ l₂ then l₁.diff (l₂.erase a) else a :: l₁.diff l₂ := by induction l₂ generalizing l₁ with | nil => rfl | cons b l₂ ih => by_cases h : a = b next => simp [*] next => have := Ne.symm h simp[*] theorem cons_diff_of_mem {a : α} {l₂ : List α} (h : a ∈ l₂) (l₁ : List α) : (a :: l₁).diff l₂ = l₁.diff (l₂.erase a) := by rw [cons_diff, if_pos h] theorem cons_diff_of_not_mem {a : α} {l₂ : List α} (h : a ∉ l₂) (l₁ : List α) : (a :: l₁).diff l₂ = a :: l₁.diff l₂ := by rw [cons_diff, if_neg h] theorem diff_eq_foldl : ∀ l₁ l₂ : List α, l₁.diff l₂ = foldl List.erase l₁ l₂ | _, [] => rfl | l₁, a :: l₂ => (diff_cons l₁ l₂ a).trans (diff_eq_foldl _ _) @[simp] theorem diff_append (l₁ l₂ l₃ : List α) : l₁.diff (l₂ ++ l₃) = (l₁.diff l₂).diff l₃ := by simp only [diff_eq_foldl, foldl_append] theorem diff_sublist : ∀ l₁ l₂ : List α, l₁.diff l₂ <+ l₁ | _, [] => .refl _ | l₁, a :: l₂ => calc l₁.diff (a :: l₂) = (l₁.erase a).diff l₂ := diff_cons .. _ <+ l₁.erase a := diff_sublist .. _ <+ l₁ := erase_sublist .. theorem diff_subset (l₁ l₂ : List α) : l₁.diff l₂ ⊆ l₁ := (diff_sublist ..).subset theorem mem_diff_of_mem {a : α} : ∀ {l₁ l₂ : List α}, a ∈ l₁ → a ∉ l₂ → a ∈ l₁.diff l₂ | _, [], h₁, _ => h₁ | l₁, b :: l₂, h₁, h₂ => by rw [diff_cons] exact mem_diff_of_mem ((mem_erase_of_ne <| ne_of_not_mem_cons h₂).2 h₁) (mt (.tail _) h₂) theorem Sublist.diff_right : ∀ {l₁ l₂ l₃ : List α}, l₁ <+ l₂ → l₁.diff l₃ <+ l₂.diff l₃ | _, _, [], h => h | l₁, l₂, a :: l₃, h => by simp only [diff_cons, (h.erase _).diff_right] theorem Sublist.erase_diff_erase_sublist {a : α} : ∀ {l₁ l₂ : List α}, l₁ <+ l₂ → (l₂.erase a).diff (l₁.erase a) <+ l₂.diff l₁ | [], _, _ => erase_sublist | b :: l₁, l₂, h => by if heq : b = a then simp [heq] else simp [heq, erase_comm a] exact (erase_cons_head b _ ▸ h.erase b).erase_diff_erase_sublist end Diff /-! ### drop -/ theorem disjoint_take_drop : ∀ {l : List α}, l.Nodup → m ≤ n → Disjoint (l.take m) (l.drop n) | [], _, _ => by simp | x :: xs, hl, h => by cases m <;> cases n <;> simp only [disjoint_cons_left, drop, disjoint_nil_left, take] · case succ.zero => cases h · cases hl with | cons h₀ h₁ => refine ⟨fun h => h₀ _ (mem_of_mem_drop h) rfl, ?_⟩ exact disjoint_take_drop h₁ (Nat.le_of_succ_le_succ h) /-! ### Pairwise -/ attribute [simp, grind ←] Pairwise.nil @[grind =] theorem pairwise_cons_cons : Pairwise R (a :: b :: l) ↔ R a b ∧ Pairwise R (a :: l) ∧ Pairwise R (b :: l) := by grind [pairwise_cons] @[grind →] protected theorem Pairwise.isChain (p : Pairwise R l) : IsChain R l := by induction p <;> grind [cases List] /-! ### IsChain -/ @[deprecated (since := "2025-09-19")] alias chain_cons := isChain_cons_cons theorem rel_of_isChain_cons_cons (p : IsChain R (a :: b :: l)) : R a b := (isChain_cons_cons.1 p).1 alias IsChain.rel := rel_of_isChain_cons_cons @[deprecated (since := "2025-09-19")] alias rel_of_chain_cons := rel_of_isChain_cons_cons theorem isChain_of_isChain_cons (p : IsChain R (b :: l)) : IsChain R l := by grind [cases List] alias IsChain.of_cons := isChain_of_isChain_cons @[deprecated IsChain.of_cons (since := "2026-02-10")] theorem isChain_cons_of_isChain_cons_cons : IsChain R (a :: b :: l) → IsChain R (b :: l) := IsChain.of_cons @[deprecated (since := "2025-09-19")] alias chain_of_chain_cons := isChain_cons_of_isChain_cons_cons @[deprecated IsChain.of_cons (since := "2026-02-10")] theorem isChain_of_isChain_cons_cons : IsChain R (a :: b :: l) → IsChain R l := IsChain.of_cons ∘ IsChain.of_cons @[grind =>] theorem IsChain.imp (H : ∀ ⦃a b : α⦄, R a b → S a b) (p : IsChain R l) : IsChain S l := by induction p with grind @[deprecated (since := "2025-09-19")] alias Chain.imp := IsChain.imp theorem IsChain.cons_of_imp (h : ∀ c, R a c → R b c) : IsChain R (a :: l) → IsChain R (b :: l) := by grind [cases List] @[deprecated (since := "2026-02-10")] alias IsChain.cons_of_imp_of_cons := IsChain.cons_of_imp theorem IsChain.cons_of_imp_of_imp (HRS : ∀ ⦃a b : α⦄, R a b → S a b) (Hab : ∀ ⦃c⦄, R a c → S b c) (h : IsChain R (a :: l)) : IsChain S (b :: l) := by grind [cases List] @[deprecated (since := "2025-09-19")] alias Chain.imp' := IsChain.cons_of_imp_of_imp @[deprecated (since := "2025-09-19")] protected alias Pairwise.chain := Pairwise.isChain theorem isChain_iff_pairwise [Trans R R R] : IsChain R l ↔ Pairwise R l := by induction l with | nil => grind | cons a l IH => cases l with | nil => grind | cons b l => simp only [isChain_cons_cons, IH, pairwise_cons, mem_cons, forall_eq_or_imp, and_congr_left_iff, iff_self_and, and_imp] exact flip <| fun _ => flip (Trans.trans · <| · · ·) @[grind →] protected theorem IsChain.pairwise [Trans R R R] (c : IsChain R l) : Pairwise R l := isChain_iff_pairwise.mp c theorem isChain_iff_getElem {l : List α} : IsChain R l ↔ ∀ (i : Nat) (_hi : i + 1 < l.length), R l[i] l[i + 1] := by induction l with | nil => grind | cons a l IH => cases l with | nil => grind | cons b l => simp [IH, Nat.forall_lt_succ_left'] theorem IsChain.getElem {l : List α} (c : IsChain R l) (i : Nat) (hi : i + 1 < l.length) : R l[i] l[i + 1] := isChain_iff_getElem.mp c _ _ /-! ### range', range -/ theorem isChain_range' (s : Nat) : ∀ n step : Nat, IsChain (fun a b => b = a + step) (range' s n step) | 0, _ => .nil | 1, _ => .singleton _ | n + 2, step => (isChain_range' (s + step) (n + 1) step).cons_cons rfl @[deprecated isChain_range' (since := "2025-09-19")] theorem chain_succ_range' (s n step : Nat) : IsChain (fun a b => b = a + step) (s :: range' (s + step) n step) := isChain_range' _ (n + 1) _ theorem isChain_lt_range' (s n : Nat) (h : 0 < step) : IsChain (· < ·) (range' s n step) := (isChain_range' s n step).imp fun | _, _, rfl => Nat.lt_add_of_pos_right h @[deprecated isChain_lt_range' (since := "2025-09-19")] theorem chain_lt_range' (s n : Nat) (h : 0 < step) : IsChain (· < ·) (s :: range' (s + step) n step) := isChain_lt_range' _ (n + 1) h /-! ### foldrIdx -/ @[simp, grind =] theorem foldrIdx_nil : ([] : List α).foldrIdx f i s = i := rfl @[simp, grind =] theorem foldrIdx_cons : (x :: xs : List α).foldrIdx f i s = f s x (foldrIdx f i xs (s + 1)) := rfl @[grind =] theorem foldrIdx_start : (xs : List α).foldrIdx f i s = (xs : List α).foldrIdx (f <| · + s) i := by induction xs generalizing f s <;> grind theorem foldrIdx_const : (xs : List α).foldrIdx (Function.const Nat f) i s = xs.foldr f i := by induction xs <;> grind theorem foldrIdx_eq_foldr_zipIdx : (xs : List α).foldrIdx f i s = (xs.zipIdx s).foldr (fun ab => f ab.2 ab.1) i := by induction xs generalizing s <;> grind /-! ### foldlIdx -/ @[simp, grind =] theorem foldlIdx_nil : ([] : List α).foldlIdx f i s = i := rfl @[simp, grind =] theorem foldlIdx_cons : (x :: xs : List α).foldlIdx f i s = foldlIdx f (f s i x) xs (s + 1) := rfl theorem foldlIdx_start : (xs : List α).foldlIdx f i s = (xs : List α).foldlIdx (f <| · + s) i := by induction xs generalizing f i s <;> grind [Function.comp_def] theorem foldlIdx_const : (xs : List α).foldlIdx (Function.const Nat f) i s = xs.foldl f i := by induction xs generalizing i s <;> grind theorem foldlIdx_eq_foldl_zipIdx : (xs : List α).foldlIdx f i s = (xs.zipIdx s).foldl (fun b ab => f ab.2 b ab.1) i := by induction xs generalizing i s <;> grind /-! ### findIdxs -/ @[simp, grind =] theorem findIdxs_nil : ([] : List α).findIdxs p s = [] := rfl @[simp, grind =] theorem findIdxs_cons : (x :: xs : List α).findIdxs p s = if p x then s :: xs.findIdxs p (s + 1) else xs.findIdxs p (s + 1) := by grind [findIdxs] theorem findIdxs_singleton : [x].findIdxs p s = if p x then [s] else [] := by grind theorem findIdxs_start : (xs : List α).findIdxs p s = (xs.findIdxs p).map (· + s) := by induction xs generalizing s <;> grind [map_inj_left] theorem findIdxs_eq_filterMap_zipIdx : (xs : List α).findIdxs p s = ((xs.zipIdx s).filterMap fun ab => bif p ab.1 then ab.2 else none) := by induction xs generalizing s <;> grind @[simp, grind =] theorem mem_findIdxs_iff_getElem_sub_pos : i ∈ (xs : List α).findIdxs p s ↔ s ≤ i ∧ ∃ (hix : i - s < xs.length), p xs[i - s] := by induction xs generalizing s <;> grind theorem mem_findIdxs_iff_exists_getElem_pos : i ∈ (xs : List α).findIdxs p ↔ ∃ (hix : i < xs.length), p xs[i] := by grind theorem mem_findIdxs_iff_pos_getElem (hi : i < (xs : List α).length) : i ∈ xs.findIdxs p ↔ p xs[i] := by grind theorem ge_of_mem_findIdxs : ∀ y ∈ (xs : List α).findIdxs p s, s ≤ y := by grind theorem lt_add_of_mem_findIdxs : ∀ y ∈ (xs : List α).findIdxs p s, y < xs.length + s := by grind theorem findIdxs_eq_nil_iff : (xs : List α).findIdxs p s = [] ↔ ∀ x ∈ xs, p x = false := by induction xs generalizing s <;> grind @[simp, grind =] theorem length_findIdxs : ((xs : List α).findIdxs p s).length = xs.countP p := by induction xs generalizing s <;> grind @[simp, grind .] theorem pairwise_findIdxs : ((xs : List α).findIdxs p s).Pairwise (· < ·) := by induction xs generalizing s <;> grind [pairwise_cons] @[simp, grind .] theorem isChain_findIdxs : ((xs : List α).findIdxs p s).IsChain (· < ·) := pairwise_findIdxs.isChain @[simp, grind .] theorem nodup_findIdxs : ((xs : List α).findIdxs p s).Nodup := pairwise_findIdxs.imp (by grind) @[simp, grind =] theorem findIdxs_map : ((xs : List α).map f).findIdxs p s = xs.findIdxs (p ∘ f) s := by induction xs generalizing s <;> grind @[simp, grind =] theorem findIdxs_append : ((xs : List α) ++ ys).findIdxs p s = xs.findIdxs p s ++ ys.findIdxs p (s + xs.length) := by induction xs generalizing s <;> grind @[simp, grind =] theorem findIdxs_take : ((xs : List α).take n).findIdxs p s = (xs.findIdxs p s).take ((xs.take n).countP p) := by induction xs generalizing n s <;> cases n <;> grind [countP_eq_length_filter] @[simp, grind =>] theorem le_getElem_findIdxs (h : i < ((xs : List α).findIdxs p s).length) : s ≤ (xs.findIdxs p s)[i] := by grind [getElem_mem] @[simp, grind =>] theorem getElem_findIdxs_lt (h : i < ((xs : List α).findIdxs p s).length) : (xs.findIdxs p s)[i] < xs.length + s := by grind [getElem_mem] theorem getElem_filter_eq_getElem_getElem_findIdxs_sub (s : Nat) (h : i < ((xs : List α).filter p).length) : (xs.filter p)[i] = xs[(xs.findIdxs p s)[i]'(by grind) - s]'(by grind) := by induction xs generalizing i s <;> grind @[grind =>] theorem getElem_filter_eq_getElem_getElem_findIdxs (h : i < ((xs : List α).filter p).length) : (xs.filter p)[i] = xs[(xs.findIdxs p)[i]'(by grind)]'(by grind) := getElem_filter_eq_getElem_getElem_findIdxs_sub 0 h theorem getElem_getElem_findIdxs_sub (s : Nat) (h : i < ((xs : List α).findIdxs p s).length) : haveI : (findIdxs p xs s)[i] - s < xs.length := by grind p xs[(xs.findIdxs p s)[i] - s] := by rw [← getElem_filter_eq_getElem_getElem_findIdxs_sub s] <;> grind theorem getElem_getElem_findIdxs (h : i < ((xs : List α).findIdxs p).length) : haveI : (findIdxs p xs)[i] < xs.length := by grind p xs[(xs.findIdxs p)[i]] := getElem_getElem_findIdxs_sub 0 h @[grind =] theorem getElem_zero_findIdxs_eq_findIdx_add (h : 0 < ((xs : List α).findIdxs p s).length) : (xs.findIdxs p s)[0] = xs.findIdx p + s := by induction xs generalizing s <;> grind @[simp] theorem getElem_zero_findIdxs_eq_findIdx (h : 0 < ((xs : List α).findIdxs p).length) : (xs.findIdxs p)[0] = xs.findIdx p := getElem_zero_findIdxs_eq_findIdx_add h @[grind =>] theorem findIdx_add_mem_findIdxs (s : Nat) (h : (xs : List α).findIdx p < xs.length) : xs.findIdx p + s ∈ xs.findIdxs p s := by grind [mem_iff_getElem] theorem findIdx_mem_findIdxs (h : (xs : List α).findIdx p < xs.length) : xs.findIdx p ∈ xs.findIdxs p := findIdx_add_mem_findIdxs 0 h /-! ### findIdxsValues -/ @[grind =] theorem findIdxsValues_eq_zip_filter_findIdxs : (xs : List α).findIdxsValues p s = (xs.findIdxs p s).zip (xs.filter p) := by induction xs generalizing s <;> grind [findIdxsValues] @[simp, grind =] theorem unzip_findIdxsValues : ((xs : List α).findIdxsValues p s).unzip = (xs.findIdxs p s, xs.filter p) := by grind [unzip_zip] /-! ### findIdxNth -/ @[simp, grind =] theorem findIdxNth_nil : ([] : List α).findIdxNth p n = 0 := rfl @[grind =] theorem findIdxNth_cons {a : α} : (a :: xs).findIdxNth p n = if n = 0 then if p a then 0 else xs.findIdxNth p 0 + 1 else if p a then xs.findIdxNth p (n - 1) + 1 else xs.findIdxNth p n + 1 := by have H : ∀ n s, findIdxNth.go (p : α → Bool) xs n s = (xs : List α).findIdxNth p n + s := by induction xs <;> grind [findIdxNth, findIdxNth.go, cases Nat] cases n <;> grind [findIdxNth, findIdxNth.go] @[simp] theorem findIdxNth_cons_zero {a : α} : (a :: xs).findIdxNth p 0 = if p a then 0 else xs.findIdxNth p 0 + 1 := by grind @[simp] theorem findIdxNth_cons_succ {a : α} : (a :: xs).findIdxNth p (n + 1) = if p a then xs.findIdxNth p n + 1 else xs.findIdxNth p (n + 1) + 1 := by grind theorem findIdxNth_cons_of_neg {a : α} (h : p a = false) : (a :: xs).findIdxNth p n = xs.findIdxNth p n + 1 := by grind theorem findIdxNth_cons_of_pos {a : α} (h : p a) : (a :: xs).findIdxNth p n = if n = 0 then 0 else xs.findIdxNth p (n - 1) + 1 := by grind theorem findIdxNth_cons_zero_of_pos {a : α} (h : p a) : (a :: xs).findIdxNth p 0 = 0 := by grind theorem findIdxNth_cons_succ_of_pos {a : α} (h : p a) : (a :: xs).findIdxNth p (n + 1) = xs.findIdxNth p n + 1 := by grind theorem getElem_findIdxs_eq_findIdxNth_add {xs : List α} {h : n < (xs.findIdxs p s).length} : (xs.findIdxs p s)[n] = xs.findIdxNth p n + s := by induction xs generalizing n s <;> grind @[grind =] theorem getElem_findIdxs_eq_findIdxNth {xs : List α} {h : n < (xs.findIdxs p).length} : (xs.findIdxs p)[n] = xs.findIdxNth p n := getElem_findIdxs_eq_findIdxNth_add theorem pos_findIdxNth_getElem {xs : List α} {h : xs.findIdxNth p n < xs.length} : p xs[xs.findIdxNth p n] := by induction xs generalizing n <;> grind grind_pattern pos_findIdxNth_getElem => xs[xs.findIdxNth p n] theorem findIdxNth_zero : (xs : List α).findIdxNth p 0 = xs.findIdx p := by induction xs <;> grind @[grind _=_] theorem findIdxNth_lt_length_iff {xs : List α} : xs.findIdxNth p n < xs.length ↔ n < xs.countP p := by induction xs generalizing n <;> grind @[grind _=_] theorem findIdxNth_eq_length_iff {xs : List α} : xs.findIdxNth p n = xs.length ↔ xs.countP p ≤ n := by induction xs generalizing n <;> grind @[simp, grind .] theorem findIdxNth_le_length {xs : List α} : xs.findIdxNth p n ≤ xs.length := (n.lt_or_ge (xs.countP p)).elim (by grind) (by grind) theorem findIdxNth_lt_length_of_lt_countP {xs : List α} (h : n < xs.countP p) : xs.findIdxNth p n < xs.length := by grind theorem findIdxNth_eq_length_of_ge_countP {xs : List α} : xs.countP p ≤ n → xs.findIdxNth p n = xs.length := by grind theorem findIdxNth_le_findIdxNth_iff {xs : List α} : xs.findIdxNth p n ≤ xs.findIdxNth p m ↔ countP p xs ≤ m ∨ n ≤ m := by induction xs generalizing n m with | nil => grind | cons a xs IH => cases h : p a <;> cases n <;> cases m <;> simp [h, IH] theorem findIdxNth_lt_findIdxNth_iff {xs : List α} : xs.findIdxNth p n < xs.findIdxNth p m ↔ n < xs.countP p ∧ n < m := by simp [← Nat.not_le, findIdxNth_le_findIdxNth_iff] theorem findIdxNth_eq_findIdxNth_iff {xs : List α} : xs.findIdxNth p n = xs.findIdxNth p m ↔ (xs.countP p ≤ m ∨ n ≤ m) ∧ (xs.countP p ≤ n ∨ m ≤ n) := by simp only [Nat.le_antisymm_iff, findIdxNth_le_findIdxNth_iff] theorem findIdxNth_lt_findIdxNth_iff_of_lt_countP {xs : List α} (hn : n < xs.countP p) : xs.findIdxNth p n < xs.findIdxNth p m ↔ n < m := by grind [findIdxNth_lt_findIdxNth_iff] theorem findIdxNth_mono {xs : List α} (hnm : n ≤ m): xs.findIdxNth p n ≤ xs.findIdxNth p m := by grind [Nat.le_iff_lt_or_eq, findIdxNth_lt_findIdxNth_iff, findIdxNth_eq_findIdxNth_iff] theorem findIdxNth_eq_findIdxNth_iff_of_left_lt_countP {xs : List α} (hn : n < xs.countP p) : xs.findIdxNth p n = xs.findIdxNth p m ↔ n = m := by grind [findIdxNth_eq_findIdxNth_iff] theorem findIdxNth_eq_findIdxNth_iff_of_right_lt_countP {xs : List α} (hm : m < xs.countP p) : xs.findIdxNth p n = xs.findIdxNth p m ↔ n = m := by grind [findIdxNth_eq_findIdxNth_iff] theorem findIdxNth_eq_findIdxNth_of_ge_countP_ge_countP {xs : List α} (hn : xs.countP p ≤ n) (hm : xs.countP p ≤ m) : xs.findIdxNth p n = xs.findIdxNth p m := by grind [findIdxNth_eq_findIdxNth_iff] /-! ### idxOf -/ @[simp] theorem eraseIdx_idxOf_eq_erase [BEq α] (a : α) (l : List α) : l.eraseIdx (l.idxOf a) = l.erase a := by induction l with grind @[grind =] theorem idxOf_eq_getD_idxOf? [BEq α] (a : α) (l : List α) : l.idxOf a = (l.idxOf? a).getD l.length := by simp [idxOf, idxOf?, findIdx_eq_getD_findIdx?] @[deprecated (since := "2025-11-06")] alias idxOf_eq_idxOf? := idxOf_eq_getD_idxOf? @[simp, grind =] theorem getElem_idxOf [BEq α] [LawfulBEq α] {x : α} {xs : List α} (h : idxOf x xs < xs.length) : xs[xs.idxOf x] = x := by induction xs <;> grind @[simp, grind =] theorem Nodup.idxOf_getElem [BEq α] [LawfulBEq α] {xs : List α} (H : Nodup xs) (i : Nat) (h : i < xs.length) : idxOf xs[i] xs = i := by induction xs generalizing i <;> grind /-! ### idxsOf -/ @[simp, grind =] theorem idxsOf_nil [BEq α] : ([] : List α).idxsOf x s = [] := rfl @[simp, grind =] theorem idxsOf_cons [BEq α] : (x :: xs : List α).idxsOf y s = if x == y then s :: xs.idxsOf y (s + 1) else xs.idxsOf y (s + 1) := findIdxs_cons theorem idxsOf_start [BEq α] : (xs : List α).idxsOf x s = (xs.idxsOf x).map (· + s) := findIdxs_start theorem idxsOf_eq_filterMap_zipIdx [BEq α] : (xs : List α).idxsOf x s = ((xs.zipIdx s).filterMap fun ab => bif ab.1 == x then ab.2 else none) := findIdxs_eq_filterMap_zipIdx @[simp, grind =] theorem mem_idxsOf_iff_getElem_sub_pos [BEq α] : i ∈ (xs : List α).idxsOf x s ↔ s ≤ i ∧ ∃ (hix : i - s < xs.length), xs[i - s] == x := mem_findIdxs_iff_getElem_sub_pos theorem mem_idxsOf_iff_exists_getElem_pos [BEq α] : i ∈ (xs : List α).idxsOf x ↔ ∃ (hix : i < xs.length), xs[i] == x := by grind theorem mem_idxsOf_iff_getElem_pos [BEq α] (hi : i < (xs : List α).length) : i ∈ xs.idxsOf x ↔ xs[i] == x := by grind theorem ge_of_mem_idxsOf [BEq α] : ∀ y ∈ (xs : List α).idxsOf x s, s ≤ y := by grind theorem lt_add_of_mem_idxsOf [BEq α] : ∀ y ∈ (xs : List α).idxsOf x s, y < xs.length + s := by grind theorem idxsOf_eq_nil_iff [BEq α] : (xs : List α).idxsOf x s = [] ↔ ∀ y ∈ xs, (y == x) = false := findIdxs_eq_nil_iff @[simp, grind =] theorem length_idxsOf [BEq α] : ((xs : List α).idxsOf x s).length = xs.count x := length_findIdxs @[simp, grind .] theorem pairwise_idxsOf [BEq α] : ((xs : List α).idxsOf x s).Pairwise (· < ·) := pairwise_findIdxs @[simp, grind .] theorem isChain_idxsOf [BEq α] : ((xs : List α).idxsOf x s).IsChain (· < ·) := pairwise_idxsOf.isChain @[simp, grind .] theorem nodup_idxsOf [BEq α] : ((xs : List α).idxsOf x s).Nodup := pairwise_idxsOf.imp (by grind) @[simp, grind =] theorem idxsOf_map [BEq α] {f : β → α} : ((xs : List β).map f).idxsOf x s = xs.findIdxs (f · == x) s := findIdxs_map @[simp, grind =] theorem idxsOf_append [BEq α] : ((xs : List α) ++ ys).idxsOf x s = xs.idxsOf x s ++ ys.idxsOf x (s + xs.length) := findIdxs_append @[simp, grind =] theorem idxsOf_take [BEq α] : ((xs : List α).take n).idxsOf x s = (xs.idxsOf x s).take ((xs.take n).count x) := findIdxs_take @[simp, grind =>] theorem le_getElem_idxsOf [BEq α] (h : i < ((xs : List α).idxsOf x s).length) : s ≤ (xs.idxsOf x s)[i] := by grind [getElem_mem] @[simp, grind =>] theorem getElem_idxsOf_lt [BEq α] (h : i < ((xs : List α).idxsOf x s).length) : (xs.idxsOf x s)[i] < xs.length + s := by grind [getElem_mem] @[grind =>] theorem getElem_getElem_idxsOf_sub [BEq α] (s : Nat) (h : i < ((xs : List α).idxsOf x s).length) : haveI : (idxsOf x xs s)[i] - s < xs.length := by grind xs[(xs.idxsOf x s)[i] - s] == x := getElem_getElem_findIdxs_sub s h @[simp] theorem getElem_getElem_idxsOf_sub_of_lawful [BEq α] [LawfulBEq α] (s : Nat) (h : i < ((xs : List α).idxsOf x s).length) : haveI : (idxsOf x xs s)[i] - s < xs.length := by grind xs[(xs.idxsOf x s)[i] - s] = x := by grind [getElem_getElem_idxsOf_sub] theorem getElem_getElem_idxsOf [BEq α] (h : i < ((xs : List α).idxsOf x).length) : haveI : (idxsOf x xs)[i] < xs.length := by grind xs[(xs.idxsOf x)[i]] == x := by grind @[simp] theorem getElem_getElem_idxsOf_of_lawful [BEq α] [LawfulBEq α] (h : i < ((xs : List α).idxsOf x).length) : haveI : (idxsOf x xs)[i] < xs.length := by grind xs[(xs.idxsOf x)[i]] = x := by grind @[grind =>] theorem mem_idxsOf_getElem [BEq α] [EquivBEq α] (h : i < (xs : List α).length) : i ∈ xs.idxsOf xs[i] := by grind @[grind =] theorem getElem_zero_idxsOf_eq_idxOf_add [BEq α] (h : 0 < ((xs : List α).idxsOf x s).length) : (xs.idxsOf x s)[0] = xs.idxOf x + s := getElem_zero_findIdxs_eq_findIdx_add h @[simp] theorem getElem_zero_idxsOf_eq_idxOf [BEq α] (h : 0 < ((xs : List α).idxsOf x).length) : (xs.idxsOf x)[0] = xs.idxOf x := getElem_zero_idxsOf_eq_idxOf_add h @[grind =>] theorem idxOf_add_mem_idxsOf [BEq α] (s : Nat) (h : (xs : List α).idxOf x < xs.length) : xs.idxOf x + s ∈ xs.idxsOf x s := findIdx_add_mem_findIdxs s h theorem idxOf_mem_idxsOf [BEq α] (h : (xs : List α).idxOf x < xs.length) : xs.idxOf x ∈ xs.idxsOf x := idxOf_add_mem_idxsOf 0 h /-! ### idxOfNth -/ @[simp, grind =] theorem idxOfNth_nil [BEq α] : ([] : List α).idxOfNth x n = 0 := rfl @[grind =] theorem idxOfNth_cons [BEq α] {a : α} : (a :: xs).idxOfNth x n = if n = 0 then if a == x then 0 else xs.idxOfNth x 0 + 1 else if a == x then xs.idxOfNth x (n - 1) + 1 else xs.idxOfNth x n + 1 := findIdxNth_cons @[simp] theorem idxOfNth_cons_zero [BEq α] {a : α} : (a :: xs).idxOfNth x 0 = if a == x then 0 else xs.idxOfNth x 0 + 1 := by grind @[simp] theorem idxOfNth_cons_succ [BEq α] {a : α} : (a :: xs).idxOfNth x (n + 1) = if a == x then xs.idxOfNth x n + 1 else xs.idxOfNth x (n + 1) + 1 := by grind theorem idxOfNth_cons_of_not_beq {a : α} [BEq α] (h : (a == x) = false) : (a :: xs).idxOfNth x n = xs.idxOfNth x n + 1 := by grind theorem idxOfNth_cons_of_beq {a : α} [BEq α] (h : a == x) : (a :: xs).idxOfNth x n = if n = 0 then 0 else xs.idxOfNth x (n - 1) + 1 := by grind theorem idxOfNth_cons_zero_of_beq {a : α} [BEq α] (h : a == x) : (a :: xs).idxOfNth x 0 = 0 := by grind theorem idxOfNth_cons_succ_of_beq {a : α} [BEq α] (h : a == x) : (a :: xs).idxOfNth x (n + 1) = xs.idxOfNth x n + 1 := by grind theorem getElem_idxOf_eq_idxOfNth_add {xs : List α} [BEq α] {h : n < (xs.idxsOf x s).length} : (xs.idxsOf x s)[n] = xs.idxOfNth x n + s := by induction xs generalizing n s <;> grind @[grind =] theorem getElem_idxOf_eq_idxOfNth {xs : List α} [BEq α] {h : n < (xs.idxsOf x).length} : (xs.idxsOf x)[n] = xs.idxOfNth x n := getElem_idxOf_eq_idxOfNth_add theorem getElem_idxOfNth_beq {xs : List α} [BEq α] {h : xs.idxOfNth x n < xs.length} : xs[xs.idxOfNth x n] == x := pos_findIdxNth_getElem (p := (· == x)) grind_pattern getElem_idxOfNth_beq => xs[xs.idxOfNth x n] @[simp, grind =] theorem getElem_idxOfNth_eq {xs : List α} [BEq α] [LawfulBEq α] {h : xs.idxOfNth x n < xs.length} : xs[xs.idxOfNth x n] = x := eq_of_beq getElem_idxOfNth_beq theorem idxOfNth_zero [BEq α] : (xs : List α).idxOfNth x 0 = xs.idxOf x := by induction xs <;> grind @[grind _=_] theorem idxOfNth_lt_length_iff [BEq α] {xs : List α} : xs.idxOfNth x n < xs.length ↔ n < xs.count x := findIdxNth_lt_length_iff @[grind _=_] theorem idxOfNth_eq_length_iff [BEq α] {xs : List α} : xs.idxOfNth x n = xs.length ↔ xs.count x ≤ n := findIdxNth_eq_length_iff @[grind .] theorem idxOfNth_le_length [BEq α] {xs : List α} : xs.idxOfNth x n ≤ xs.length := findIdxNth_le_length theorem idxOfNth_lt_length_of_lt_count {xs : List α} [BEq α] : n < xs.count x → xs.idxOfNth x n < xs.length := by grind theorem idxOfNth_eq_length_of_ge_count {xs : List α} [BEq α] : xs.count x ≤ n → xs.idxOfNth x n = xs.length := by grind theorem idxOfNth_lt_idxOfNth_iff [BEq α] {xs : List α} : xs.idxOfNth x n < xs.idxOfNth x m ↔ n < xs.count x ∧ n < m := findIdxNth_lt_findIdxNth_iff theorem idxOfNth_eq_idxOfNth_iff [BEq α] {xs : List α} : xs.idxOfNth x n = xs.idxOfNth x m ↔ (xs.count x ≤ m ∨ n ≤ m) ∧ (xs.count x ≤ n ∨ m ≤ n) := findIdxNth_eq_findIdxNth_iff theorem idxOfNth_lt_idxOfNth_iff_of_lt_count [BEq α] {xs : List α} (hn : n < xs.count x) : xs.idxOfNth x n < xs.idxOfNth x m ↔ n < m := findIdxNth_lt_findIdxNth_iff_of_lt_countP hn theorem idxOfNth_mono [BEq α] {xs : List α} (hnm : n ≤ m): xs.idxOfNth x n ≤ xs.idxOfNth x m := findIdxNth_mono hnm theorem idxOfNth_eq_idxOfNth_iff_of_left_lt_count [BEq α] {xs : List α} (hn : n < xs.count x) : xs.idxOfNth x n = xs.idxOfNth x m ↔ n = m := findIdxNth_eq_findIdxNth_iff_of_left_lt_countP hn theorem idxOfNth_eq_idxOfNth_iff_of_right_lt_count [BEq α] {xs : List α} (hm : m < xs.count x) : xs.idxOfNth x n = xs.idxOfNth x m ↔ n = m := findIdxNth_eq_findIdxNth_iff_of_right_lt_countP hm theorem idxOfNth_eq_idxOfNth_of_ge_countP_ge_countP [BEq α] {xs : List α} (hn : xs.count x ≤ n) (hm : xs.count x ≤ m) : xs.idxOfNth x n = xs.idxOfNth x m := findIdxNth_eq_findIdxNth_of_ge_countP_ge_countP hn hm /-! ### countPBefore -/ @[simp, grind =] theorem countPBefore_nil : ([] : List α).countPBefore p n = 0 := rfl @[grind =] theorem countPBefore_cons {a : α} : (a :: xs).countPBefore p i = if i = 0 then 0 else if p a then xs.countPBefore p (i - 1) + 1 else xs.countPBefore p (i - 1) := by have H : ∀ i s, countPBefore.go (p : α → Bool) xs i s = countPBefore.go p xs i 0 + s := by induction xs <;> grind [countPBefore, countPBefore.go, cases Nat] cases i <;> grind [countPBefore, countPBefore.go] theorem countPBefore_cons_zero {a : α} : (a :: xs).countPBefore p 0 = 0 := by grind @[simp] theorem countPBefore_cons_succ {a : α} : (a :: xs).countPBefore p (i + 1) = if p a then xs.countPBefore p i + 1 else xs.countPBefore p i := by grind @[simp, grind =] theorem countPBefore_zero : (xs : List α).countPBefore p 0 = 0 := by grind [cases List] @[grind =] theorem countPBefore_succ : (xs : List α).countPBefore p (i + 1) = if h : xs = [] then 0 else if p (xs.head h) then xs.tail.countPBefore p i + 1 else xs.tail.countPBefore p i := by grind [cases List] theorem countPBefore_cons_succ_of_neg {a : α} (h : p a = false) : (a :: xs).countPBefore p (i + 1) = xs.countPBefore p i := by grind theorem countPBefore_cons_succ_of_pos {a : α} (h : p a) : (a :: xs).countPBefore p (i + 1) = xs.countPBefore p i + 1 := by grind theorem countPBefore_eq_countP_take : (xs : List α).countPBefore p i = (xs.take i).countP p := by induction xs generalizing i <;> grind [cases Nat] theorem countPBefore_of_ge_length {xs : List α} (hi : xs.length ≤ i) : xs.countPBefore p i = xs.countP p := by rw [countPBefore_eq_countP_take, take_of_length_le (by grind)] theorem countPBefore_length {xs : List α} : xs.countPBefore p xs.length = xs.countP p := countPBefore_of_ge_length (by grind) @[simp, grind <=] theorem findIdxNth_countPBefore_of_lt_length_of_pos {xs : List α} {h : i < xs.length} (hip : p xs[i]) : xs.findIdxNth p (xs.countPBefore p i) = i := by induction xs generalizing i <;> grind @[simp, grind <=] theorem countPBefore_findIdxNth_of_lt_countP {xs : List α} : n < xs.countP p → xs.countPBefore p (xs.findIdxNth p n) = n := by induction xs generalizing n <;> grind theorem pos_iff_exists_findIdxNth {xs : List α} {h : i < xs.length} : p xs[i] ↔ ∃ n, xs.findIdxNth p n = i := ⟨fun h => ⟨xs.countPBefore p i, by grind⟩, by grind⟩ theorem countPBefore_le_countP {xs : List α} (p : α → Bool) : xs.countPBefore p i ≤ xs.countP p := by rw [countPBefore_eq_countP_take] exact (take_sublist _ _).countP_le theorem countPBefore_mono {xs : List α} (hij : i ≤ j) : xs.countPBefore p i ≤ xs.countPBefore p j := by simp only [countPBefore_eq_countP_take] exact (take_sublist_take_left hij).countP_le @[grind <=] theorem countPBefore_lt_countP_of_lt_length_of_pos {xs : List α} {h : i < xs.length} (hip : p xs[i]) : xs.countPBefore p i < xs.countP p := by rwa [← findIdxNth_lt_length_iff, findIdxNth_countPBefore_of_lt_length_of_pos hip] /-! ### countBefore -/ @[simp, grind =] theorem countBefore_nil [BEq α] : ([] : List α).countBefore x i = 0 := rfl @[grind =] theorem countBefore_cons [BEq α] {a : α} : (a :: xs).countBefore x i = if i = 0 then 0 else if a == x then xs.countBefore x (i - 1) + 1 else xs.countBefore x (i - 1) := countPBefore_cons @[simp] theorem countBefore_zero [BEq α] : (xs : List α).countBefore p 0 = 0 := countPBefore_zero @[simp] theorem countBefore_cons_succ {a : α} [BEq α] : (a :: xs).countBefore x (i + 1) = xs.countBefore x i + if a == x then 1 else 0 := by grind theorem countBefore_cons_succ_of_not_beq [BEq α] {a : α} (h : (a == x) = false): (a :: xs).countBefore x (i + 1) = xs.countBefore x i := by grind theorem countBefore_cons_succ_of_beq {a : α} [BEq α] (h : a == x) : (a :: xs).countBefore x (i + 1) = xs.countBefore x i + 1 := by grind theorem countBefore_eq_count_take [BEq α] : (xs : List α).countBefore x i = (xs.take i).count x := by induction xs generalizing i <;> cases i <;> grind @[grind <=] theorem countBefore_idxOfNth_of_lt_count [BEq α] {xs : List α} (hn : n < xs.count x) : xs.countBefore x (xs.idxOfNth x n) = n := countPBefore_findIdxNth_of_lt_countP hn @[grind <=] theorem idxOfNth_countBefore_of_lt_length_of_beq [BEq α] {xs : List α} {h : i < xs.length} (hip : xs[i] == x) : xs.idxOfNth x (xs.countBefore x i) = i := findIdxNth_countPBefore_of_lt_length_of_pos hip @[simp, grind =] theorem idxOfNth_countBefore_getElem [BEq α] [ReflBEq α] {xs : List α} {h : i < xs.length} : xs.idxOfNth xs[i] (xs.countBefore xs[i] i) = i := idxOfNth_countBefore_of_lt_length_of_beq BEq.rfl theorem beq_iff_exists_findIdxNth [BEq α] {xs : List α} {h : i < xs.length} : xs[i] == x ↔ ∃ n, xs.idxOfNth x n = i := ⟨fun h => ⟨xs.countBefore x i, by grind⟩, by grind⟩ theorem countBefore_le_count [BEq α] {xs : List α} : xs.countBefore x i ≤ xs.count x := by induction xs generalizing i <;> cases i <;> grind @[grind <=] theorem countBefore_lt_count_of_lt_length_of_beq [BEq α] {xs : List α} {h : i < xs.length} (hip : xs[i] == x) : xs.countBefore x i < xs.count x := countPBefore_lt_countP_of_lt_length_of_pos hip @[simp, grind <=] theorem countBefore_lt_count_getElem [BEq α] [ReflBEq α] {xs : List α} {h : i < xs.length} : xs.countBefore xs[i] i < xs.count xs[i] := countBefore_lt_count_of_lt_length_of_beq BEq.rfl theorem countBefore_of_ge_length [BEq α] {xs : List α} (hi : xs.length ≤ i) : xs.countBefore x i = xs.count x := countPBefore_of_ge_length hi /-! ### insertP -/ theorem insertP_loop (a : α) (l r : List α) : insertP.loop p a l r = reverseAux r (insertP p a l) := by induction l generalizing r with simp [insertP, insertP.loop, cond] | cons b l ih => rw [ih (b :: r), ih [b]]; split <;> simp @[simp] theorem insertP_nil (p : α → Bool) (a) : insertP p a [] = [a] := rfl @[simp] theorem insertP_cons_pos (p : α → Bool) (a b l) (h : p b) : insertP p a (b :: l) = a :: b :: l := by simp only [insertP, insertP.loop, cond, h]; rfl @[simp] theorem insertP_cons_neg (p : α → Bool) (a b l) (h : ¬ p b) : insertP p a (b :: l) = b :: insertP p a l := by simp only [insertP, insertP.loop, cond, h]; exact insertP_loop .. @[simp] theorem length_insertP (p : α → Bool) (a l) : (insertP p a l).length = l.length + 1 := by induction l with simp [insertP, insertP.loop, cond] | cons _ _ ih => split <;> simp [insertP_loop, ih] @[simp] theorem mem_insertP (p : α → Bool) (a l) : a ∈ insertP p a l := by induction l with simp [insertP, insertP.loop, cond] | cons _ _ ih => split <;> simp [insertP_loop, ih] /-! ### dropPrefix?, dropSuffix?, dropInfix?-/ open Option @[simp] theorem dropPrefix?_nil [BEq α] {p : List α} : dropPrefix? p [] = some p := by simp [dropPrefix?] theorem dropPrefix?_eq_some_iff [BEq α] {l p s : List α} : dropPrefix? l p = some s ↔ ∃ p', l = p' ++ s ∧ p' == p := by unfold dropPrefix? split · simp · simp · rename_i a as b bs simp only [ite_none_right_eq_some] constructor · rw [dropPrefix?_eq_some_iff] rintro ⟨w, p', rfl, h⟩ refine ⟨a :: p', by simp_all⟩ · rw [dropPrefix?_eq_some_iff] rintro ⟨p, h, w⟩ rw [cons_eq_append_iff] at h obtain (⟨rfl, rfl⟩ | ⟨a', rfl, rfl⟩) := h · simp at w · simp only [cons_beq_cons, Bool.and_eq_true] at w refine ⟨w.1, a', rfl, w.2⟩ theorem dropPrefix?_append_of_beq [BEq α] {l₁ l₂ : List α} (p : List α) (h : l₁ == l₂) : dropPrefix? (l₁ ++ p) l₂ = some p := by simp [dropPrefix?_eq_some_iff, h] theorem dropSuffix?_eq_some_iff [BEq α] {l p s : List α} : dropSuffix? l s = some p ↔ ∃ s', l = p ++ s' ∧ s' == s := by unfold dropSuffix? rw [splitAt_eq] simp only [ite_none_right_eq_some, some.injEq] constructor · rintro ⟨w, rfl⟩ refine ⟨_, by simp, w⟩ · rintro ⟨s', rfl, w⟩ simp [length_eq_of_beq w, w] @[simp] theorem dropSuffix?_nil [BEq α] {s : List α} : dropSuffix? s [] = some s := by simp [dropSuffix?_eq_some_iff] theorem dropInfix?_go_eq_some_iff [BEq α] {i l acc p s : List α} : dropInfix?.go i l acc = some (p, s) ↔ ∃ p', p = acc.reverse ++ p' ∧ -- `i` is an infix up to `==` (∃ i', l = p' ++ i' ++ s ∧ i' == i) ∧ -- and there is no shorter prefix for which that is the case (∀ p'' i'' s'', l = p'' ++ i'' ++ s'' → i'' == i → p''.length ≥ p'.length) := by unfold dropInfix?.go split · simp only [isEmpty_iff, ite_none_right_eq_some, some.injEq, Prod.mk.injEq, nil_eq, append_assoc, append_eq_nil_iff, ge_iff_le, and_imp] constructor · rintro ⟨rfl, rfl, rfl⟩ simp · rintro ⟨p', rfl, ⟨_, ⟨rfl, rfl, rfl⟩, h⟩, w⟩ simp_all · rename_i a t split <;> rename_i h · rw [dropInfix?_go_eq_some_iff] constructor · rintro ⟨p', rfl, ⟨i', rfl, h₂⟩, w⟩ refine ⟨a :: p', ?_⟩ simp [h₂] intro p'' i'' s'' h₁ h₂ rw [cons_eq_append_iff] at h₁ obtain (⟨rfl, h₁⟩ | ⟨p'', rfl, h₁⟩) := h₁ · rw [append_assoc, ← h₁] at h have := dropPrefix?_append_of_beq s'' h₂ simp_all · simpa using w p'' i'' s'' (by simpa using h₁) h₂ · rintro ⟨p', rfl, ⟨i', h₁, h₂⟩, w⟩ rw [cons_eq_append_iff] at h₁ simp at h₁ obtain (⟨⟨rfl, rfl⟩, rfl⟩ | ⟨a', h₁, rfl⟩) := h₁ · simp only [nil_beq_eq, isEmpty_iff] at h₂ simp only [h₂] at h simp at h · rw [append_eq_cons_iff] at h₁ obtain (⟨rfl, rfl⟩ | ⟨p', rfl, rfl⟩) := h₁ · rw [← cons_append] at h have := dropPrefix?_append_of_beq s h₂ simp_all · refine ⟨p', ?_⟩ simp only [reverse_cons, append_assoc, singleton_append, append_cancel_left_eq, append_cancel_right_eq, exists_eq_left', ge_iff_le, true_and] refine ⟨h₂, ?_⟩ intro p'' i'' s'' h₃ h₄ rw [← append_assoc] at h₃ rw [h₃] at w simpa using w (a :: p'') i'' s'' (by simp) h₄ · rename_i s' simp only [some.injEq, Prod.mk.injEq, append_assoc, ge_iff_le] rw [dropPrefix?_eq_some_iff] at h obtain ⟨p', h, w⟩ := h constructor · rintro ⟨rfl, rfl⟩ simpa using ⟨p', by simp_all⟩ · rintro ⟨p'', rfl, ⟨i', h₁, h₂⟩, w'⟩ specialize w' [] p' s' (by simpa using h) w simp at w' simp [w'] at h₁ ⊢ rw [h] at h₁ apply append_inj_right h₁ replace w := length_eq_of_beq w replace h₂ := length_eq_of_beq h₂ simp_all theorem dropInfix?_eq_some_iff [BEq α] {l i p s : List α} : dropInfix? l i = some (p, s) ↔ -- `i` is an infix up to `==` (∃ i', l = p ++ i' ++ s ∧ i' == i) ∧ -- and there is no shorter prefix for which that is the case (∀ p' i' s', l = p' ++ i' ++ s' → i' == i → p'.length ≥ p.length) := by unfold dropInfix? rw [dropInfix?_go_eq_some_iff] simp @[simp] theorem dropInfix?_nil [BEq α] {s : List α} : dropInfix? s [] = some ([], s) := by simp [dropInfix?_eq_some_iff] /-! ### IsPrefixOf?, IsSuffixOf? -/ @[simp] theorem isSome_isPrefixOf?_eq_isPrefixOf [BEq α] (xs ys : List α) : (xs.isPrefixOf? ys).isSome = xs.isPrefixOf ys := by match xs, ys with | [], _ => simp [List.isPrefixOf?] | _::_, [] => rfl | _::_, _::_ => simp only [List.isPrefixOf?, List.isPrefixOf] split <;> simp [*, isSome_isPrefixOf?_eq_isPrefixOf] @[simp] theorem isPrefixOf?_eq_some_iff_append_eq [BEq α] [LawfulBEq α] {xs ys zs : List α} : xs.isPrefixOf? ys = some zs ↔ xs ++ zs = ys := by induction xs generalizing ys with | nil => simp [isPrefixOf?, Eq.comm] | cons => cases ys <;> simp [isPrefixOf?, *] theorem append_eq_of_isPrefixOf?_eq_some [BEq α] [LawfulBEq α] {xs ys zs : List α} (h : xs.isPrefixOf? ys = some zs) : xs ++ zs = ys := by simp_all @[simp] theorem isSome_isSuffixOf?_eq_isSuffixOf [BEq α] (xs ys : List α) : (xs.isSuffixOf? ys).isSome = xs.isSuffixOf ys := by simp [List.isSuffixOf?, isSuffixOf] @[simp] theorem isSuffixOf?_eq_some_iff_append_eq [BEq α] [LawfulBEq α] {xs ys zs : List α} : xs.isSuffixOf? ys = some zs ↔ zs ++ xs = ys := by simp only [isSuffixOf?, map_eq_some_iff, isPrefixOf?_eq_some_iff_append_eq] constructor · intro | ⟨_, h, heq⟩ => rw [List.reverse_eq_iff] at heq rw [heq] at h rw [← reverse_inj, reverse_append, h] · intro h exists zs.reverse simp [← h] theorem append_eq_of_isSuffixOf?_eq_some [BEq α] [LawfulBEq α] {xs ys zs : List α} (h : xs.isSuffixOf? ys = some zs) : zs ++ xs = ys := by simp_all /-! ### finRange -/ theorem get_finRange (i : Fin (finRange n).length) : (finRange n).get i = Fin.cast length_finRange i := by simp @[simp, grind =] theorem finRange_eq_nil_iff : finRange n = [] ↔ n = 0 := by simp [eq_nil_iff_length_eq_zero] theorem finRange_eq_pmap_range : finRange n = (range n).pmap Fin.mk (by simp) := by apply List.ext_getElem <;> simp [finRange] theorem nodup_finRange (n) : (finRange n).Nodup := by rw [finRange_eq_pmap_range] exact (Pairwise.pmap nodup_range _) fun _ _ _ _ => @Fin.ne_of_val_ne _ ⟨_, _⟩ ⟨_, _⟩ theorem pairwise_lt_finRange (n) : Pairwise (· < ·) (finRange n) := by rw [finRange_eq_pmap_range] exact List.pairwise_lt_range.pmap (by simp) (by simp) theorem pairwise_le_finRange (n) : Pairwise (· ≤ ·) (finRange n) := by rw [finRange_eq_pmap_range] exact List.pairwise_le_range.pmap (by simp) (by simp) @[simp] theorem map_get_finRange (l : List α) : (finRange l.length).map l.get = l := by apply ext_getElem <;> simp @[simp] theorem map_getElem_finRange (l : List α) : (finRange l.length).map (l[·.1]) = l := by apply ext_getElem <;> simp @[simp] theorem map_coe_finRange_eq_range : (finRange n).map (↑·) = List.range n := by apply List.ext_getElem <;> simp /-! ### sum/prod -/ @[simp, grind =] theorem prod_nil [Mul α] [One α] : ([] : List α).prod = 1 := rfl @[simp, grind =] theorem prod_cons [Mul α] [One α] {a : α} {l : List α} : (a :: l).prod = a * l.prod := rfl theorem prod_one_cons [Mul α] [One α] [Std.LawfulLeftIdentity (α := α) (· * ·) 1] {l : List α} : (1 :: l).prod = l.prod := by simp [Std.LawfulLeftIdentity.left_id] theorem prod_singleton [Mul α] [One α] [Std.LawfulRightIdentity (α := α) (· * ·) 1] {a : α} : [a].prod = a := by simp [Std.LawfulRightIdentity.right_id] theorem prod_pair [Mul α] [One α] [Std.LawfulRightIdentity (α := α) (· * ·) 1] {a b : α} : [a, b].prod = a * b := by simp [Std.LawfulRightIdentity.right_id] @[simp, grind =] theorem prod_append [Mul α] [One α] [Std.LawfulLeftIdentity (α := α) (· * ·) 1] [Std.Associative (α := α) (· * ·)] {l₁ l₂ : List α} : (l₁ ++ l₂).prod = l₁.prod * l₂.prod := by induction l₁ with simp [Std.LawfulLeftIdentity.left_id, Std.Associative.assoc, *] theorem prod_concat [Mul α] [One α] [Std.LawfulIdentity (α := α) (· * ·) 1] [Std.Associative (α := α) (· * ·)] {l : List α} {a : α} : (l.concat a).prod = l.prod * a := by simp [Std.LawfulRightIdentity.right_id] @[simp, grind =] theorem prod_flatten [Mul α] [One α] [Std.LawfulIdentity (α := α) (· * ·) 1] [Std.Associative (α := α) (· * ·)] {l : List (List α)} : l.flatten.prod = (l.map prod).prod := by induction l with simp [*] theorem prod_eq_foldr [Mul α] [One α] {l : List α} : l.prod = l.foldr (· * ·) 1 := rfl theorem prod_eq_foldl [Mul α] [One α] [Std.Associative (α := α) (· * ·)] [Std.LawfulIdentity (α := α) (· * ·) 1] {l : List α} : l.prod = l.foldl (· * ·) 1 := foldr_eq_foldl .. theorem sum_zero_cons [Add α] [Zero α] [Std.LawfulLeftIdentity (α := α) (· + ·) 0] {l : List α} : (0 :: l).sum = l.sum := by simp [Std.LawfulLeftIdentity.left_id] theorem sum_pair [Add α] [Zero α] [Std.LawfulRightIdentity (α := α) (· + ·) 0] {a b : α} : [a, b].sum = a + b := by simp [Std.LawfulRightIdentity.right_id] theorem sum_concat [Add α] [Zero α] [Std.LawfulIdentity (α := α) (· + ·) 0] [Std.Associative (α := α) (· + ·)] {l : List α} {a : α} : (l.concat a).sum = l.sum + a := by simp [Std.LawfulRightIdentity.right_id] @[simp, grind =] theorem sum_flatten [Add α] [Zero α] [Std.LawfulIdentity (α := α) (· + ·) 0] [Std.Associative (α := α) (· + ·)] {l : List (List α)} : l.flatten.sum = (l.map sum).sum := by induction l with simp [*] theorem take_succ_drop {l : List α} {n stop : Nat} (h : n < l.length - stop) : (l.drop stop |>.take (n + 1)) = (l.drop stop |>.take n) ++ [l[stop + n]'(by omega)] := by rw [← List.take_append_getElem (by simpa [← List.length_drop] using h)] simp [List.getElem_drop] ================================================ FILE: Batteries/Data/List/Matcher.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Data.Array.Match @[expose] public section namespace List /-- Knuth-Morris-Pratt matcher type This type is used to keep data for running the Knuth-Morris-Pratt (KMP) list matching algorithm. KMP is a linear time algorithm to locate all contiguous sublists of a list that match a given pattern. Generating the algorithm data is also linear in the length of the pattern but the data can be re-used to match the same pattern over multiple lists. The KMP data for a pattern can be generated using `Matcher.ofList`. Then `Matcher.find?` and `Matcher.findAll` can be used to run the algorithm on an input list. ``` def m := Matcher.ofList [0,1,1,0] #eval Option.isSome <| m.find? [2,1,1,0,1,1,2] -- false #eval Option.isSome <| m.find? [0,0,1,1,0,0] -- true #eval Array.size <| m.findAll [0,1,1,0,1,1,0] -- 2 #eval Array.size <| m.findAll [0,1,1,0,1,1,0,1,1,0] -- 3 ``` -/ structure Matcher (α : Type _) extends Array.Matcher α where /-- The pattern for the matcher -/ pattern : List α /-- Make KMP matcher from list pattern. -/ @[inline] def Matcher.ofList [BEq α] (pattern : List α) : Matcher α where toMatcher := Array.Matcher.ofStream pattern pattern := pattern /-- List stream that keeps count of items read. -/ local instance (α) : Std.Stream (List α × Nat) α where next? | ([], _) => none | (x::xs, n) => (x, xs, n+1) /-- Find all start and end positions of all infix sublists of `l` matching `m.pattern`. The sublists may be overlapping. -/ partial def Matcher.findAll [BEq α] (m : Matcher α) (l : List α) : Array (Nat × Nat) := loop (l, 0) m.toMatcher #[] where /-- Accumulator loop for `List.Matcher.findAll` -/ loop (l : List α × Nat) (am : Array.Matcher α) (occs : Array (Nat × Nat)) : Array (Nat × Nat) := match am.next? l with | none => occs | some (l, am) => loop l am (occs.push (l.snd - m.table.size, l.snd)) /-- Find the start and end positions of the first infix sublist of `l` matching `m.pattern`, or `none` if there is no such sublist. -/ def Matcher.find? [BEq α] (m : Matcher α) (l : List α) : Option (Nat × Nat) := match m.next? (l, 0) with | none => none | some (l, _) => some (l.snd - m.table.size, l.snd) /-- Returns all the start and end positions of all infix sublists of of `l` that match `pattern`. The sublists may be overlapping. -/ @[inline] def findAllInfix [BEq α] (l pattern : List α) : Array (Nat × Nat) := (Matcher.ofList pattern).findAll l /-- Returns the start and end positions of the first infix sublist of `l` that matches `pattern`, or `none` if there is no such sublist. -/ @[inline] def findInfix? [BEq α] (l pattern : List α) : Option (Nat × Nat) := (Matcher.ofList pattern).find? l /-- Returns true iff `pattern` occurs as an infix sublist of `l`. -/ @[inline] def containsInfix [BEq α] (l pattern : List α) : Bool := findInfix? l pattern |>.isSome ================================================ FILE: Batteries/Data/List/Monadic.lean ================================================ /- Copyright (c) 2024 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Classes.SatisfiesM @[expose] public section /-! # Results about monadic operations on `List`, in terms of `SatisfiesM`. -/ namespace List theorem satisfiesM_foldlM [Monad m] [LawfulMonad m] {f : β → α → m β} (h₀ : motive b) (h₁ : ∀ (b) (_ : motive b) (a : α) (_ : a ∈ l), SatisfiesM motive (f b a)) : SatisfiesM motive (List.foldlM f b l) := by induction l generalizing b with | nil => exact SatisfiesM.pure h₀ | cons hd tl ih => simp only [foldlM_cons] apply SatisfiesM.bind_pre let ⟨q, qh⟩ := h₁ b h₀ hd mem_cons_self exact ⟨(fun ⟨b, bh⟩ => ⟨b, ih bh (fun b bh a am => h₁ b bh a (mem_cons_of_mem hd am))⟩) <$> q, by simpa using qh⟩ theorem satisfiesM_foldrM [Monad m] [LawfulMonad m] {f : α → β → m β} (h₀ : motive b) (h₁ : ∀ (a : α) (_ : a ∈ l) (b) (_ : motive b), SatisfiesM motive (f a b)) : SatisfiesM motive (List.foldrM f b l) := by induction l with | nil => exact SatisfiesM.pure h₀ | cons hd tl ih => simp only [foldrM_cons] apply SatisfiesM.bind_pre let ⟨q, qh⟩ := ih (fun a am b hb => h₁ a (mem_cons_of_mem hd am) b hb) exact ⟨(fun ⟨b, bh⟩ => ⟨b, h₁ hd mem_cons_self b bh⟩) <$> q, by simpa using qh⟩ end List ================================================ FILE: Batteries/Data/List/Pairwise.lean ================================================ /- Copyright (c) 2018 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, James Gallicchio -/ module public import Batteries.Data.List.Basic @[expose] public section /-! # Pairwise relations on a list This file provides basic results about `List.Pairwise` and `List.pwFilter` (definitions are in `Batteries.Data.List.Basic`). `Pairwise r [a 0, ..., a (n - 1)]` means `∀ i j, i < j → r (a i) (a j)`. For example, `Pairwise (≠) l` means that all elements of `l` are distinct, and `Pairwise (<) l` means that `l` is strictly increasing. `pwFilter r l` is the list obtained by iteratively adding each element of `l` that doesn't break the pairwiseness of the list we have so far. It thus yields `l'` a maximal sublist of `l` such that `Pairwise r l'`. ## Tags sorted, nodup -/ open Nat Function namespace List /-! ### Pairwise -/ theorem pairwise_iff_get : Pairwise R l ↔ ∀ (i j) (_hij : i < j), R (get l i) (get l j) := by rw [pairwise_iff_getElem] constructor <;> intro h · intros i j h' exact h _ _ _ _ h' · intros i j hi hj h' exact h ⟨i, hi⟩ ⟨j, hj⟩ h' /-! ### Pairwise filtering -/ @[simp] theorem pwFilter_nil [DecidableRel R] : pwFilter R [] = [] := rfl @[simp] theorem pwFilter_cons_of_pos [DecidableRel (α := α) R] {a : α} {l : List α} (h : ∀ b ∈ pwFilter R l, R a b) : pwFilter R (a :: l) = a :: pwFilter R l := if_pos h @[simp] theorem pwFilter_cons_of_neg [DecidableRel (α := α) R] {a : α} {l : List α} (h : ¬∀ b ∈ pwFilter R l, R a b) : pwFilter R (a :: l) = pwFilter R l := if_neg h theorem pwFilter_map [DecidableRel (α := α) R] (f : β → α) : ∀ l : List β, pwFilter R (map f l) = map f (pwFilter (fun x y => R (f x) (f y)) l) | [] => rfl | x :: xs => by if h : ∀ b ∈ pwFilter R (map f xs), R (f x) b then have h' : ∀ b : β, b ∈ pwFilter (fun x y : β => R (f x) (f y)) xs → R (f x) (f b) := fun b hb => h _ (by rw [pwFilter_map f xs]; apply mem_map_of_mem hb) rw [map, pwFilter_cons_of_pos h, pwFilter_cons_of_pos h', pwFilter_map f xs, map] else rw [map, pwFilter_cons_of_neg h, pwFilter_cons_of_neg ?_, pwFilter_map f xs] refine fun hh => h fun a ha => ?_ rw [pwFilter_map f xs, mem_map] at ha let ⟨b, hb₀, hb₁⟩ := ha; exact hb₁ ▸ hh _ hb₀ theorem pwFilter_sublist [DecidableRel (α := α) R] : ∀ l : List α, pwFilter R l <+ l | [] => nil_sublist _ | x :: l => if h : ∀ y ∈ pwFilter R l, R x y then pwFilter_cons_of_pos h ▸ (pwFilter_sublist l).cons_cons _ else pwFilter_cons_of_neg h ▸ Sublist.cons _ (pwFilter_sublist l) theorem pwFilter_subset [DecidableRel (α := α) R] (l : List α) : pwFilter R l ⊆ l := (pwFilter_sublist _).subset theorem pairwise_pwFilter [DecidableRel (α := α) R] : ∀ l : List α, Pairwise R (pwFilter R l) | [] => Pairwise.nil | x :: l => if h : ∀ y ∈ pwFilter R l, R x y then pwFilter_cons_of_pos h ▸ pairwise_cons.2 ⟨h, pairwise_pwFilter l⟩ else pwFilter_cons_of_neg h ▸ pairwise_pwFilter l theorem pwFilter_eq_self [DecidableRel (α := α) R] {l : List α} : pwFilter R l = l ↔ Pairwise R l := by refine ⟨fun e => e ▸ pairwise_pwFilter l, fun p => ?_⟩ induction l with | nil => rfl | cons x l IH => let ⟨al, p⟩ := pairwise_cons.1 p rw [pwFilter_cons_of_pos fun b hb => ?_, IH p] rw [IH p] at hb exact al _ hb @[simp] theorem pwFilter_idem [DecidableRel (α := α) R] : pwFilter R (pwFilter R l) = pwFilter R l := pwFilter_eq_self.2 (pairwise_pwFilter ..) theorem forall_mem_pwFilter [DecidableRel (α := α) R] (neg_trans : ∀ {x y z}, R x z → R x y ∨ R y z) (a : α) (l : List α) : (∀ b ∈ pwFilter R l, R a b) ↔ ∀ b ∈ l, R a b := by refine ⟨?_, fun h b hb => h _ <| pwFilter_subset (R := R) _ hb⟩ induction l with | nil => exact fun _ _ h => (not_mem_nil h).elim | cons x l IH => simp only [forall_mem_cons] if h : ∀ y ∈ pwFilter R l, R x y then simpa [pwFilter_cons_of_pos h] using fun r H => ⟨r, IH H⟩ else refine pwFilter_cons_of_neg h ▸ fun H => ⟨?_, IH H⟩ match e : find? (fun y => ¬R x y) (pwFilter R l) with | none => exact h.elim fun y hy => by simpa using find?_eq_none.1 e y hy | some k => have := find?_some e apply (neg_trans (H k (mem_of_find?_eq_some e))).resolve_right rw [decide_eq_true_iff] at this; exact this ================================================ FILE: Batteries/Data/List/Perm.lean ================================================ /- Copyright (c) 2015 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro -/ module public import Batteries.Tactic.Alias public import Batteries.Data.List.Count import Batteries.Util.ProofWanted @[expose] public section /-! # List Permutations This file introduces the `List.Perm` relation, which is true if two lists are permutations of one another. ## Notation The notation `~` is used for permutation equivalence. -/ open Nat namespace List open Perm (swap) @[simp] theorem nil_subperm {l : List α} : [] <+~ l := ⟨[], Perm.nil, by simp⟩ theorem Perm.subperm_left {l l₁ l₂ : List α} (p : l₁ ~ l₂) : l <+~ l₁ ↔ l <+~ l₂ := suffices ∀ {l₁ l₂ : List α}, l₁ ~ l₂ → l <+~ l₁ → l <+~ l₂ from ⟨this p, this p.symm⟩ fun p ⟨_u, pu, su⟩ => let ⟨v, pv, sv⟩ := exists_perm_sublist su p ⟨v, pv.trans pu, sv⟩ theorem Perm.subperm_right {l₁ l₂ l : List α} (p : l₁ ~ l₂) : l₁ <+~ l ↔ l₂ <+~ l := ⟨fun ⟨u, pu, su⟩ => ⟨u, pu.trans p, su⟩, fun ⟨u, pu, su⟩ => ⟨u, pu.trans p.symm, su⟩⟩ theorem Sublist.subperm {l₁ l₂ : List α} (s : l₁ <+ l₂) : l₁ <+~ l₂ := ⟨l₁, .rfl, s⟩ theorem Perm.subperm {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁ <+~ l₂ := ⟨l₂, p.symm, Sublist.refl _⟩ @[refl] theorem Subperm.refl (l : List α) : l <+~ l := Perm.rfl.subperm theorem Subperm.trans {l₁ l₂ l₃ : List α} (s₁₂ : l₁ <+~ l₂) (s₂₃ : l₂ <+~ l₃) : l₁ <+~ l₃ := let ⟨_l₂', p₂, s₂⟩ := s₂₃ let ⟨l₁', p₁, s₁⟩ := p₂.subperm_left.2 s₁₂ ⟨l₁', p₁, s₁.trans s₂⟩ theorem Subperm.cons_self : l <+~ a :: l := ⟨l, .refl _, sublist_cons_self ..⟩ theorem Subperm.cons_right {α : Type _} {l l' : List α} (x : α) (h : l <+~ l') : l <+~ x :: l' := h.trans (sublist_cons_self x l').subperm theorem Subperm.length_le {l₁ l₂ : List α} : l₁ <+~ l₂ → length l₁ ≤ length l₂ | ⟨_l, p, s⟩ => p.length_eq ▸ s.length_le theorem Subperm.perm_of_length_le {l₁ l₂ : List α} : l₁ <+~ l₂ → length l₂ ≤ length l₁ → l₁ ~ l₂ | ⟨_l, p, s⟩, h => (s.eq_of_length_le <| p.symm.length_eq ▸ h) ▸ p.symm theorem Subperm.antisymm {l₁ l₂ : List α} (h₁ : l₁ <+~ l₂) (h₂ : l₂ <+~ l₁) : l₁ ~ l₂ := h₁.perm_of_length_le h₂.length_le theorem Subperm.subset {l₁ l₂ : List α} : l₁ <+~ l₂ → l₁ ⊆ l₂ | ⟨_l, p, s⟩ => Subset.trans p.symm.subset s.subset theorem Subperm.filter (p : α → Bool) ⦃l l' : List α⦄ (h : l <+~ l') : filter p l <+~ filter p l' := by let ⟨xs, hp, h⟩ := h exact ⟨_, hp.filter p, h.filter p⟩ @[simp] theorem subperm_nil : l <+~ [] ↔ l = [] := ⟨fun h => length_eq_zero_iff.1 $ Nat.le_zero.1 h.length_le, by rintro rfl; rfl⟩ @[simp] theorem singleton_subperm_iff {α} {l : List α} {a : α} : [a] <+~ l ↔ a ∈ l := by refine ⟨fun ⟨s, hla, h⟩ => ?_, fun h => ⟨[a], .rfl, singleton_sublist.mpr h⟩⟩ rwa [perm_singleton.mp hla, singleton_sublist] at h theorem Subperm.countP_le (p : α → Bool) {l₁ l₂ : List α} : l₁ <+~ l₂ → countP p l₁ ≤ countP p l₂ | ⟨_l, p', s⟩ => p'.countP_eq p ▸ s.countP_le theorem Subperm.count_le [BEq α] {l₁ l₂ : List α} (s : l₁ <+~ l₂) (a) : count a l₁ ≤ count a l₂ := s.countP_le _ theorem subperm_cons (a : α) {l₁ l₂ : List α} : a :: l₁ <+~ a :: l₂ ↔ l₁ <+~ l₂ := by refine ⟨fun ⟨l, p, s⟩ => ?_, fun ⟨l, p, s⟩ => ⟨a :: l, p.cons a, s.cons_cons _⟩⟩ match s with | .cons _ s' => exact (p.subperm_left.2 <| (sublist_cons_self _ _).subperm).trans s'.subperm | .cons_cons _ s' => exact ⟨_, p.cons_inv, s'⟩ /-- Weaker version of `Subperm.cons_left` -/ theorem cons_subperm_of_not_mem_of_mem {a : α} {l₁ l₂ : List α} (h₁ : a ∉ l₁) (h₂ : a ∈ l₂) (s : l₁ <+~ l₂) : a :: l₁ <+~ l₂ := by obtain ⟨l, p, s⟩ := s induction s generalizing l₁ with | slnil => cases h₂ | @cons r₁ _ b s' ih => simp at h₂ match h₂ with | .inl e => subst_vars; exact ⟨_ :: r₁, p.cons _, s'.cons_cons _⟩ | .inr m => let ⟨t, p', s'⟩ := ih h₁ m p; exact ⟨t, p', s'.cons _⟩ | @cons_cons _ r₂ b _ ih => have bm : b ∈ l₁ := p.subset mem_cons_self have am : a ∈ r₂ := by simp only [mem_cons] at h₂ exact h₂.resolve_left fun e => h₁ <| e.symm ▸ bm obtain ⟨t₁, t₂, rfl⟩ := append_of_mem bm have st : t₁ ++ t₂ <+ t₁ ++ b :: t₂ := by simp obtain ⟨t, p', s'⟩ := ih (mt (st.subset ·) h₁) am (.cons_inv <| p.trans perm_middle) exact ⟨b :: t, (p'.cons b).trans <| (swap ..).trans (perm_middle.symm.cons a), s'.cons_cons _⟩ theorem subperm_append_left {l₁ l₂ : List α} : ∀ l, l ++ l₁ <+~ l ++ l₂ ↔ l₁ <+~ l₂ | [] => .rfl | a :: l => (subperm_cons a).trans (subperm_append_left l) theorem subperm_append_right {l₁ l₂ : List α} (l) : l₁ ++ l <+~ l₂ ++ l ↔ l₁ <+~ l₂ := (perm_append_comm.subperm_left.trans perm_append_comm.subperm_right).trans (subperm_append_left l) theorem Subperm.exists_of_length_lt {l₁ l₂ : List α} (s : l₁ <+~ l₂) (h : length l₁ < length l₂) : ∃ a, a :: l₁ <+~ l₂ := by obtain ⟨l, p, s⟩ := s suffices length l < length l₂ → ∃ a : α, a :: l <+~ l₂ from (this <| p.symm.length_eq ▸ h).imp fun a => (p.cons a).subperm_right.1 clear h p l₁ induction s with intro h | slnil => cases h | cons a s IH => match Nat.lt_or_eq_of_le (Nat.le_of_lt_succ h) with | .inl h => exact (IH h).imp fun a s => s.trans (sublist_cons_self _ _).subperm | .inr h => exact ⟨a, s.eq_of_length h ▸ .refl _⟩ | cons_cons b _ IH => exact (IH <| Nat.lt_of_succ_lt_succ h).imp fun a s => (swap ..).subperm_right.1 <| (subperm_cons _).2 s theorem subperm_of_subset (d : Nodup l₁) (H : l₁ ⊆ l₂) : l₁ <+~ l₂ := by induction d with | nil => exact ⟨nil, .nil, nil_sublist _⟩ | cons h _ IH => have ⟨H₁, H₂⟩ := forall_mem_cons.1 H exact cons_subperm_of_not_mem_of_mem (h _ · rfl) H₁ (IH H₂) theorem perm_ext_iff_of_nodup {l₁ l₂ : List α} (d₁ : Nodup l₁) (d₂ : Nodup l₂) : l₁ ~ l₂ ↔ ∀ a, a ∈ l₁ ↔ a ∈ l₂ := by refine ⟨fun p _ => p.mem_iff, fun H => ?_⟩ exact (subperm_of_subset d₁ fun a => (H a).1).antisymm <| subperm_of_subset d₂ fun a => (H a).2 theorem Nodup.perm_iff_eq_of_sublist {l₁ l₂ l : List α} (d : Nodup l) (s₁ : l₁ <+ l) (s₂ : l₂ <+ l) : l₁ ~ l₂ ↔ l₁ = l₂ := by refine ⟨fun h => ?_, fun h => by rw [h]⟩ induction s₂ generalizing l₁ with simp [Nodup, List.forall_mem_ne] at d | slnil => exact h.eq_nil | cons a s₂ IH => match s₁ with | .cons _ s₁ => exact IH d.2 s₁ h | .cons_cons _ s₁ => have := Subperm.subset ⟨_, h.symm, s₂⟩ (.head _) exact (d.1 this).elim | cons_cons a _ IH => match s₁ with | .cons _ s₁ => have := Subperm.subset ⟨_, h, s₁⟩ (.head _) exact (d.1 this).elim | .cons_cons _ s₁ => rw [IH d.2 s₁ h.cons_inv] theorem subperm_cons_erase [BEq α] [LawfulBEq α] (a : α) (l : List α) : l <+~ a :: l.erase a := if h : a ∈ l then (perm_cons_erase h).subperm else (erase_of_not_mem h).symm ▸ (sublist_cons_self _ _).subperm theorem erase_subperm [BEq α] (a : α) (l : List α) : l.erase a <+~ l := erase_sublist.subperm theorem Subperm.erase [BEq α] [LawfulBEq α] (a : α) (h : l₁ <+~ l₂) : l₁.erase a <+~ l₂.erase a := let ⟨l, hp, hs⟩ := h ⟨l.erase a, hp.erase _, hs.erase _⟩ theorem Perm.diff_right [BEq α] [LawfulBEq α] (t : List α) (h : l₁ ~ l₂) : l₁.diff t ~ l₂.diff t := by induction t generalizing l₁ l₂ h with simp only [List.diff] | nil => exact h | cons x t ih => simp only [elem_eq_mem, decide_eq_true_eq, Perm.mem_iff h] split · exact ih (h.erase _) · exact ih h theorem Perm.diff_left [BEq α] [LawfulBEq α] (l : List α) (h : t₁ ~ t₂) : l.diff t₁ = l.diff t₂ := by induction h generalizing l with try simp [List.diff] | cons x _ ih => apply ite_congr rfl <;> (intro; apply ih) | swap x y => if h : x = y then simp [h] else simp [mem_erase_of_ne h, mem_erase_of_ne (Ne.symm h), erase_comm x y] split <;> simp | trans => simp only [*] theorem Perm.diff [BEq α] [LawfulBEq α] {l₁ l₂ t₁ t₂ : List α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) : l₁.diff t₁ ~ l₂.diff t₂ := ht.diff_left l₂ ▸ hl.diff_right _ theorem Subperm.diff_right [BEq α] [LawfulBEq α] (h : l₁ <+~ l₂) (t : List α) : l₁.diff t <+~ l₂.diff t := by induction t generalizing l₁ l₂ h with simp [List.diff, *] | cons x t ih => split <;> rename_i hx1 · simp [h.subset hx1] exact ih (h.erase _) · split · rw [← erase_of_not_mem hx1] exact ih (h.erase _) · exact ih h theorem erase_cons_subperm_cons_erase [BEq α] [LawfulBEq α] (a b : α) (l : List α) : (a :: l).erase b <+~ a :: l.erase b := by if h : a = b then rw [h, erase_cons_head]; apply subperm_cons_erase else have : ¬(a == b) = true := by simp only [beq_false_of_ne h, not_false_eq_true, reduceCtorEq] rw [erase_cons_tail this] theorem subperm_cons_diff [BEq α] [LawfulBEq α] {a : α} {l₁ l₂ : List α} : (a :: l₁).diff l₂ <+~ a :: l₁.diff l₂ := by induction l₂ with | nil => exact ⟨a :: l₁, by simp [List.diff]⟩ | cons b l₂ ih => rw [diff_cons, diff_cons, ← diff_erase, ← diff_erase] exact Subperm.trans (.erase _ ih) (erase_cons_subperm_cons_erase ..) theorem subset_cons_diff [BEq α] [LawfulBEq α] {a : α} {l₁ l₂ : List α} : (a :: l₁).diff l₂ ⊆ a :: l₁.diff l₂ := subperm_cons_diff.subset /-- The list version of `add_tsub_cancel_of_le` for multisets. -/ theorem subperm_append_diff_self_of_count_le [BEq α] [LawfulBEq α] {l₁ l₂ : List α} (h : ∀ x ∈ l₁, count x l₁ ≤ count x l₂) : l₁ ++ l₂.diff l₁ ~ l₂ := by induction l₁ generalizing l₂ with | nil => simp | cons hd tl IH => have : hd ∈ l₂ := by rw [← count_pos_iff] exact Nat.lt_of_lt_of_le (count_pos_iff.mpr (.head _)) (h hd (.head _)) have := perm_cons_erase this refine Perm.trans ?_ this.symm rw [cons_append, diff_cons, perm_cons] refine IH fun x hx => ?_ specialize h x (.tail _ hx) rw [perm_iff_count.mp this] at h if hx : hd = x then subst hd; simpa [Nat.succ_le_succ_iff] using h else simpa [hx] using h /-- The list version of `Multiset.le_iff_count`. -/ theorem subperm_ext_iff [BEq α] [LawfulBEq α] {l₁ l₂ : List α} : l₁ <+~ l₂ ↔ ∀ x ∈ l₁, count x l₁ ≤ count x l₂ := by refine ⟨fun h x _ => h.count_le x, fun h => ?_⟩ have : l₁ <+~ l₂.diff l₁ ++ l₁ := (subperm_append_right l₁).mpr nil_subperm refine this.trans (Perm.subperm ?_) exact perm_append_comm.trans (subperm_append_diff_self_of_count_le h) theorem isSubperm_iff [BEq α] [LawfulBEq α] {l₁ l₂ : List α} : l₁.isSubperm l₂ ↔ l₁ <+~ l₂ := by simp [isSubperm, subperm_ext_iff] instance decidableSubperm [BEq α] [LawfulBEq α] : DecidableRel ((· <+~ ·) : List α → List α → Prop) := fun _ _ => decidable_of_iff _ isSubperm_iff theorem Subperm.cons_left [BEq α] [LawfulBEq α] (h : l₁ <+~ l₂) (x : α) (hx : count x l₁ < count x l₂) : x :: l₁ <+~ l₂ := by rw [subperm_ext_iff] at h ⊢ intro y hy if hy' : y = x then subst x; simpa using Nat.succ_le_of_lt hx else rw [count_cons_of_ne (Ne.symm hy')] refine h y ?_ simpa [hy'] using hy theorem Perm.union_right [BEq α] [LawfulBEq α] (t₁ : List α) (h : l₁ ~ l₂) : l₁ ∪ t₁ ~ l₂ ∪ t₁ := by induction h with | nil => rfl | cons a _ ih => exact ih.insert a | swap => apply perm_insert_swap | trans _ _ ih_1 ih_2 => exact ih_1.trans ih_2 theorem Perm.union_left [BEq α] [LawfulBEq α] (l : List α) (h : t₁ ~ t₂) : l ∪ t₁ ~ l ∪ t₂ := by induction l with | nil => simp only [nil_union, h] | cons _ _ ih => simp only [cons_union, Perm.insert _ ih] theorem Perm.union [BEq α] [LawfulBEq α] {l₁ l₂ t₁ t₂ : List α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∪ t₁ ~ l₂ ∪ t₂ := (p₁.union_right t₁).trans (p₂.union_left l₂) theorem Perm.inter_right [BEq α] (t₁ : List α) : l₁ ~ l₂ → l₁ ∩ t₁ ~ l₂ ∩ t₁ := .filter _ theorem Perm.inter_left [BEq α] [LawfulBEq α] (l : List α) (p : t₁ ~ t₂) : l ∩ t₁ = l ∩ t₂ := filter_congr fun a _ => by simpa using p.mem_iff (a := a) theorem Perm.inter [BEq α] [LawfulBEq α] {l₁ l₂ t₁ t₂ : List α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∩ t₁ ~ l₂ ∩ t₂ := p₂.inter_left l₂ ▸ p₁.inter_right t₁ theorem Perm.flatten_congr : ∀ {l₁ l₂ : List (List α)} (_ : List.Forall₂ (· ~ ·) l₁ l₂), l₁.flatten ~ l₂.flatten | _, _, .nil => .rfl | _ :: _, _ :: _, .cons h₁ h₂ => h₁.append (Perm.flatten_congr h₂) theorem perm_insertP (p : α → Bool) (a l) : insertP p a l ~ a :: l := by induction l with simp [insertP, insertP.loop, cond] | cons _ _ ih => split · exact Perm.refl .. · rw [insertP_loop, reverseAux, reverseAux] exact Perm.trans (Perm.cons _ ih) (Perm.swap ..) theorem Perm.insertP (p : α → Bool) (a) (h : l₁ ~ l₂) : insertP p a l₁ ~ insertP p a l₂ := Perm.trans (perm_insertP ..) <| Perm.trans (Perm.cons _ h) <| Perm.symm (perm_insertP ..) /-! ### idxInj -/ /-- `Subperm.idxInj` is an injective map from `Fin xs.length` to `Fin ys.length` which exists when we have `xs <+~ ys`: conceptually it represents an embedding of one list into the other. For example: ``` (by decide : [1, 0, 1] <+~ [5, 0, 1, 3, 1]).idxInj 1 = 1 ``` -/ def Subperm.idxInj [BEq α] [ReflBEq α] {xs ys : List α} (h : xs <+~ ys) (i : Fin xs.length) : Fin ys.length := ⟨ys.idxOfNth xs[i.1] (xs.countBefore xs[i] i), idxOfNth_lt_length_of_lt_count <| Nat.lt_of_lt_of_le countBefore_lt_count_getElem <| h.count_le _⟩ @[simp, grind =] theorem coe_idxInj [BEq α] [ReflBEq α] {xs ys : List α} {h : xs <+~ ys} {i : Fin xs.length} : (h.idxInj i : Nat) = ys.idxOfNth xs[i] (xs.countBefore xs[i] i) := rfl theorem Subperm.getElem_idxInj_eq_getElem [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs <+~ ys) {i : Fin xs.length} : ys[(h.idxInj i : Nat)] = xs[(i : Nat)] := getElem_idxOfNth_eq theorem Subperm.idxInj_injective [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs <+~ ys) : h.idxInj.Injective := fun _ _ hij => by have H := congrArg (fun i : Fin ys.length => xs.idxOfNth ys[i] (ys.countBefore ys[i] i)) hij grind @[simp] theorem Subperm.idxInj_inj [BEq α] [LawfulBEq α] {xs ys : List α} {h : xs <+~ ys} (i j : Fin xs.length) : h.idxInj i = h.idxInj j ↔ i = j := h.idxInj_injective.eq_iff /-! ### idxBij -/ /-- `Perm.idxBij` is a bijective map from `Fin xs.length` to `Fin ys.length` which exists when we have `xs.Perm ys`: conceptually it represents a permuting of one list into the other. For example: ``` (by decide : [0, 1, 1, 3, 5] ~ [5, 0, 1, 3, 1]).idxBij 2 = 4 ``` -/ def Perm.idxBij [BEq α] [ReflBEq α] {xs ys : List α} (h : xs ~ ys) : Fin xs.length → Fin ys.length := h.subperm.idxInj @[simp, grind =] theorem Perm.subperm_idxBij [BEq α] [ReflBEq α] {xs ys : List α} (h : xs ~ ys) : h.subperm.idxInj = h.idxBij := rfl @[simp, grind =] theorem Perm.coe_idxBij [BEq α] [ReflBEq α] {xs ys : List α} (h : xs ~ ys) {i : Fin xs.length} : (h.idxBij i : Nat) = ys.idxOfNth xs[i] (xs.countBefore xs[i] i) := rfl theorem Perm.getElem_idxBij_eq_getElem [BEq α] [LawfulBEq α] {xs ys : List α} (hxy : xs.Perm ys) (i : Fin xs.length) : ys[(hxy.idxBij i : Nat)] = xs[(i : Nat)] := getElem_idxOfNth_eq theorem Perm.getElem_idxBij_symm_eq_getElem [BEq α] [LawfulBEq α] {xs ys : List α} (hxy : xs.Perm ys) (i : Fin ys.length) : xs[(hxy.symm.idxBij i : Nat)] = ys[(i : Nat)] := getElem_idxOfNth_eq theorem Perm.idxBij_leftInverse_idxBij_symm [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.idxBij.LeftInverse h.symm.idxBij := by grind theorem Perm.idxBij_rightInverse_idxBij_symm [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.idxBij.RightInverse h.symm.idxBij := by grind theorem Perm.idxBij_symm_rightInverse_idxBij [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.symm.idxBij.RightInverse h.idxBij := h.idxBij_leftInverse_idxBij_symm theorem Perm.idxBij_symm_leftInverse_idxBij [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.symm.idxBij.LeftInverse h.idxBij := h.idxBij_rightInverse_idxBij_symm theorem Perm.idxBij_idxBij_symm [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) {i : Fin ys.length} : h.idxBij (h.symm.idxBij i) = i := h.idxBij_leftInverse_idxBij_symm _ theorem Perm.idxBij_symm_idxBij [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) {i : Fin xs.length} : h.symm.idxBij (h.idxBij i) = i := h.idxBij_rightInverse_idxBij_symm _ theorem Perm.idxBij_injective [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.idxBij.Injective := h.idxBij_rightInverse_idxBij_symm.injective theorem Perm.idxBij_surjective [BEq α] [LawfulBEq α] {xs ys : List α} (h : xs ~ ys) : h.idxBij.Surjective := h.idxBij_symm_rightInverse_idxBij.surjective ================================================ FILE: Batteries/Data/List/Scan.lean ================================================ /- Copyright (c) 2014 Parikshit Khanna. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro -/ module public import Batteries.Data.List.Basic public import Batteries.Data.List.Lemmas import Batteries.Util.ProofWanted meta import Batteries.Tactic.Init @[expose] public section /-! # List scan Prove basic results about `List.scanl`, `List.scanr`, `List.scanlM` and `List.scanrM`. -/ namespace List /-! ### partialSums/partialProd -/ @[simp, grind =] theorem length_partialSums [Add α] [Zero α] {l : List α} : l.partialSums.length = l.length + 1 := by simp [partialSums] @[simp] theorem partialSums_ne_nil [Add α] [Zero α] {l : List α} : l.partialSums ≠ [] := by simp [ne_nil_iff_length_pos] @[simp, grind =] theorem partialSums_nil [Add α] [Zero α] : ([] : List α).partialSums = [0] := by simp [partialSums] theorem partialSums_cons [Add α] [Zero α] [Std.Associative (α := α) (· + ·)] [Std.LawfulIdentity (α := α) (· + ·) 0] {l : List α} : (a :: l).partialSums = 0 :: l.partialSums.map (a + ·) := by simp only [partialSums, scanl_cons, Std.LawfulLeftIdentity.left_id, cons.injEq] induction l generalizing a with | nil => simp only [Std.LawfulRightIdentity.right_id, scanl_nil, map_cons, map_nil] | cons b l ih => simp [Std.LawfulLeftIdentity.left_id, Std.LawfulRightIdentity.right_id] rw [ih (a := b), ih (a := a + b), map_map] congr; funext; simp [Std.Associative.assoc] theorem partialSums_append [Add α] [Zero α] [Std.Associative (α := α) (· + ·)] [Std.LawfulIdentity (α := α) (· + ·) 0] {l₁ l₂ : List α} : (l₁ ++ l₂).partialSums = l₁.partialSums ++ l₂.partialSums.tail.map (l₁.sum + · ) := by induction l₁ generalizing l₂ with | nil => cases l₂ <;> simp [partialSums, Std.LawfulLeftIdentity.left_id] | cons _ _ ih => simp only [cons_append, partialSums_cons, ih, map_tail, map_append, map_map, sum_cons, cons.injEq, append_cancel_left_eq, true_and] congr 2; funext; simp [Std.Associative.assoc] @[simp, grind =] theorem getElem_partialSums [Add α] [Zero α] [Std.Associative (α := α) (· + ·)] [Std.LawfulIdentity (α := α) (· + ·) 0] {l : List α} (h : i < l.partialSums.length) : l.partialSums[i] = (l.take i).sum := by simp [partialSums, sum_eq_foldl] @[simp, grind =] theorem getElem?_partialSums [Add α] [Zero α] [Std.Associative (α := α) (· + ·)] [Std.LawfulIdentity (α := α) (· + ·) 0] {l : List α} : l.partialSums[i]? = if i ≤ l.length then some (l.take i).sum else none := by split <;> grind @[simp, grind =] theorem take_partialSums [Add α] [Zero α] {l : List α} : l.partialSums.take (i+1) = (l.take i).partialSums := by simp [partialSums, take_scanl] @[simp, grind =] theorem length_partialProds [Mul α] [One α] {l : List α} : l.partialProds.length = l.length + 1 := by simp [partialProds] @[simp, grind =] theorem partialProds_nil [Mul α] [One α] : ([] : List α).partialProds = [1] := by simp [partialProds] theorem partialProds_cons [Mul α] [One α] [Std.Associative (α := α) (· * ·)] [Std.LawfulIdentity (α := α) (· * ·) 1] {l : List α} : (a :: l).partialProds = 1 :: l.partialProds.map (a * ·) := by simp only [partialProds, scanl_cons, Std.LawfulLeftIdentity.left_id, cons.injEq] induction l generalizing a with | nil => simp only [Std.LawfulRightIdentity.right_id, scanl_nil, map_cons, map_nil] | cons b l ih => simp [Std.LawfulLeftIdentity.left_id, Std.LawfulRightIdentity.right_id] rw [ih (a := b), ih (a := a * b), map_map] congr; funext; simp [Std.Associative.assoc] theorem partialProds_append [Mul α] [One α] [Std.Associative (α := α) (· * ·)] [Std.LawfulIdentity (α := α) (· * ·) 1] {l₁ l₂ : List α} : (l₁ ++ l₂).partialProds = l₁.partialProds ++ l₂.partialProds.tail.map (l₁.prod * · ) := by induction l₁ generalizing l₂ with | nil => cases l₂ <;> simp [partialProds, Std.LawfulLeftIdentity.left_id] | cons _ _ ih => simp only [cons_append, partialProds_cons, ih, map_tail, map_append, map_map, prod_cons, cons.injEq, append_cancel_left_eq, true_and] congr 2; funext; simp [Std.Associative.assoc] @[simp, grind =] theorem getElem_partialProds [Mul α] [One α] [Std.Associative (α := α) (· * ·)] [Std.LawfulIdentity (α := α) (· * ·) 1] {l : List α} (h : i < l.partialProds.length) : l.partialProds[i] = (l.take i).prod := by simp [partialProds, prod_eq_foldl] @[simp, grind =] theorem getElem?_partialProds [Mul α] [One α] [Std.Associative (α := α) (· * ·)] [Std.LawfulIdentity (α := α) (· * ·) 1] {l : List α} : l.partialProds[i]? = if i ≤ l.length then some (l.take i).prod else none := by split <;> grind @[simp, grind =] theorem take_partialProds [Mul α] [One α] {l : List α} : l.partialProds.take (i+1) = (l.take i).partialProds := by simp [partialProds, take_scanl] /-! ### flatten -/ theorem length_flatten_mem_partialSums_map_length (L : List (List α)) : L.flatten.length ∈ (L.map length).partialSums := by induction L with | nil => simp | cons l L ih => simp [flatten_cons, partialSums_cons] right simpa using ih theorem getElem_flatten_aux₁ (L : List (List α)) (i : Nat) (h : i < L.flatten.length) : (L.map length).partialSums.findIdx (· > i) - 1 < L.length := by have := findIdx_lt_length_of_exists (xs := (L.map length).partialSums) (p := fun x => decide (x > i)) specialize this ⟨L.flatten.length, length_flatten_mem_partialSums_map_length L, by grind⟩ simp at this simp have : 0 < findIdx (fun x => decide (i < x)) (map length L).partialSums := by by_contra w simp at w omega theorem getElem_flatten_aux₂ (L : List (List α)) (i : Nat) (h : i < L.flatten.length) : let j := (L.map length).partialSums.findIdx (· > i) - 1 have hj : j < L.length := getElem_flatten_aux₁ L i h let k := i - (L.take j).flatten.length k < L[j].length := by induction L generalizing i with | nil => simp at h | cons l L ih => simp only [map_cons, partialSums_cons, findIdx_cons, Nat.not_lt_zero, decide_false, findIdx_map, Function.comp_def, cond_false, Nat.add_one_sub_one, length_flatten, map_take, getElem_cons] split <;> rename_i h' · simp only [h', take_zero, sum_nil, Nat.sub_zero] rw [findIdx_eq (by simp)] at h' simp_all · have : l.length ≤ i := by rw [findIdx_eq (by simp)] at h' simp_all rw [take_cons (by grind)] specialize ih (i - l.length) (by grind) have p : ∀ x, i - l.length < x ↔ i < l.length + x := by grind simp only [p, length_flatten, map_take] at ih grind /-- Indexing into a flattened list: `L.flatten[i]` equals `L[j][k]` where `j` is the sublist index and `k` is the offset within that sublist. The indices are computed as: - `j` is one less than where the cumulative sum first exceeds `i` - `k` is `i` minus the total length of the first `j` sublists This theorem states that these indices are in range and the equality holds. -/ theorem getElem_flatten (L : List (List α)) (i : Nat) (h : i < L.flatten.length) : L.flatten[i] = let j := (L.map length).partialSums.findIdx (· > i) - 1 have hj : j < L.length := getElem_flatten_aux₁ L i h let k := i - (L.take j).flatten.length have hk : k < L[j].length := getElem_flatten_aux₂ L i h L[j][k] := by induction L generalizing i with | nil => simp at h | cons l L ih => simp only [flatten_cons, getElem_append] split <;> rename_i h' · have : findIdx (fun x => decide (x > i)) (map length (l :: L)).partialSums = 1 := by simp [partialSums_cons, findIdx_cons] rw [findIdx_eq] <;> grind simp only [this] simp · rw [ih] have : findIdx (fun x => decide (x > i)) (map length (l :: L)).partialSums = findIdx (fun x => decide (x > i - l.length)) (map length L).partialSums + 1 := by simp [partialSums_cons, findIdx_cons, Function.comp_def] congr funext x grind simp only [this] simp only [getElem_cons] split <;> rename_i h'' · simp [findIdx_eq] at h'' · congr 1 rw [take_cons] · simp omega · simp /-- Taking the first `i` elements of a flattened list can be expressed as the flattening of the first `j` complete sublists, plus the first `k` elements of the `j`-th sublist. The indices are computed as: - `j` is one less than where the cumulative sum first exceeds `i` - `k` is `i` minus the total length of the first `j` sublists -/ proof_wanted take_flatten (L : List (List α)) (i : Nat) : let j := (L.map length).partialSums.findIdx (· > i) - 1 let k := i - (L.take j).flatten.length L.flatten.take i = (L.take j).flatten ++ (L[j]?.getD []).take k ================================================ FILE: Batteries/Data/List.lean ================================================ module public import Batteries.Data.List.ArrayMap public import Batteries.Data.List.Basic public import Batteries.Data.List.Count public import Batteries.Data.List.Init.Lemmas public import Batteries.Data.List.Lemmas public import Batteries.Data.List.Matcher public import Batteries.Data.List.Monadic public import Batteries.Data.List.Pairwise public import Batteries.Data.List.Perm public import Batteries.Data.List.Scan ================================================ FILE: Batteries/Data/MLList/Basic.lean ================================================ /- Copyright (c) 2018 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Keeley Hoek, Simon Hudon, Kim Morrison -/ module public import Batteries.Control.AlternativeMonad public section /-! # Monadic lazy lists. Lazy lists with "laziness" controlled by an arbitrary monad. -/ /-! In an initial section we describe the specification of `MLList`, and provide a private unsafe implementation, and then a public `opaque` wrapper of this implementation, satisfying the specification. -/ namespace MLList private structure Spec (m : Type u → Type u) where listM : Type u → Type u nil : listM α cons : α → listM α → listM α thunk : (Unit → listM α) → listM α squash : (Unit → m (listM α)) → listM α uncons : [Monad m] → listM α → m (Option (α × listM α)) uncons? : listM α → Option (Option (α × listM α)) private instance : Nonempty (Spec m) := .intro { listM := fun _ => PUnit nil := ⟨⟩ cons := fun _ _ => ⟨⟩ thunk := fun _ => ⟨⟩ squash := fun _ => ⟨⟩ uncons := fun _ => pure none uncons? := fun _ => none } private unsafe inductive MLListImpl (m : Type u → Type u) (α : Type u) : Type u | nil : MLListImpl m α | cons : α → MLListImpl m α → MLListImpl m α | thunk : Thunk (MLListImpl m α) → MLListImpl m α | squash : (Unit → m (MLListImpl m α)) → MLListImpl m α private unsafe def unconsImpl {m : Type u → Type u} [Monad m] : MLListImpl m α → m (Option (α × MLListImpl m α)) | .nil => pure none | .thunk t => unconsImpl t.get | .squash t => t () >>= unconsImpl | .cons x xs => return (x, xs) private unsafe def uncons?Impl : MLListImpl m α → Option (Option (α × MLListImpl m α)) | .nil => pure none | .cons x xs => pure (x, xs) | _ => none @[inline] private unsafe def specImpl (m) : Spec m where listM := MLListImpl m nil := .nil cons := .cons thunk f := .thunk (.mk f) squash := .squash uncons := unconsImpl uncons? := uncons?Impl @[implemented_by specImpl] private opaque spec (m) : MLList.Spec m end MLList /-- A monadic lazy list, controlled by an arbitrary monad. -/ def MLList (m : Type u → Type u) (α : Type u) : Type u := (MLList.spec m).listM α namespace MLList /-- The empty `MLList`. -/ @[inline] def nil : MLList m α := (MLList.spec m).nil /-- Constructs a `MLList` from head and tail. -/ @[inline] def cons : α → MLList m α → MLList m α := (MLList.spec m).cons /-- Embed a non-monadic thunk as a lazy list. -/ @[inline] def thunk : (Unit → MLList m α) → MLList m α := (MLList.spec m).thunk /-- Lift a monadic lazy list inside the monad to a monadic lazy list. -/ def squash : (Unit → m (MLList m α)) → MLList m α := (MLList.spec m).squash /-- Deconstruct a `MLList`, returning inside the monad an optional pair `α × MLList m α` representing the head and tail of the list. -/ @[inline] def uncons [Monad m] : MLList.{u} m α → m (Option (α × MLList m α)) := (MLList.spec m).uncons /-- Try to deconstruct a `MLList`, returning an optional pair `α × MLList m α` representing the head and tail of the list if it is already evaluated, and `none` otherwise. -/ @[inline] def uncons? : MLList.{u} m α → Option (Option (α × MLList m α)) := (MLList.spec m).uncons? instance : EmptyCollection (MLList m α) := ⟨nil⟩ instance : Inhabited (MLList m α) := ⟨nil⟩ private local instance [Monad n] : Inhabited (δ → (α → δ → n (ForInStep δ)) → n δ) where default d _ := pure d in /-- The implementation of `ForIn`, which enables `for a in L do ...` notation. -/ @[specialize] protected partial def forIn [Monad m] [Monad n] [MonadLiftT m n] (as : MLList m α) (init : δ) (f : α → δ → n (ForInStep δ)) : n δ := do match ← as.uncons with | none => pure init | some (a, t) => match (← f a init) with | ForInStep.done d => pure d | ForInStep.yield d => t.forIn d f instance [Monad m] [Monad n] [MonadLiftT m n] : ForIn n (MLList m α) α where forIn := MLList.forIn /-- Construct a singleton monadic lazy list from a single monadic value. -/ def singletonM [Monad m] (x : m α) : MLList m α := .squash fun _ => do return .cons (← x) .nil /-- Construct a singleton monadic lazy list from a single value. -/ def singleton [Monad m] (x : α) : MLList m α := .singletonM (pure x) /-- Construct a `MLList` recursively. Failures from `f` will result in `uncons` failing. -/ partial def fix [Monad m] (f : α → m α) (x : α) : MLList m α := cons x <| squash fun _ => fix f <$> f x /-- Constructs an `MLList` recursively, with state in `α`, recording terms from `β`. If `f` returns `none` the list will terminate. Variant of `MLList.fix?` that allows returning values of a different type. -/ partial def fix?' [Monad m] (f : α → m (Option (β × α))) (init : α) : MLList m β := squash fun _ => do match ← f init with | none => pure .nil | some (b, a) => pure (.cons b (fix?' f a)) /-- Constructs an `MLList` recursively. If `f` returns `none` the list will terminate. Returns the initial value as the first element. -/ partial def fix? [Monad m] (f : α → m (Option α)) (x : α) : MLList m α := cons x <| squash fun _ => do match ← f x with | none => return nil | some x' => return fix? f x' /-- Construct a `MLList` by iteration. (`m` must be a stateful monad for this to be useful.) -/ partial def iterate [Monad m] (f : m α) : MLList m α := squash fun _ => return cons (← f) (iterate f) /-- Repeatedly apply a function `f : α → m (α × List β)` to an initial `a : α`, accumulating the elements of the resulting `List β` as a single monadic lazy list. (This variant allows starting with a specified `List β` of elements, as well. )-/ partial def fixlWith [Monad m] {α β : Type u} (f : α → m (α × List β)) (s : α) (l : List β) : MLList m β := thunk fun _ => match l with | b :: rest => cons b (fixlWith f s rest) | [] => squash fun _ => do let (s', l) ← f s match l with | b :: rest => pure <| cons b (fixlWith f s' rest) | [] => pure <| fixlWith f s' [] /-- Repeatedly apply a function `f : α → m (α × List β)` to an initial `a : α`, accumulating the elements of the resulting `List β` as a single monadic lazy list. -/ def fixl [Monad m] {α β : Type u} (f : α → m (α × List β)) (s : α) : MLList m β := fixlWith f s [] /-- Compute, inside the monad, whether a `MLList` is empty. -/ def isEmpty [Monad m] (xs : MLList m α) : m (ULift Bool) := (ULift.up ∘ Option.isNone) <$> uncons xs /-- Convert a `List` to a `MLList`. -/ def ofList : List α → MLList m α | [] => nil | h :: t => cons h (thunk fun _ => ofList t) /-- Convert a `List` of values inside the monad into a `MLList`. -/ def ofListM [Monad m] : List (m α) → MLList m α | [] => nil | h :: t => squash fun _ => return cons (← h) (ofListM t) /-- Extract a list inside the monad from a `MLList`. -/ partial def force [Monad m] (L : MLList m α) : m (List α) := do match ← L.uncons with | none => pure [] | some (x, xs) => return x :: (← xs.force) /-- Extract an array inside the monad from a `MLList`. -/ def asArray [Monad m] (L : MLList m α) : m (Array α) := do let mut r := #[] for a in L do r := r.push a return r /-- Performs a monadic case distinction on a `MLList` when the motive is a `MLList` as well. -/ @[specialize] def casesM [Monad m] (xs : MLList m α) (hnil : Unit → m (MLList m β)) (hcons : α → MLList m α → m (MLList m β)) : MLList m β := squash fun _ => do match ← xs.uncons with | none => hnil () | some (x, xs) => hcons x xs /-- Performs a case distinction on a `MLList` when the motive is a `MLList` as well. (We need to be in a monadic context to distinguish a nil from a cons.) -/ @[specialize] def cases [Monad m] (xs : MLList m α) (hnil : Unit → MLList m β) (hcons : α → MLList m α → MLList m β) : MLList m β := match xs.uncons? with | none => xs.casesM (fun _ => return hnil ()) (fun x xs => return hcons x xs) | some none => thunk hnil | some (some (x, xs)) => thunk fun _ => hcons x xs /-- Gives the monadic lazy list consisting all of folds of a function on a given initial element. Thus `[a₀, a₁, ...].foldsM f b` will give `[b, ← f b a₀, ← f (← f b a₀) a₁, ...]`. -/ partial def foldsM [Monad m] (f : β → α → m β) (init : β) (L : MLList m α) : MLList m β := cons init <| squash fun _ => do match ← L.uncons with | none => return nil | some (x, xs) => return foldsM f (← f init x) xs /-- Gives the monadic lazy list consisting all of folds of a function on a given initial element. Thus `[a₀, a₁, ...].foldsM f b` will give `[b, f b a₀, f (f b a₀) a₁, ...]`. -/ def folds [Monad m] (f : β → α → β) (init : β) (L : MLList m α) : MLList m β := L.foldsM (fun b a => pure (f b a)) init /-- Take the first `n` elements, as a list inside the monad. -/ partial def takeAsList [Monad m] (xs : MLList m α) (n : Nat) : m (List α) := go n [] xs where /-- Implementation of `MLList.takeAsList`. -/ go (r : Nat) (acc : List α) (xs : MLList m α) : m (List α) := match r with | 0 => pure acc.reverse | r+1 => do match ← xs.uncons with | none => pure acc.reverse | some (x, xs) => go r (x :: acc) xs /-- Take the first `n` elements, as an array inside the monad. -/ partial def takeAsArray [Monad m] (xs : MLList m α) (n : Nat) : m (Array α) := go n #[] xs where /-- Implementation of `MLList.takeAsArray`. -/ go (r : Nat) (acc : Array α) (xs : MLList m α) : m (Array α) := match r with | 0 => pure acc | r+1 => do match ← xs.uncons with | none => pure acc | some (x, xs) => go r (acc.push x) xs /-- Take the first `n` elements. -/ partial def take [Monad m] (xs : MLList m α) : Nat → MLList m α | 0 => nil | n+1 => xs.cases (fun _ => nil) fun h l => cons h (l.take n) /-- Drop the first `n` elements. -/ def drop [Monad m] (xs : MLList m α) : Nat → MLList m α | 0 => xs | n+1 => xs.cases (fun _ => nil) fun _ l => l.drop n /-- Apply a function which returns values in the monad to every element of a `MLList`. -/ partial def mapM [Monad m] (f : α → m β) (xs : MLList m α) : MLList m β := xs.cases (fun _ => nil) fun x xs => squash fun _ => return cons (← f x) (xs.mapM f) /-- Apply a function to every element of a `MLList`. -/ def map [Monad m] (f : α → β) (L : MLList m α) : MLList m β := L.mapM fun a => pure (f a) /-- Filter a `MLList` using a monadic function. -/ partial def filterM [Monad m] (p : α → m (ULift Bool)) (L : MLList m α) : MLList m α := L.casesM (fun _ => pure nil) fun x xs => return if (← p x).down then cons x (filterM p xs) else filterM p xs /-- Filter a `MLList`. -/ def filter [Monad m] (p : α → Bool) (L : MLList m α) : MLList m α := L.filterM fun a => pure <| .up (p a) /-- Filter and transform a `MLList` using a function that returns values inside the monad. -/ -- Note that the type signature has changed since Lean 3, when we allowed `f` to fail. -- Use `try?` from `Mathlib.Control.Basic` to lift a possibly failing function to `Option`. partial def filterMapM [Monad m] (f : α → m (Option β)) (xs : MLList m α) : MLList m β := xs.casesM (fun _ => pure nil) fun x xs => do match ← f x with | none => return xs.filterMapM f | some a => return cons a (xs.filterMapM f) /-- Filter and transform a `MLList` using an `Option` valued function. -/ def filterMap [Monad m] (f : α → Option β) : MLList m α → MLList m β := filterMapM fun a => do pure (f a) /-- Take the initial segment of the lazy list, until the function `f` first returns `false`. -/ partial def takeWhileM [Monad m] (f : α → m (ULift Bool)) (L : MLList m α) : MLList m α := L.casesM (fun _ => pure nil) fun x xs => return if !(← f x).down then nil else cons x (xs.takeWhileM f) /-- Take the initial segment of the lazy list, until the function `f` first returns `false`. -/ def takeWhile [Monad m] (f : α → Bool) : MLList m α → MLList m α := takeWhileM fun a => pure (.up (f a)) /-- Concatenate two monadic lazy lists. -/ partial def append [Monad m] (xs : MLList m α) (ys : Unit → MLList m α) : MLList m α := xs.cases ys fun x xs => cons x (append xs ys) /-- Join a monadic lazy list of monadic lazy lists into a single monadic lazy list. -/ partial def join [Monad m] (xs : MLList m (MLList m α)) : MLList m α := xs.cases (fun _ => nil) fun x xs => append x (fun _ => join xs) /-- Enumerate the elements of a monadic lazy list, starting at a specified offset. -/ partial def enumFrom [Monad m] (n : Nat) (xs : MLList m α) : MLList m (Nat × α) := xs.cases (fun _ => nil) fun x xs => cons (n, x) (xs.enumFrom (n+1)) /-- Enumerate the elements of a monadic lazy list. -/ def enum [Monad m] : MLList m α → MLList m (Nat × α) := enumFrom 0 /-- The infinite monadic lazy list of natural numbers.-/ def range [Monad m] : MLList m Nat := MLList.fix (fun n => pure (n + 1)) 0 /-- Iterate through the elements of `Fin n`. -/ partial def fin (n : Nat) : MLList m (Fin n) := go 0 where /-- Implementation of `MLList.fin`. -/ go (i : Nat) : MLList m (Fin n) := if h : i < n then cons ⟨i, h⟩ (thunk fun _ => go (i+1)) else nil /-- Convert an array to a monadic lazy list. -/ partial def ofArray {α : Type} (L : Array α) : MLList m α := go 0 where /-- Implementation of `MLList.ofArray`. -/ go (i : Nat) : MLList m α := if h : i < L.size then cons L[i] (thunk fun _ => go (i+1)) else nil /-- Group the elements of a lazy list into chunks of a given size. If the lazy list is finite, the last chunk may be smaller (possibly even length 0). -/ partial def chunk [Monad m] (L : MLList m α) (n : Nat) : MLList m (Array α) := go n #[] L where /-- Implementation of `MLList.chunk`. -/ go (r : Nat) (acc : Array α) (M : MLList m α) : MLList m (Array α) := match r with | 0 => cons acc (thunk fun _ => go n #[] M) | r+1 => squash fun _ => do match ← M.uncons with | none => return cons acc nil | some (a, M') => return go r (acc.push a) M' /-- Add one element to the end of a monadic lazy list. -/ def concat [Monad m] (L : MLList m α) (a : α) : MLList m α := L.append (fun _ => cons a nil) /-- Take the product of two monadic lazy lists. -/ partial def zip [Monad m] (L : MLList m α) (M : MLList m β) : MLList.{u} m (α × β) := L.cases (fun _ => nil) fun a L => M.cases (fun _ => nil) fun b M => cons (a, b) (L.zip M) /-- Apply a function returning a monadic lazy list to each element of a monadic lazy list, joining the results. -/ partial def bind [Monad m] (xs : MLList m α) (f : α → MLList m β) : MLList m β := xs.cases (fun _ => nil) fun x xs => match xs.uncons? with | some none => f x | _ => append (f x) (fun _ => bind xs f) /-- Convert any value in the monad to the singleton monadic lazy list. -/ def monadLift [Monad m] (x : m α) : MLList m α := squash fun _ => return cons (← x) nil /-- Lift the monad of a lazy list. -/ partial def liftM [Monad m] [Monad n] [MonadLiftT m n] (L : MLList m α) : MLList n α := squash fun _ => return match ← (uncons L : m _) with | none => nil | some (a, L') => cons a L'.liftM /-- Given a lazy list in a state monad, run it on some initial state, recording the states. -/ partial def runState [Monad m] (L : MLList (StateT.{u} σ m) α) (s : σ) : MLList m (α × σ) := squash fun _ => return match ← (uncons L).run s with | (none, _) => nil | (some (a, L'), s') => cons (a, s') (L'.runState s') /-- Given a lazy list in a state monad, run it on some initial state. -/ def runState' [Monad m] (L : MLList (StateT.{u} σ m) α) (s : σ) : MLList m α := L.runState s |>.map (·.1) /-- Run a lazy list in a `ReaderT` monad on some fixed state. -/ partial def runReader [Monad m] (L : MLList (ReaderT.{u, u} ρ m) α) (r : ρ) : MLList m α := squash fun _ => return match ← (uncons L).run r with | none => nil | some (a, L') => cons a (L'.runReader r) /-- Run a lazy list in a `StateRefT'` monad on some initial state. -/ partial def runStateRef [Monad m] [MonadLiftT (ST ω) m] (L : MLList (StateRefT' ω σ m) α) (s : σ) : MLList m α := squash fun _ => return match ← (uncons L).run s with | (none, _) => nil | (some (a, L'), s') => cons a (L'.runStateRef s') /-- Return the head of a monadic lazy list if it exists, as an `Option` in the monad. -/ def head? [Monad m] (L : MLList m α) : m (Option α) := return (← L.uncons).map (·.1) /-- Take the initial segment of the lazy list, up to and including the first place where `f` gives `true`. -/ partial def takeUpToFirstM [Monad m] (L : MLList m α) (f : α → m (ULift Bool)) : MLList m α := L.casesM (fun _ => pure nil) fun x xs => return cons x <| if (← (f x)).down then nil else xs.takeUpToFirstM f /-- Take the initial segment of the lazy list, up to and including the first place where `f` gives `true`. -/ def takeUpToFirst [Monad m] (L : MLList m α) (f : α → Bool) : MLList m α := L.takeUpToFirstM fun a => pure (.up (f a)) /-- Gets the last element of a monadic lazy list, as an option in the monad. This will run forever if the list is infinite. -/ partial def getLast? [Monad m] (L : MLList m α) : m (Option α) := do match ← uncons L with | none => return none | some (x, xs) => aux x xs where /-- Implementation of `MLList.aux`. -/ aux (x : α) (L : MLList m α) : m (Option α) := do match ← uncons L with | none => return some x | some (y, ys) => aux y ys /-- Gets the last element of a monadic lazy list, or the default value if the list is empty. This will run forever if the list is infinite. -/ partial def getLast! [Monad m] [Inhabited α] (L : MLList m α) : m α := Option.get! <$> L.getLast? /-- Folds a binary function across a monadic lazy list, from an initial starting value. This will run forever if the list is infinite. -/ partial def foldM [Monad m] (f : β → α → m β) (init : β) (L : MLList m α) : m β := return (← L.foldsM f init |>.getLast?).getD init -- `foldsM` is always non-empty, anyway. /-- Folds a binary function across a monadic lazy list, from an initial starting value. This will run forever if the list is infinite. -/ partial def fold [Monad m] (f : β → α → β) (init : β) (L : MLList m α) : m β := L.foldM (fun b a => pure (f b a)) init /-- Return the head of a monadic lazy list, as a value in the monad. Fails if the list is empty. -/ def head [AlternativeMonad m] (L : MLList m α) : m α := do let some (r, _) ← L.uncons | failure return r /-- Apply a function returning values inside the monad to a monadic lazy list, returning only the first successful result. -/ def firstM [AlternativeMonad m] (L : MLList m α) (f : α → m (Option β)) : m β := (L.filterMapM f).head /-- Return the first value on which a predicate returns true. -/ def first [AlternativeMonad m] (L : MLList m α) (p : α → Bool) : m α := (L.filter p).head instance [Monad m] : AlternativeMonad (MLList m) where pure a := cons a nil map := map bind := bind failure := nil orElse := MLList.append instance [Monad m] : MonadLift m (MLList m) where monadLift := monadLift ================================================ FILE: Batteries/Data/MLList/Heartbeats.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Data.MLList.Basic public import Lean.Util.Heartbeats @[expose] public section /-! # Truncate a `MLList` when running out of available heartbeats. -/ open Lean open Lean.Core (CoreM) /-- Take an initial segment of a monadic lazy list, stopping when there is less than `percent` of the remaining allowed heartbeats. If `getMaxHeartbeats` returns `0`, then this passes through the original list unmodified. The `initial` heartbeat counter is recorded when the first element of the list is requested. Then each time an element is requested from the wrapped list the heartbeat counter is checked, and if `current * 100 / initial < percent` then that element is returned, but no further elements. -/ def MLList.whileAtLeastHeartbeatsPercent [Monad m] [MonadLiftT CoreM m] (L : MLList m α) (percent : Nat := 10) : MLList m α := MLList.squash fun _ => do if (← getMaxHeartbeats) = 0 then do return L let initialHeartbeats ← getRemainingHeartbeats return L.takeUpToFirstM fun _ => do pure <| .up <| (← getRemainingHeartbeats) * 100 / initialHeartbeats < percent ================================================ FILE: Batteries/Data/MLList/IO.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Lean.System.IO public import Batteries.Data.MLList.Basic @[expose] public section /-! # IO operations using monadic lazy lists. -/ namespace MLList /-- Give a list of tasks, return the monadic lazy list which returns the values as they become available. -/ def ofTaskList (tasks : List (Task α)) : MLList BaseIO α := fix?' (init := tasks) fun t => do if h : 0 < t.length then some <$> IO.waitAny' t h else pure none ================================================ FILE: Batteries/Data/MLList.lean ================================================ module public import Batteries.Data.MLList.Basic public import Batteries.Data.MLList.Heartbeats public import Batteries.Data.MLList.IO ================================================ FILE: Batteries/Data/NameSet.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Lean.Data.NameMap.Basic @[expose] public section namespace Lean.NameSet instance : Singleton Name NameSet where singleton := fun n => (∅ : NameSet).insert n instance : Union NameSet where union := fun s t => s.foldl (fun t n => t.insert n) t instance : Inter NameSet where inter := fun s t => s.foldl (fun r n => if t.contains n then r.insert n else r) {} instance : SDiff NameSet where sdiff := fun s t => t.foldl (fun s n => s.erase n) s end Lean.NameSet ================================================ FILE: Batteries/Data/Nat/Basic.lean ================================================ /- Copyright (c) 2016 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro -/ module @[expose] public section namespace Nat /-- Recursor identical to `Nat.recOn` but uses notations `0` for `Nat.zero` and `·+1` for `Nat.succ` -/ @[elab_as_elim] protected def recAuxOn {motive : Nat → Sort _} (t : Nat) (zero : motive 0) (succ : ∀ n, motive n → motive (n+1)) : motive t := Nat.recAux zero succ t /-- Strong recursor for `Nat` -/ @[elab_as_elim] protected def strongRec {motive : Nat → Sort _} (ind : ∀ n, (∀ m, m < n → motive m) → motive n) (t : Nat) : motive t := ind t fun m _ => Nat.strongRec ind m /-- Strong recursor via a `Nat`-valued measure -/ @[elab_as_elim] def strongRecMeasure (f : α → Nat) {motive : α → Sort _} (ind : ∀ x, (∀ y, f y < f x → motive y) → motive x) (x : α) : motive x := ind x fun y _ => strongRecMeasure f ind y termination_by f x /-- Simple diagonal recursor for `Nat` -/ @[elab_as_elim] protected def recDiagAux {motive : Nat → Nat → Sort _} (zero_left : ∀ n, motive 0 n) (zero_right : ∀ m, motive m 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) : (m n : Nat) → motive m n | 0, _ => zero_left _ | _, 0 => zero_right _ | _+1, _+1 => succ_succ _ _ (Nat.recDiagAux zero_left zero_right succ_succ _ _) /-- Diagonal recursor for `Nat` -/ @[elab_as_elim] protected def recDiag {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) : (m n : Nat) → motive m n := Nat.recDiagAux left right succ_succ where /-- Left leg for `Nat.recDiag` -/ left : ∀ n, motive 0 n | 0 => zero_zero | _+1 => zero_succ _ (left _) /-- Right leg for `Nat.recDiag` -/ right : ∀ m, motive m 0 | 0 => zero_zero | _+1 => succ_zero _ (right _) /-- Diagonal recursor for `Nat` -/ @[elab_as_elim] protected def recDiagOn {motive : Nat → Nat → Sort _} (m n : Nat) (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) : motive m n := Nat.recDiag zero_zero zero_succ succ_zero succ_succ m n /-- Diagonal recursor for `Nat` -/ @[elab_as_elim] protected def casesDiagOn {motive : Nat → Nat → Sort _} (m n : Nat) (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 (n+1)) (succ_zero : ∀ m, motive (m+1) 0) (succ_succ : ∀ m n, motive (m+1) (n+1)) : motive m n := Nat.recDiag zero_zero (fun _ _ => zero_succ _) (fun _ _ => succ_zero _) (fun _ _ _ => succ_succ _ _) m n /-- Integer square root function. Implemented via Newton's method. -/ def sqrt (n : Nat) : Nat := if n ≤ 1 then n else iter n (1 <<< ((n.log2 / 2) + 1)) where /-- Auxiliary for `sqrt`. If `guess` is greater than the integer square root of `n`, returns the integer square root of `n`. -/ iter (n guess : Nat) : Nat := let next := (guess + n / guess) / 2 if _h : next < guess then iter n next else guess termination_by guess /-- Construct a natural number from a sequence of bits using little endian convention. -/ @[inline] def ofBits (f : Fin n → Bool) : Nat := Fin.foldr n (fun i v => 2 * v + (f i).toNat) 0 -- Forward port of lean4#10739 instance {n : Nat} : NeZero (n^0) := ⟨Nat.one_ne_zero⟩ ================================================ FILE: Batteries/Data/Nat/Bisect.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Batteries.Tactic.Basic @[expose] public section namespace Nat /-- Average of two natural numbers rounded toward zero. -/ abbrev avg (a b : Nat) := (a + b) / 2 theorem avg_comm (a b : Nat) : avg a b = avg b a := by rw [avg, Nat.add_comm] theorem avg_le_left (h : b ≤ a) : avg a b ≤ a := by apply Nat.div_le_of_le_mul; simp +arith [*] theorem avg_le_right (h : a ≤ b) : avg a b ≤ b := by apply Nat.div_le_of_le_mul; simp +arith [*] theorem avg_lt_left (h : b < a) : avg a b < a := by apply Nat.div_lt_of_lt_mul; omega theorem avg_lt_right (h : a < b) : avg a b < b := by apply Nat.div_lt_of_lt_mul; omega theorem le_avg_left (h : a ≤ b) : a ≤ avg a b := by apply (Nat.le_div_iff_mul_le Nat.zero_lt_two).mpr; simp +arith [*] theorem le_avg_right (h : b ≤ a) : b ≤ avg a b := by apply (Nat.le_div_iff_mul_le Nat.zero_lt_two).mpr; simp +arith [*] theorem le_add_one_of_avg_eq_left (h : avg a b = a) : b ≤ a + 1 := by cases Nat.lt_or_ge b (a+2) with | inl hlt => exact Nat.le_of_lt_add_one hlt | inr hge => absurd Nat.lt_irrefl a conv => rhs; rw [← h] rw [← Nat.add_one_le_iff, Nat.le_div_iff_mul_le Nat.zero_lt_two] omega theorem le_add_one_of_avg_eq_right (h : avg a b = b) : a ≤ b + 1 := by cases Nat.lt_or_ge a (b+2) with | inl hlt => exact Nat.le_of_lt_add_one hlt | inr hge => absurd Nat.lt_irrefl b conv => rhs; rw [← h] rw [← Nat.add_one_le_iff, Nat.le_div_iff_mul_le Nat.zero_lt_two] omega /-- Given natural numbers `a < b` such that `p a = true` and `p b = false`, `bisect` finds a natural number `a ≤ c < b` such that `p c = true` and `p (c+1) = false`. -/ def bisect {p : Nat → Bool} (h : start < stop) (hstart : p start = true) (hstop : p stop = false) := let mid := avg start stop have hmidstop : mid < stop := by apply Nat.div_lt_of_lt_mul; omega if hstartmid : start < mid then match hmid : p mid with | false => bisect hstartmid hstart hmid | true => bisect hmidstop hmid hstop else mid termination_by stop - start theorem bisect_lt_stop {p : Nat → Bool} (h : start < stop) (hstart : p start = true) (hstop : p stop = false) : bisect h hstart hstop < stop := by unfold bisect simp only; split · split · next h' _ => have : avg start stop - start < stop - start := by apply Nat.sub_lt_sub_right · exact Nat.le_of_lt h' · exact Nat.avg_lt_right h apply Nat.lt_trans · exact bisect_lt_stop .. · exact avg_lt_right h · exact bisect_lt_stop .. · exact avg_lt_right h theorem start_le_bisect {p : Nat → Bool} (h : start < stop) (hstart : p start = true) (hstop : p stop = false) : start ≤ bisect h hstart hstop := by unfold bisect simp only; split · split · next h' _ => have : avg start stop - start < stop - start := by apply Nat.sub_lt_sub_right · exact Nat.le_of_lt h' · exact avg_lt_right h exact start_le_bisect .. · next h' _ => apply Nat.le_trans · exact Nat.le_of_lt h' · exact start_le_bisect .. · exact le_avg_left (Nat.le_of_lt h) theorem bisect_true {p : Nat → Bool} (h : start < stop) (hstart : p start = true) (hstop : p stop = false) : p (bisect h hstart hstop) = true := by unfold bisect simp only; split · split · have : avg start stop - start < stop - start := by apply Nat.sub_lt_sub_right · exact Nat.le_avg_left (Nat.le_of_lt h) · exact Nat.avg_lt_right h exact bisect_true .. · exact bisect_true .. · next h' => rw [← hstart]; congr apply Nat.le_antisymm · exact Nat.le_of_not_gt h' · exact Nat.le_avg_left (Nat.le_of_lt h) theorem bisect_add_one_false {p : Nat → Bool} (h : start < stop) (hstart : p start = true) (hstop : p stop = false) : p (bisect h hstart hstop + 1) = false := by unfold bisect simp only; split · split · have : avg start stop - start < stop - start := by apply Nat.sub_lt_sub_right · exact Nat.le_avg_left (Nat.le_of_lt h) · exact Nat.avg_lt_right h exact bisect_add_one_false .. · exact bisect_add_one_false .. · next h' => have heq : avg start stop = start := by apply Nat.le_antisymm · exact Nat.le_of_not_gt h' · exact Nat.le_avg_left (Nat.le_of_lt h) rw [← hstop, heq]; congr apply Nat.le_antisymm · exact Nat.succ_le_of_lt h · exact Nat.le_add_one_of_avg_eq_left heq ================================================ FILE: Batteries/Data/Nat/Bitwise/Lemmas.lean ================================================ /- Copyright (c) 2025 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section /-! # Bitwise Lemmas This module defines properties of the bitwise operations on natural numbers. This file is complements `Init.Data.Nat.Bitwise.Lemmas` with properties that are not necessary for the bitvector library. -/ namespace Nat /-! ### and -/ @[simp] theorem and_self_left (a b : Nat) : a &&& (a &&& b) = a &&& b := by apply Nat.eq_of_testBit_eq; simp @[simp] theorem and_self_right (a b : Nat) : ((a &&& b) &&& b) = (a &&& b) := by apply Nat.eq_of_testBit_eq; simp theorem and_left_comm (x y z : Nat) : x &&& (y &&& z) = y &&& (x &&& z) := by apply Nat.eq_of_testBit_eq; simp [Bool.and_left_comm] theorem and_right_comm (x y z : Nat) : (x &&& y) &&& z = (x &&& z) &&& y := by apply Nat.eq_of_testBit_eq; simp [Bool.and_right_comm] /-! ### or -/ @[simp] theorem or_self_left (a b : Nat) : a ||| (a ||| b) = a ||| b := by apply Nat.eq_of_testBit_eq; simp @[simp] theorem or_self_right (a b : Nat) : (a ||| b) ||| b = a ||| b := by apply Nat.eq_of_testBit_eq; simp theorem or_left_comm (x y z : Nat) : x ||| (y ||| z) = y ||| (x ||| z) := by apply Nat.eq_of_testBit_eq; simp [Bool.or_left_comm] theorem or_right_comm (x y z : Nat) : (x ||| y) ||| z = (x ||| z) ||| y := by apply Nat.eq_of_testBit_eq; simp [Bool.or_right_comm] /-! ### xor -/ theorem xor_left_comm (x y z : Nat) : x ^^^ (y ^^^ z) = y ^^^ (x ^^^ z) := by apply Nat.eq_of_testBit_eq; simp only [testBit_xor, Bool.xor_left_comm, implies_true] theorem xor_right_comm (x y z : Nat) : (x ^^^ y) ^^^ z = (x ^^^ z) ^^^ y := by apply Nat.eq_of_testBit_eq; simp only [testBit_xor, Bool.xor_right_comm, implies_true] @[simp] theorem xor_xor_cancel_left (x y : Nat) : x ^^^ (x ^^^ y) = y := by apply Nat.eq_of_testBit_eq; simp @[simp] theorem xor_xor_cancel_right (x y : Nat) : (x ^^^ y) ^^^ y = x := by apply Nat.eq_of_testBit_eq; simp theorem eq_of_xor_eq_zero {x y : Nat} : x ^^^ y = 0 → x = y := by intro h; rw [← xor_xor_cancel_left x y, h, xor_zero] @[simp] theorem xor_eq_zero_iff {x y : Nat} : x ^^^ y = 0 ↔ x = y := ⟨eq_of_xor_eq_zero, fun | rfl => Nat.xor_self _⟩ theorem xor_ne_zero_iff {x y : Nat} : x ^^^ y ≠ 0 ↔ x ≠ y := by simp /-! ### injectivity lemmas -/ theorem xor_right_injective {x : Nat} : Function.Injective (x ^^^ ·) := by intro y z h; rw [← xor_xor_cancel_left x y, ← xor_xor_cancel_left x z]; simp only [h] theorem xor_left_injective {x : Nat} : Function.Injective (· ^^^ x) := by intro y z h; rw [← xor_xor_cancel_right y x, ← xor_xor_cancel_right z x]; simp only [h] @[simp] theorem xor_right_inj {x y z : Nat} : x ^^^ y = x ^^^ z ↔ y = z := ⟨(xor_right_injective ·), fun | rfl => rfl⟩ @[simp] theorem xor_left_inj {x y z : Nat} : x ^^^ z = y ^^^ z ↔ x = y := ⟨(xor_left_injective ·), fun | rfl => rfl⟩ theorem and_or_right_injective {m x y : Nat} : x &&& m = y &&& m → x ||| m = y ||| m → x = y := by intro ha ho apply Nat.eq_of_testBit_eq intro i rw [← Bool.and_or_inj_right_iff (m := m.testBit i)] simp [← testBit_and, ← testBit_or, ha, ho] theorem and_or_right_inj {m x y : Nat} : x &&& m = y &&& m ∧ x ||| m = y ||| m ↔ x = y := ⟨fun ⟨ha, ho⟩ => and_or_right_injective ha ho, fun | rfl => ⟨rfl, rfl⟩⟩ theorem and_or_left_injective {m x y : Nat} : m &&& x = m &&& y → m ||| x = m ||| y → x = y := by intro ha ho apply Nat.eq_of_testBit_eq intro i rw [← Bool.and_or_inj_left_iff (m := m.testBit i)] simp [← testBit_and, ← testBit_or, ha, ho] theorem and_or_left_inj {m x y : Nat} : m &&& x = m &&& y ∧ m ||| x = m ||| y ↔ x = y := ⟨fun ⟨ha, ho⟩ => and_or_left_injective ha ho, fun | rfl => ⟨rfl, rfl⟩⟩ ================================================ FILE: Batteries/Data/Nat/Bitwise.lean ================================================ module public import Batteries.Data.Nat.Bitwise.Lemmas ================================================ FILE: Batteries/Data/Nat/Gcd.lean ================================================ /- Copyright (c) 2014 Jeremy Avigad. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro -/ module public import Batteries.Tactic.Alias @[expose] public section /-! # Definitions and properties of `coprime` -/ namespace Nat @[deprecated (since := "2025-08-04")] alias Coprime.mul := Coprime.mul_left ================================================ FILE: Batteries/Data/Nat/Lemmas.lean ================================================ /- Copyright (c) 2016 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro -/ module public import Batteries.Tactic.Alias public import Batteries.Data.Nat.Basic @[expose] public section /-! # Basic lemmas about natural numbers The primary purpose of the lemmas in this file is to assist with reasoning about sizes of objects, array indices and such. For a more thorough development of the theory of natural numbers, we recommend using Mathlib. -/ namespace Nat /-! ### rec/cases -/ @[simp] theorem recAux_zero {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive n → motive (n+1)) : Nat.recAux zero succ 0 = zero := rfl theorem recAux_succ {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive n → motive (n+1)) (n) : Nat.recAux zero succ (n+1) = succ n (Nat.recAux zero succ n) := rfl @[simp] theorem recAuxOn_zero {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive n → motive (n+1)) : Nat.recAuxOn 0 zero succ = zero := rfl theorem recAuxOn_succ {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive n → motive (n+1)) (n) : Nat.recAuxOn (n+1) zero succ = succ n (Nat.recAuxOn n zero succ) := rfl @[simp] theorem casesAuxOn_zero {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive (n+1)) : Nat.casesAuxOn 0 zero succ = zero := rfl theorem casesAuxOn_succ {motive : Nat → Sort _} (zero : motive 0) (succ : ∀ n, motive (n+1)) (n) : Nat.casesAuxOn (n+1) zero succ = succ n := rfl theorem strongRec_eq {motive : Nat → Sort _} (ind : ∀ n, (∀ m, m < n → motive m) → motive n) (t : Nat) : Nat.strongRec ind t = ind t fun m _ => Nat.strongRec ind m := by conv => lhs; unfold Nat.strongRec theorem strongRecOn_eq {motive : Nat → Sort _} (ind : ∀ n, (∀ m, m < n → motive m) → motive n) (t : Nat) : Nat.strongRecOn t ind = ind t fun m _ => Nat.strongRecOn m ind := WellFounded.fix_eq WellFoundedRelation.wf ind t @[simp] theorem recDiagAux_zero_left {motive : Nat → Nat → Sort _} (zero_left : ∀ n, motive 0 n) (zero_right : ∀ m, motive m 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (n) : Nat.recDiagAux zero_left zero_right succ_succ 0 n = zero_left n := by cases n <;> rfl @[simp] theorem recDiagAux_zero_right {motive : Nat → Nat → Sort _} (zero_left : ∀ n, motive 0 n) (zero_right : ∀ m, motive m 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m) (h : zero_left 0 = zero_right 0 := by first | assumption | trivial) : Nat.recDiagAux zero_left zero_right succ_succ m 0 = zero_right m := by cases m; exact h; rfl theorem recDiagAux_succ_succ {motive : Nat → Nat → Sort _} (zero_left : ∀ n, motive 0 n) (zero_right : ∀ m, motive m 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m n) : Nat.recDiagAux zero_left zero_right succ_succ (m+1) (n+1) = succ_succ m n (Nat.recDiagAux zero_left zero_right succ_succ m n) := rfl @[simp] theorem recDiag_zero_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) : Nat.recDiag (motive:=motive) zero_zero zero_succ succ_zero succ_succ 0 0 = zero_zero := rfl theorem recDiag_zero_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (n) : Nat.recDiag zero_zero zero_succ succ_zero succ_succ 0 (n+1) = zero_succ n (Nat.recDiag zero_zero zero_succ succ_zero succ_succ 0 n) := by simp [Nat.recDiag]; rfl theorem recDiag_succ_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m) : Nat.recDiag zero_zero zero_succ succ_zero succ_succ (m+1) 0 = succ_zero m (Nat.recDiag zero_zero zero_succ succ_zero succ_succ m 0) := by simp [Nat.recDiag]; cases m <;> rfl theorem recDiag_succ_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m n) : Nat.recDiag zero_zero zero_succ succ_zero succ_succ (m+1) (n+1) = succ_succ m n (Nat.recDiag zero_zero zero_succ succ_zero succ_succ m n) := rfl @[simp] theorem recDiagOn_zero_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) : Nat.recDiagOn (motive:=motive) 0 0 zero_zero zero_succ succ_zero succ_succ = zero_zero := rfl theorem recDiagOn_zero_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (n) : Nat.recDiagOn 0 (n+1) zero_zero zero_succ succ_zero succ_succ = zero_succ n (Nat.recDiagOn 0 n zero_zero zero_succ succ_zero succ_succ) := Nat.recDiag_zero_succ .. theorem recDiagOn_succ_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m) : Nat.recDiagOn (m+1) 0 zero_zero zero_succ succ_zero succ_succ = succ_zero m (Nat.recDiagOn m 0 zero_zero zero_succ succ_zero succ_succ) := Nat.recDiag_succ_zero .. theorem recDiagOn_succ_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 n → motive 0 (n+1)) (succ_zero : ∀ m, motive m 0 → motive (m+1) 0) (succ_succ : ∀ m n, motive m n → motive (m+1) (n+1)) (m n) : Nat.recDiagOn (m+1) (n+1) zero_zero zero_succ succ_zero succ_succ = succ_succ m n (Nat.recDiagOn m n zero_zero zero_succ succ_zero succ_succ) := rfl @[simp] theorem casesDiagOn_zero_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 (n+1)) (succ_zero : ∀ m, motive (m+1) 0) (succ_succ : ∀ m n, motive (m+1) (n+1)) : Nat.casesDiagOn 0 0 (motive:=motive) zero_zero zero_succ succ_zero succ_succ = zero_zero := rfl @[simp] theorem casesDiagOn_zero_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 (n+1)) (succ_zero : ∀ m, motive (m+1) 0) (succ_succ : ∀ m n, motive (m+1) (n+1)) (n) : Nat.casesDiagOn 0 (n+1) zero_zero zero_succ succ_zero succ_succ = zero_succ n := rfl @[simp] theorem casesDiagOn_succ_zero {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 (n+1)) (succ_zero : ∀ m, motive (m+1) 0) (succ_succ : ∀ m n, motive (m+1) (n+1)) (m) : Nat.casesDiagOn (m+1) 0 zero_zero zero_succ succ_zero succ_succ = succ_zero m := rfl @[simp] theorem casesDiagOn_succ_succ {motive : Nat → Nat → Sort _} (zero_zero : motive 0 0) (zero_succ : ∀ n, motive 0 (n+1)) (succ_zero : ∀ m, motive (m+1) 0) (succ_succ : ∀ m n, motive (m+1) (n+1)) (m n) : Nat.casesDiagOn (m+1) (n+1) zero_zero zero_succ succ_zero succ_succ = succ_succ m n := rfl /-! ## strong case -/ /-- Strong case analysis on `a < b ∨ b ≤ a` -/ protected def lt_sum_ge (a b : Nat) : a < b ⊕' b ≤ a := if h : a < b then .inl h else .inr (Nat.not_lt.1 h) /-- Strong case analysis on `a < b ∨ a = b ∨ b < a` -/ protected def sum_trichotomy (a b : Nat) : a < b ⊕' a = b ⊕' b < a := match h : compare a b with | .lt => .inl (Nat.compare_eq_lt.1 h) | .eq => .inr (.inl (Nat.compare_eq_eq.1 h)) | .gt => .inr (.inr (Nat.compare_eq_gt.1 h)) /-! ### div/mod -/ -- TODO mod_core_congr, mod_def -- TODO div_core_congr, div_def -- TODO cont_to_bool_mod_two /-! ### sum -/ @[deprecated (since := "2025-07-31")] alias sum_append := List.sum_append_nat /-! ### ofBits -/ @[simp] theorem ofBits_zero (f : Fin 0 → Bool) : ofBits f = 0 := rfl theorem ofBits_succ (f : Fin (n+1) → Bool) : ofBits f = 2 * ofBits (f ∘ Fin.succ) + (f 0).toNat := Fin.foldr_succ .. theorem ofBits_lt_two_pow (f : Fin n → Bool) : ofBits f < 2 ^ n := by induction n with | zero => simp | succ n ih => calc ofBits f = 2 * ofBits (f ∘ Fin.succ) + (f 0).toNat := ofBits_succ .. _ < 2 * (ofBits (f ∘ Fin.succ) + 1) := Nat.add_lt_add_left (Bool.toNat_lt _) .. _ ≤ 2 * 2 ^ n := Nat.mul_le_mul_left 2 (ih ..) _ = 2 ^ (n + 1) := Nat.pow_add_one' .. |>.symm @[simp] theorem testBit_ofBits_lt (f : Fin n → Bool) (i : Nat) (h : i < n) : (ofBits f).testBit i = f ⟨i, h⟩ := by induction n generalizing i with | zero => contradiction | succ n ih => simp only [ofBits_succ] match i with | 0 => simp [mod_eq_of_lt (Bool.toNat_lt _)] | i+1 => rw [testBit_add_one, mul_add_div Nat.zero_lt_two, Nat.div_eq_of_lt (Bool.toNat_lt _)] exact ih (f ∘ Fin.succ) i (Nat.lt_of_succ_lt_succ h) @[simp] theorem testBit_ofBits_ge (f : Fin n → Bool) (i : Nat) (h : n ≤ i) : (ofBits f).testBit i = false := by apply testBit_lt_two_pow apply Nat.lt_of_lt_of_le · exact ofBits_lt_two_pow f · exact Nat.pow_le_pow_right Nat.zero_lt_two h theorem testBit_ofBits (f : Fin n → Bool) : (ofBits f).testBit i = if h : i < n then f ⟨i, h⟩ else false := by cases Nat.lt_or_ge i n with | inl h => simp [h] | inr h => simp [h, Nat.not_lt_of_ge h] theorem ofBits_testBit (x n) : ofBits (fun i : Fin n => x.testBit i) = x % 2 ^ n := by apply eq_of_testBit_eq; simp [testBit_ofBits] /-! ### Misc -/ theorem mul_add_lt_mul_of_lt_of_lt {m n x y : Nat} (hx : x < m) (hy : y < n) : n * x + y < m * n := calc _ < n * x + n := Nat.add_lt_add_left hy _ _ = n * (x + 1) := Nat.mul_add_one .. |>.symm _ ≤ n * m := Nat.mul_le_mul_left _ hx _ = m * n := Nat.mul_comm .. theorem add_mul_lt_mul_of_lt_of_lt {m n x y : Nat} (hx : x < m) (hy : y < n) : x + m * y < m * n := by rw [Nat.add_comm, Nat.mul_comm _ n] exact mul_add_lt_mul_of_lt_of_lt hy hx ================================================ FILE: Batteries/Data/Nat.lean ================================================ module public import Batteries.Data.Nat.Basic public import Batteries.Data.Nat.Bisect public import Batteries.Data.Nat.Bitwise public import Batteries.Data.Nat.Bitwise.Lemmas public import Batteries.Data.Nat.Gcd public import Batteries.Data.Nat.Lemmas ================================================ FILE: Batteries/Data/PairingHeap.lean ================================================ /- Copyright (c) 2022 Yuyang Zhao. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Yuyang Zhao -/ module public import Batteries.Classes.Order @[expose] public section namespace Batteries.PairingHeapImp /-- A `Heap` is the nodes of the pairing heap. Each node have two pointers: `child` going to the first child of this node, and `sibling` goes to the next sibling of this tree. So it actually encodes a forest where each node has children `node.child`, `node.child.sibling`, `node.child.sibling.sibling`, etc. Each edge in this forest denotes a `le a b` relation that has been checked, so the root is smaller than everything else under it. -/ inductive Heap (α : Type u) where /-- An empty forest, which has depth `0`. -/ | nil : Heap α /-- A forest consists of a root `a`, a forest `child` elements greater than `a`, and another forest `sibling`. -/ | node (a : α) (child sibling : Heap α) : Heap α deriving Repr /-- `O(n)`. The number of elements in the heap. -/ def Heap.size : Heap α → Nat | .nil => 0 | .node _ c s => c.size + 1 + s.size /-- A node containing a single element `a`. -/ def Heap.singleton (a : α) : Heap α := .node a .nil .nil /-- `O(1)`. Is the heap empty? -/ def Heap.isEmpty : Heap α → Bool | .nil => true | _ => false /-- `O(1)`. Merge two heaps. Ignore siblings. -/ @[specialize] def Heap.merge (le : α → α → Bool) : Heap α → Heap α → Heap α | .nil, .nil => .nil | .nil, .node a₂ c₂ _ => .node a₂ c₂ .nil | .node a₁ c₁ _, .nil => .node a₁ c₁ .nil | .node a₁ c₁ _, .node a₂ c₂ _ => if le a₁ a₂ then .node a₁ (.node a₂ c₂ c₁) .nil else .node a₂ (.node a₁ c₁ c₂) .nil /-- Auxiliary for `Heap.deleteMin`: merge the forest in pairs. -/ @[specialize] def Heap.combine (le : α → α → Bool) : Heap α → Heap α | h₁@(.node _ _ h₂@(.node _ _ s)) => merge le (merge le h₁ h₂) (s.combine le) | h => h /-- `O(1)`. Get the smallest element in the heap, including the passed in value `a`. -/ @[inline] def Heap.headD (a : α) : Heap α → α | .nil => a | .node a _ _ => a /-- `O(1)`. Get the smallest element in the heap, if it has an element. -/ @[inline] def Heap.head? : Heap α → Option α | .nil => none | .node a _ _ => some a /-- Amortized `O(log n)`. Find and remove the the minimum element from the heap. -/ @[inline] def Heap.deleteMin (le : α → α → Bool) : Heap α → Option (α × Heap α) | .nil => none | .node a c _ => (a, combine le c) /-- Amortized `O(log n)`. Get the tail of the pairing heap after removing the minimum element. -/ @[inline] def Heap.tail? (le : α → α → Bool) (h : Heap α) : Option (Heap α) := deleteMin le h |>.map (·.snd) /-- Amortized `O(log n)`. Remove the minimum element of the heap. -/ @[inline] def Heap.tail (le : α → α → Bool) (h : Heap α) : Heap α := tail? le h |>.getD .nil /-- A predicate says there is no more than one tree. -/ inductive Heap.NoSibling : Heap α → Prop /-- An empty heap is no more than one tree. -/ | nil : NoSibling .nil /-- Or there is exactly one tree. -/ | node (a c) : NoSibling (.node a c .nil) instance : Decidable (Heap.NoSibling s) := match s with | .nil => isTrue .nil | .node a c .nil => isTrue (.node a c) | .node _ _ (.node _ _ _) => isFalse nofun theorem Heap.noSibling_merge (le) (s₁ s₂ : Heap α) : (s₁.merge le s₂).NoSibling := by unfold merge (split <;> try split) <;> constructor theorem Heap.noSibling_combine (le) (s : Heap α) : (s.combine le).NoSibling := by unfold combine; split · exact noSibling_merge _ _ _ · match s with | nil | node _ _ nil => constructor | node _ _ (node _ _ s) => rename_i h; exact (h _ _ _ _ _ rfl).elim theorem Heap.noSibling_deleteMin {s : Heap α} (eq : s.deleteMin le = some (a, s')) : s'.NoSibling := by cases s with cases eq | node a c => exact noSibling_combine _ _ theorem Heap.noSibling_tail? {s : Heap α} : s.tail? le = some s' → s'.NoSibling := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact noSibling_deleteMin eq₂ theorem Heap.noSibling_tail (le) (s : Heap α) : (s.tail le).NoSibling := by simp only [Heap.tail] match eq : s.tail? le with | none => cases s with cases eq | nil => constructor | some tl => exact Heap.noSibling_tail? eq theorem Heap.size_merge_node (le) (a₁ : α) (c₁ s₁ : Heap α) (a₂ : α) (c₂ s₂ : Heap α) : (merge le (.node a₁ c₁ s₁) (.node a₂ c₂ s₂)).size = c₁.size + c₂.size + 2 := by unfold merge; dsimp; split <;> simp +arith [size] theorem Heap.size_merge (le) {s₁ s₂ : Heap α} (h₁ : s₁.NoSibling) (h₂ : s₂.NoSibling) : (merge le s₁ s₂).size = s₁.size + s₂.size := by match h₁, h₂ with | .nil, .nil | .nil, .node _ _ | .node _ _, .nil => simp [merge, size] | .node _ _, .node _ _ => unfold merge; dsimp; split <;> simp +arith [size] theorem Heap.size_combine (le) (s : Heap α) : (s.combine le).size = s.size := by unfold combine; split · rename_i a₁ c₁ a₂ c₂ s rw [size_merge le (noSibling_merge _ _ _) (noSibling_combine _ _), size_merge_node, size_combine le s] simp +arith [size] · rfl theorem Heap.size_deleteMin {s : Heap α} (h : s.NoSibling) (eq : s.deleteMin le = some (a, s')) : s.size = s'.size + 1 := by cases h with cases eq | node a c => rw [size_combine, size, size] theorem Heap.size_tail? {s : Heap α} (h : s.NoSibling) : s.tail? le = some s' → s.size = s'.size + 1 := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact size_deleteMin h eq₂ theorem Heap.size_tail (le) {s : Heap α} (h : s.NoSibling) : (s.tail le).size = s.size - 1 := by simp only [Heap.tail] match eq : s.tail? le with | none => cases s with cases eq | nil => rfl | some tl => simp [Heap.size_tail? h eq] theorem Heap.size_deleteMin_lt {s : Heap α} (eq : s.deleteMin le = some (a, s')) : s'.size < s.size := by cases s with cases eq | node a c => simp +arith [size_combine, size] theorem Heap.size_tail?_lt {s : Heap α} : s.tail? le = some s' → s'.size < s.size := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact size_deleteMin_lt eq₂ /-- `O(n log n)`. Monadic fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[specialize] def Heap.foldM [Monad m] (le : α → α → Bool) (s : Heap α) (init : β) (f : β → α → m β) : m β := match eq : s.deleteMin le with | none => pure init | some (hd, tl) => have : tl.size < s.size := by simp +arith [Heap.size_deleteMin_lt eq] do foldM le tl (← f init hd) f termination_by s.size /-- `O(n log n)`. Fold over the elements of a heap in increasing order, by repeatedly pulling the minimum element out of the heap. -/ @[inline] def Heap.fold (le : α → α → Bool) (s : Heap α) (init : β) (f : β → α → β) : β := Id.run <| s.foldM le init f /-- `O(n log n)`. Convert the heap to an array in increasing order. -/ @[inline] def Heap.toArray (le : α → α → Bool) (s : Heap α) : Array α := fold le s #[] Array.push /-- `O(n log n)`. Convert the heap to a list in increasing order. -/ @[inline] def Heap.toList (le : α → α → Bool) (s : Heap α) : List α := (s.toArray le).toList /-- `O(n)`. Fold a monadic function over the tree structure to accumulate a value. -/ @[specialize] def Heap.foldTreeM [Monad m] (nil : β) (join : α → β → β → m β) : Heap α → m β | .nil => pure nil | .node a c s => do join a (← c.foldTreeM nil join) (← s.foldTreeM nil join) /-- `O(n)`. Fold a function over the tree structure to accumulate a value. -/ @[inline] def Heap.foldTree (nil : β) (join : α → β → β → β) (s : Heap α) : β := Id.run <| s.foldTreeM nil join /-- `O(n)`. Convert the heap to a list in arbitrary order. -/ def Heap.toListUnordered (s : Heap α) : List α := s.foldTree id (fun a c s l => a :: c (s l)) [] /-- `O(n)`. Convert the heap to an array in arbitrary order. -/ def Heap.toArrayUnordered (s : Heap α) : Array α := s.foldTree id (fun a c s r => s (c (r.push a))) #[] /-- The well formedness predicate for a heap node. It asserts that: * If `a` is added at the top to make the forest into a tree, the resulting tree is a `le`-min-heap (if `le` is well-behaved) -/ def Heap.NodeWF (le : α → α → Bool) (a : α) : Heap α → Prop | .nil => True | .node b c s => (∀ [TotalBLE le], le a b) ∧ c.NodeWF le b ∧ s.NodeWF le a /-- The well formedness predicate for a pairing heap. It asserts that: * There is no more than one tree. * It is a `le`-min-heap (if `le` is well-behaved) -/ inductive Heap.WF (le : α → α → Bool) : Heap α → Prop /-- It is an empty heap. -/ | nil : WF le .nil /-- There is exactly one tree and it is a `le`-min-heap. -/ | node (h : c.NodeWF le a) : WF le (.node a c .nil) theorem Heap.WF.singleton : (Heap.singleton a).WF le := node trivial theorem Heap.WF.merge_node (h₁ : NodeWF le a₁ c₁) (h₂ : NodeWF le a₂ c₂) : (merge le (.node a₁ c₁ s₁) (.node a₂ c₂ s₂)).WF le := by unfold merge; dsimp split <;> rename_i h · exact node ⟨fun [_] => h, h₂, h₁⟩ · exact node ⟨fun [_] => TotalBLE.total.resolve_left h, h₁, h₂⟩ theorem Heap.WF.merge (h₁ : s₁.WF le) (h₂ : s₂.WF le) : (merge le s₁ s₂).WF le := match h₁, h₂ with | .nil, .nil => nil | .nil, .node h₂ => node h₂ | .node h₁, .nil => node h₁ | .node h₁, .node h₂ => merge_node h₁ h₂ theorem Heap.WF.combine (h : s.NodeWF le a) : (combine le s).WF le := match s with | .nil => nil | .node _b _c .nil => node h.2.1 | .node _b₁ _c₁ (.node _b₂ _c₂ _s) => merge (merge_node h.2.1 h.2.2.2.1) (combine h.2.2.2.2) theorem Heap.WF.deleteMin {s : Heap α} (h : s.WF le) (eq : s.deleteMin le = some (a, s')) : s'.WF le := by cases h with cases eq | node h => exact Heap.WF.combine h theorem Heap.WF.tail? (hwf : (s : Heap α).WF le) : s.tail? le = some tl → tl.WF le := by simp only [Heap.tail?]; intro eq match eq₂ : s.deleteMin le, eq with | some (a, tl), rfl => exact hwf.deleteMin eq₂ theorem Heap.WF.tail (hwf : (s : Heap α).WF le) : (s.tail le).WF le := by simp only [Heap.tail] match eq : s.tail? le with | none => exact Heap.WF.nil | some tl => exact hwf.tail? eq theorem Heap.deleteMin_fst : ((s : Heap α).deleteMin le).map (·.1) = s.head? := match s with | .nil => rfl | .node _ _ _ => rfl end PairingHeapImp open PairingHeapImp /-- A [pairing heap](https://en.wikipedia.org/wiki/Pairing_heap) is a data structure which supports the following primary operations: * `insert : α → PairingHeap α → PairingHeap α`: add an element to the heap * `deleteMin : PairingHeap α → Option (α × PairingHeap α)`: remove the minimum element from the heap * `merge : PairingHeap α → PairingHeap α → PairingHeap α`: combine two heaps The first two operations are known as a "priority queue", so this could be called a "mergeable priority queue". The standard choice for a priority queue is a binary heap, which supports `insert` and `deleteMin` in `O(log n)`, but `merge` is `O(n)`. With a `PairingHeap`, `insert` and `merge` are `O(1)`, `deleteMin` is amortized `O(log n)`. Note that `deleteMin` may be `O(n)` in a single operation. So if you need an efficient persistent priority queue, you should use other data structures with better worst-case time. -/ def PairingHeap (α : Type u) (le : α → α → Bool) := { h : Heap α // h.WF le } /-- `O(1)`. Make a new empty pairing heap. -/ @[inline] def mkPairingHeap (α : Type u) (le : α → α → Bool) : PairingHeap α le := ⟨.nil, Heap.WF.nil⟩ namespace PairingHeap variable {α : Type u} {le : α → α → Bool} /-- `O(1)`. Make a new empty pairing heap. -/ @[inline] def empty : PairingHeap α le := mkPairingHeap α le instance : Inhabited (PairingHeap α le) := ⟨.empty⟩ /-- `O(1)`. Is the heap empty? -/ @[inline] def isEmpty (b : PairingHeap α le) : Bool := b.1.isEmpty /-- `O(n)`. The number of elements in the heap. -/ @[inline] def size (b : PairingHeap α le) : Nat := b.1.size /-- `O(1)`. Make a new heap containing `a`. -/ @[inline] def singleton (a : α) : PairingHeap α le := ⟨Heap.singleton a, Heap.WF.singleton⟩ /-- `O(1)`. Merge the contents of two heaps. -/ @[inline] def merge : PairingHeap α le → PairingHeap α le → PairingHeap α le | ⟨b₁, h₁⟩, ⟨b₂, h₂⟩ => ⟨b₁.merge le b₂, h₁.merge h₂⟩ /-- `O(1)`. Add element `a` to the given heap `h`. -/ @[inline] def insert (a : α) (h : PairingHeap α le) : PairingHeap α le := merge (singleton a) h /-- `O(n log n)`. Construct a heap from a list by inserting all the elements. -/ def ofList (le : α → α → Bool) (as : List α) : PairingHeap α le := as.foldl (flip insert) empty /-- `O(n log n)`. Construct a heap from a list by inserting all the elements. -/ def ofArray (le : α → α → Bool) (as : Array α) : PairingHeap α le := as.foldl (flip insert) empty /-- Amortized `O(log n)`. Remove and return the minimum element from the heap. -/ @[inline] def deleteMin (b : PairingHeap α le) : Option (α × PairingHeap α le) := match eq : b.1.deleteMin le with | none => none | some (a, tl) => some (a, ⟨tl, b.2.deleteMin eq⟩) /-- `O(1)`. Returns the smallest element in the heap, or `none` if the heap is empty. -/ @[inline] def head? (b : PairingHeap α le) : Option α := b.1.head? /-- `O(1)`. Returns the smallest element in the heap, or panics if the heap is empty. -/ @[inline] def head! [Inhabited α] (b : PairingHeap α le) : α := b.head?.get! /-- `O(1)`. Returns the smallest element in the heap, or `default` if the heap is empty. -/ @[inline] def headI [Inhabited α] (b : PairingHeap α le) : α := b.head?.getD default /-- Amortized `O(log n)`. Removes the smallest element from the heap, or `none` if the heap is empty. -/ @[inline] def tail? (b : PairingHeap α le) : Option (PairingHeap α le) := match eq : b.1.tail? le with | none => none | some tl => some ⟨tl, b.2.tail? eq⟩ /-- Amortized `O(log n)`. Removes the smallest element from the heap, if possible. -/ @[inline] def tail (b : PairingHeap α le) : PairingHeap α le := ⟨b.1.tail le, b.2.tail⟩ /-- `O(n log n)`. Convert the heap to a list in increasing order. -/ @[inline] def toList (b : PairingHeap α le) : List α := b.1.toList le /-- `O(n log n)`. Convert the heap to an array in increasing order. -/ @[inline] def toArray (b : PairingHeap α le) : Array α := b.1.toArray le /-- `O(n)`. Convert the heap to a list in arbitrary order. -/ @[inline] def toListUnordered (b : PairingHeap α le) : List α := b.1.toListUnordered /-- `O(n)`. Convert the heap to an array in arbitrary order. -/ @[inline] def toArrayUnordered (b : PairingHeap α le) : Array α := b.1.toArrayUnordered ================================================ FILE: Batteries/Data/RBMap/Alter.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.RBMap.WF @[expose] public section /-! # Path operations; `modify` and `alter` This develops the necessary theorems to construct the `modify` and `alter` functions on `RBSet` using path operations for in-place modification of an `RBTree`. -/ namespace Batteries namespace RBNode open RBColor attribute [simp] Path.fill /-! ## path balance -/ /-- Asserts that property `p` holds on the root of the tree, if any. -/ def OnRoot (p : α → Prop) : RBNode α → Prop | nil => True | node _ _ x _ => p x namespace Path /-- Same as `fill` but taking its arguments in a pair for easier composition with `zoom`. -/ @[inline] def fill' : RBNode α × Path α → RBNode α := fun (t, path) => path.fill t theorem zoom_fill' (cut : α → Ordering) (t : RBNode α) (path : Path α) : fill' (zoom cut t path) = path.fill t := by induction t generalizing path with | nil => rfl | node _ _ _ _ iha ihb => unfold zoom; split <;> [apply iha; apply ihb; rfl] theorem zoom_fill (H : zoom cut t path = (t', path')) : path.fill t = path'.fill t' := (H ▸ zoom_fill' cut t path).symm variable (c₀ : RBColor) (n₀ : Nat) in /-- The balance invariant for a path. `path.Balanced c₀ n₀ c n` means that `path` is a red-black tree with balance invariant `c₀, n₀`, but it has a "hole" where a tree with balance invariant `c, n` has been removed. The defining property is `Balanced.fill`: if `path.Balanced c₀ n₀ c n` and you fill the hole with a tree satisfying `t.Balanced c n`, then `(path.fill t).Balanced c₀ n₀` . -/ protected inductive Balanced : Path α → RBColor → Nat → Prop where /-- The root of the tree is `c₀, n₀`-balanced by assumption. -/ | protected root : Path.root.Balanced c₀ n₀ /-- Descend into the left subtree of a red node. -/ | redL : Balanced y black n → parent.Balanced red n → (Path.left red parent v y).Balanced black n /-- Descend into the right subtree of a red node. -/ | redR : Balanced x black n → parent.Balanced red n → (Path.right red x v parent).Balanced black n /-- Descend into the left subtree of a black node. -/ | blackL : Balanced y c₂ n → parent.Balanced black (n + 1) → (Path.left black parent v y).Balanced c₁ n /-- Descend into the right subtree of a black node. -/ | blackR : Balanced x c₁ n → parent.Balanced black (n + 1) → (Path.right black x v parent).Balanced c₂ n /-- The defining property of a balanced path: If `path` is a `c₀,n₀` tree with a `c,n` hole, then filling the hole with a `c,n` tree yields a `c₀,n₀` tree. -/ protected theorem Balanced.fill {path : Path α} {t} : path.Balanced c₀ n₀ c n → t.Balanced c n → (path.fill t).Balanced c₀ n₀ | .root, h => h | .redL hb H, ha | .redR ha H, hb => H.fill (.red ha hb) | .blackL hb H, ha | .blackR ha H, hb => H.fill (.black ha hb) protected theorem _root_.Batteries.RBNode.Balanced.zoom : t.Balanced c n → path.Balanced c₀ n₀ c n → zoom cut t path = (t', path') → ∃ c n, t'.Balanced c n ∧ path'.Balanced c₀ n₀ c n | .nil, hp => fun e => by cases e; exact ⟨_, _, .nil, hp⟩ | .red ha hb, hp => by unfold zoom; split · exact ha.zoom (.redL hb hp) · exact hb.zoom (.redR ha hp) · intro e; cases e; exact ⟨_, _, .red ha hb, hp⟩ | .black ha hb, hp => by unfold zoom; split · exact ha.zoom (.blackL hb hp) · exact hb.zoom (.blackR ha hp) · intro e; cases e; exact ⟨_, _, .black ha hb, hp⟩ protected theorem Balanced.ins {path : Path α} (hp : path.Balanced c₀ n₀ c n) (ht : t.RedRed (c = red) n) : ∃ n, (path.ins t).Balanced black n := by induction hp generalizing t with | root => exact ht.setBlack | redL hr hp ih => match ht with | .balanced .nil => exact ih (.balanced (.red .nil hr)) | .balanced (.red ha hb) => exact ih (.redred rfl (.red ha hb) hr) | .balanced (.black ha hb) => exact ih (.balanced (.red (.black ha hb) hr)) | redR hl hp ih => match ht with | .balanced .nil => exact ih (.balanced (.red hl .nil)) | .balanced (.red ha hb) => exact ih (.redred rfl hl (.red ha hb)) | .balanced (.black ha hb) => exact ih (.balanced (.red hl (.black ha hb))) | blackL hr _hp ih => exact have ⟨c, h⟩ := ht.balance1 hr; ih (.balanced h) | blackR hl _hp ih => exact have ⟨c, h⟩ := ht.balance2 hl; ih (.balanced h) protected theorem Balanced.insertNew {path : Path α} (H : path.Balanced c n black 0) : ∃ n, (path.insertNew v).Balanced black n := H.ins (.balanced (.red .nil .nil)) protected theorem Balanced.del {path : Path α} (hp : path.Balanced c₀ n₀ c n) (ht : t.DelProp c' n) (hc : c = black → c' ≠ red) : ∃ n, (path.del t c').Balanced black n := by induction hp generalizing t c' with | root => match c', ht with | red, ⟨_, h⟩ | black, ⟨_, _, h⟩ => exact h.setBlack | @redL _ n _ _ hb hp ih => match c', n, ht with | red, _, _ => cases hc rfl rfl | black, _, ⟨_, rfl, ha⟩ => exact ih ((hb.balLeft ha).of_false nofun) nofun | @redR _ n _ _ ha hp ih => match c', n, ht with | red, _, _ => cases hc rfl rfl | black, _, ⟨_, rfl, hb⟩ => exact ih ((ha.balRight hb).of_false nofun) nofun | @blackL _ _ n _ _ _ hb hp ih => match c', n, ht with | red, _, ⟨_, ha⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ nofun | black, _, ⟨_, rfl, ha⟩ => exact ih ⟨_, rfl, (hb.balLeft ha).imp fun _ => ⟨⟩⟩ nofun | @blackR _ _ n _ _ _ ha hp ih => match c', n, ht with | red, _, ⟨_, hb⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ nofun | black, _, ⟨_, rfl, hb⟩ => exact ih ⟨_, rfl, (ha.balRight hb).imp fun _ => ⟨⟩⟩ nofun /-- The property of a path returned by `t.zoom cut`. Each of the parents visited along the path have the appropriate ordering relation to the cut. -/ def Zoomed (cut : α → Ordering) : Path α → Prop | .root => True | .left _ parent x _ => cut x = .lt ∧ parent.Zoomed cut | .right _ _ x parent => cut x = .gt ∧ parent.Zoomed cut theorem zoom_zoomed₂ (e : zoom cut t path = (t', path')) (hp : path.Zoomed cut) : path'.Zoomed cut := match t, e with | nil, rfl => hp | node .., e => by revert e; unfold zoom; split · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩ · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩ · intro e; cases e; exact hp /-- `path.RootOrdered cmp v` is true if `v` would be able to fit into the hole without violating the ordering invariant. -/ def RootOrdered (cmp : α → α → Ordering) : Path α → α → Prop | .root, _ => True | .left _ parent x _, v => cmpLT cmp v x ∧ parent.RootOrdered cmp v | .right _ _ x parent, v => cmpLT cmp x v ∧ parent.RootOrdered cmp v theorem _root_.Batteries.RBNode.cmpEq.RootOrdered_congr {cmp : α → α → Ordering} (h : cmpEq cmp a b) : ∀ {t : Path α}, t.RootOrdered cmp a ↔ t.RootOrdered cmp b | .root => .rfl | .left .. => and_congr h.lt_congr_left h.RootOrdered_congr | .right .. => and_congr h.lt_congr_right h.RootOrdered_congr theorem Zoomed.toRootOrdered {cmp} : ∀ {path : Path α}, path.Zoomed (cmp v) → path.RootOrdered cmp v | .root, h => h | .left .., ⟨h, hp⟩ => ⟨⟨h⟩, hp.toRootOrdered⟩ | .right .., ⟨h, hp⟩ => ⟨⟨Std.OrientedCmp.gt_iff_lt.1 h⟩, hp.toRootOrdered⟩ /-- The ordering invariant for a `Path`. -/ def Ordered (cmp : α → α → Ordering) : Path α → Prop | .root => True | .left _ parent x b => parent.Ordered cmp ∧ b.All (cmpLT cmp x ·) ∧ parent.RootOrdered cmp x ∧ b.All (parent.RootOrdered cmp) ∧ b.Ordered cmp | .right _ a x parent => parent.Ordered cmp ∧ a.All (cmpLT cmp · x) ∧ parent.RootOrdered cmp x ∧ a.All (parent.RootOrdered cmp) ∧ a.Ordered cmp protected theorem Ordered.fill : ∀ {path : Path α} {t}, (path.fill t).Ordered cmp ↔ path.Ordered cmp ∧ t.Ordered cmp ∧ t.All (path.RootOrdered cmp) | .root, _ => ⟨fun H => ⟨⟨⟩, H, .trivial ⟨⟩⟩, (·.2.1)⟩ | .left .., _ => by simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and] exact ⟨ fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩, fun ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩ | .right .., _ => by simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and] exact ⟨ fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩, fun ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩ theorem _root_.Batteries.RBNode.Ordered.zoom' {t : RBNode α} {path : Path α} (ht : t.Ordered cmp) (hp : path.Ordered cmp) (tp : t.All (path.RootOrdered cmp)) (pz : path.Zoomed cut) (eq : t.zoom cut path = (t', path')) : t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut := have ⟨hp', ht', tp'⟩ := Ordered.fill.1 <| zoom_fill eq ▸ Ordered.fill.2 ⟨hp, ht, tp⟩ ⟨ht', hp', tp', zoom_zoomed₂ eq pz⟩ theorem _root_.Batteries.RBNode.Ordered.zoom {t : RBNode α} (ht : t.Ordered cmp) (eq : t.zoom cut = (t', path')) : t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut := ht.zoom' (path := .root) ⟨⟩ (.trivial ⟨⟩) ⟨⟩ eq theorem Ordered.ins : ∀ {path : Path α} {t : RBNode α}, t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.ins t).Ordered cmp | .root, _, ht, _, _ => Ordered.setBlack.2 ht | .left red parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by unfold Path.ins have ⟨ax, ap⟩ := All_and.1 H exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩ | .right red a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by unfold Path.ins have ⟨xb, bp⟩ := All_and.1 H exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩ | .left black parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by unfold Path.ins have ⟨ax, ap⟩ := All_and.1 H exact hp.ins (ha.balance1 ax xb hb) (balance1_All.2 ⟨xp, ap, bp⟩) | .right black a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by unfold Path.ins have ⟨xb, bp⟩ := All_and.1 H exact hp.ins (ha.balance2 ax xb hb) (balance2_All.2 ⟨xp, ap, bp⟩) theorem Ordered.insertNew {path : Path α} (hp : path.Ordered cmp) (vp : path.RootOrdered cmp v) : (path.insertNew v).Ordered cmp := hp.ins ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ ⟨vp, ⟨⟩, ⟨⟩⟩ theorem Ordered.del : ∀ {path : Path α} {t : RBNode α} {c}, t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.del t c).Ordered cmp | .root, _, _, ht, _, _ => Ordered.setBlack.2 ht | .left _ parent x b, a, red, ha, ⟨hp, xb, xp, bp, hb⟩, H => by unfold Path.del have ⟨ax, ap⟩ := All_and.1 H exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩ | .right _ a x parent, b, red, hb, ⟨hp, ax, xp, ap, ha⟩, H => by unfold Path.del have ⟨xb, bp⟩ := All_and.1 H exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩ | .left _ parent x b, a, black, ha, ⟨hp, xb, xp, bp, hb⟩, H => by unfold Path.del have ⟨ax, ap⟩ := All_and.1 H exact hp.del (ha.balLeft ax xb hb) (ap.balLeft xp bp) | .right _ a x parent, b, black, hb, ⟨hp, ax, xp, ap, ha⟩, H => by unfold Path.del have ⟨xb, bp⟩ := All_and.1 H exact hp.del (ha.balRight ax xb hb) (ap.balRight xp bp) end Path /-! ## alter -/ /-- The `alter` function preserves the ordering invariants. -/ protected theorem Ordered.alter {t : RBNode α} (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x → p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x)) (h : t.Ordered cmp) : (alter cut f t).Ordered cmp := by simp [alter]; split · next path eq => have ⟨_, hp, _, _⟩ := h.zoom eq; split · exact h · next hf => exact hp.insertNew (H eq hf).1 · next path eq => have ⟨⟨ax, xb, ha, hb⟩, hp, ⟨_, ap, bp⟩, _⟩ := h.zoom eq; split · exact hp.del (ha.append ax xb hb) (ap.append bp) · next hf => have ⟨yp, xy⟩ := H eq hf apply Path.Ordered.fill.2 exact ⟨hp, ⟨ax.imp xy.lt_congr_right.2, xb.imp xy.lt_congr_left.2, ha, hb⟩, yp, ap, bp⟩ /-- The `alter` function preserves the balance invariants. -/ protected theorem Balanced.alter {t : RBNode α} (h : t.Balanced c n) : ∃ c n, (t.alter cut f).Balanced c n := by simp [alter]; split · next path eq => split · exact ⟨_, _, h⟩ · have ⟨_, _, .nil, h⟩ := h.zoom .root eq exact ⟨_, h.insertNew⟩ · next path eq => have ⟨_, _, h, hp⟩ := h.zoom .root eq split · match h with | .red ha hb => exact ⟨_, hp.del ((ha.append hb).of_false (· rfl rfl)) nofun⟩ | .black ha hb => exact ⟨_, hp.del ⟨_, rfl, (ha.append hb).imp fun _ => ⟨⟩⟩ nofun⟩ · match h with | .red ha hb => exact ⟨_, _, hp.fill (.red ha hb)⟩ | .black ha hb => exact ⟨_, _, hp.fill (.black ha hb)⟩ theorem modify_eq_alter (t : RBNode α) : t.modify cut f = t.alter cut (.map f) := by simp [modify, alter] /-- The `modify` function preserves the ordering invariants. -/ protected theorem Ordered.modify {t : RBNode α} (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x) (h : t.Ordered cmp) : (modify cut f t).Ordered cmp := modify_eq_alter _ ▸ h.alter @fun | _, .node .., _, eq, rfl => by rw [eq] at H; exact ⟨H.RootOrdered_congr.2 (h.zoom eq).2.2.1.1, H⟩ /-- The `modify` function preserves the balance invariants. -/ protected theorem Balanced.modify {t : RBNode α} (h : t.Balanced c n) : ∃ c n, (t.modify cut f).Balanced c n := modify_eq_alter _ ▸ h.alter theorem WF.alter {t : RBNode α} (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x → p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x)) (h : WF cmp t) : WF cmp (alter cut f t) := let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.alter H, h₂.alter⟩ theorem WF.modify {t : RBNode α} (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x) (h : WF cmp t) : WF cmp (t.modify cut f) := let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.modify H, h₂.modify⟩ theorem find?_eq_zoom : ∀ {t : RBNode α} (p := .root), t.find? cut = (t.zoom cut p).1.root? | .nil, _ => rfl | .node .., _ => by unfold find? zoom; split <;> [apply find?_eq_zoom; apply find?_eq_zoom; rfl] end RBNode namespace RBSet open RBNode /-- A sufficient condition for `ModifyWF` is that the new element compares equal to the original. -/ theorem ModifyWF.of_eq {t : RBSet α cmp} (H : ∀ {x}, RBNode.find? cut t.val = some x → cmpEq cmp (f x) x) : ModifyWF t cut f := by refine ⟨.modify ?_ t.2⟩ revert H; rw [find?_eq_zoom] cases (t.1.zoom cut).1 <;> intro H <;> [trivial; exact H rfl] end RBSet namespace RBMap /-- `O(log n)`. In-place replace the corresponding to key `k`. This takes the element out of the tree while `f` runs, so it uses the element linearly if `t` is unshared. -/ def modify (t : RBMap α β cmp) (k : α) (f : β → β) : RBMap α β cmp := @RBSet.modifyP _ _ t (cmp k ·.1) (fun (a, b) => (a, f b)) (.of_eq fun _ => ⟨Std.ReflCmp.compare_self (cmp := Ordering.byKey Prod.fst cmp)⟩) /-- Auxiliary definition for `alter`. -/ def alter.adapt (k : α) (f : Option β → Option β) : Option (α × β) → Option (α × β) | none => match f none with | none => none | some v => some (k, v) | some (k', v') => match f (some v') with | none => none | some v => some (k', v) /-- `O(log n)`. `alterP cut f t` simultaneously handles inserting, erasing and replacing an element using a function `f : Option α → Option α`. It is passed the result of `t.findP? cut` and can either return `none` to remove the element or `some a` to replace/insert the element with `a` (which must have the same ordering properties as the original element). The element is used linearly if `t` is unshared. The `AlterWF` assumption is required because `f` may change the ordering properties of the element, which would break the invariants. -/ @[specialize] def alter (t : RBMap α β cmp) (k : α) (f : Option β → Option β) : RBMap α β cmp := by refine @RBSet.alterP _ _ t (cmp k ·.1) (alter.adapt k f) ⟨.alter (@fun _ t' p eq => ?_) t.2⟩ cases t' <;> simp [alter.adapt, RBNode.root?] <;> split <;> intro h <;> cases h · exact ⟨(t.2.out.1.zoom eq).2.2.2.toRootOrdered, ⟨⟩⟩ · refine ⟨(?a).RootOrdered_congr.2 (t.2.out.1.zoom eq).2.2.1.1, ?a⟩ exact ⟨Std.ReflCmp.compare_self (cmp := Ordering.byKey Prod.fst cmp)⟩ end RBMap ================================================ FILE: Batteries/Data/RBMap/Basic.lean ================================================ /- Copyright (c) 2017 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Mario Carneiro -/ module public import Batteries.Classes.Order public import Batteries.Control.ForInStep.Basic public import Batteries.Tactic.Lint.Misc @[expose] public section /-! # Red-black trees Note: users are recommended to use `Std.TreeMap` instead of `Batteries.RBMap`. `Std.TreeMap` is a mostly drop-in replacement (notably, there is no `ToStream` instance yet), and has more complete and consistent API. This implementation will eventually be deprecated. This module implements a type `RBMap α β cmp` which is a functional data structure for storing a key-value store in a binary search tree. It is built on the simpler `RBSet α cmp` type, which stores a set of values of type `α` using the function `cmp : α → α → Ordering` for determining the ordering relation. The tree will never store two elements that compare `.eq` under the `cmp` function, but the function does not have to satisfy `cmp x y = .eq → x = y`, and in the map case `α` is a key-value pair and the `cmp` function only compares the keys. -/ namespace Batteries /-- In a red-black tree, every node has a color which is either "red" or "black" (this particular choice of colors is conventional). A nil node is considered black. -/ inductive RBColor where /-- A red node is required to have black children. -/ | red /-- Every path from the root to a leaf must pass through the same number of black nodes. -/ | black deriving Repr /-- A red-black tree. (This is an internal implementation detail of the `RBSet` type, which includes the invariants of the tree.) This is a binary search tree augmented with a "color" field which is either red or black for each node and used to implement the re-balancing operations. See: [Red–black tree](https://en.wikipedia.org/wiki/Red%E2%80%93black_tree) -/ inductive RBNode (α : Type u) where /-- An empty tree. -/ | nil /-- A node consists of a value `v`, a subtree `l` of smaller items, and a subtree `r` of larger items. The color `c` is either `red` or `black` and participates in the red-black balance invariant (see `Balanced`). -/ | node (c : RBColor) (l : RBNode α) (v : α) (r : RBNode α) deriving Repr namespace RBNode open RBColor instance : EmptyCollection (RBNode α) := ⟨nil⟩ /-- The minimum element of a tree is the left-most value. -/ protected def min? : RBNode α → Option α | nil => none | node _ nil v _ => some v | node _ l _ _ => l.min? /-- The maximum element of a tree is the right-most value. -/ protected def max? : RBNode α → Option α | nil => none | node _ _ v nil => some v | node _ _ _ r => r.max? /-- Fold a function in tree order along the nodes. `v₀` is used at `nil` nodes and `f` is used to combine results at branching nodes. -/ @[specialize] def fold (v₀ : σ) (f : σ → α → σ → σ) : RBNode α → σ | nil => v₀ | node _ l v r => f (l.fold v₀ f) v (r.fold v₀ f) /-- Fold a function on the values from left to right (in increasing order). -/ @[specialize] def foldl (f : σ → α → σ) : (init : σ) → RBNode α → σ | b, nil => b | b, node _ l v r => foldl f (f (foldl f b l) v) r /-- Fold a function on the values from right to left (in decreasing order). -/ @[specialize] def foldr (f : α → σ → σ) : RBNode α → (init : σ) → σ | nil, b => b | node _ l v r, b => l.foldr f <| f v <| r.foldr f b /-- `O(n)`. Convert the tree to a list in ascending order. -/ def toList (t : RBNode α) : List α := t.foldr (·::·) [] /-- Run monadic function `f` on each element of the tree (in increasing order). -/ @[specialize] def forM [Monad m] (f : α → m PUnit) : RBNode α → m PUnit | nil => pure ⟨⟩ | node _ l v r => do forM f l; f v; forM f r /-- Fold a monadic function on the values from left to right (in increasing order). -/ @[specialize] def foldlM [Monad m] (f : σ → α → m σ) : (init : σ) → RBNode α → m σ | b, nil => pure b | b, node _ l v r => do foldlM f (← f (← foldlM f b l) v) r /-- Implementation of `for x in t` loops over a `RBNode` (in increasing order). -/ @[inline] protected def forIn [Monad m] (as : RBNode α) (init : σ) (f : α → σ → m (ForInStep σ)) : m σ := do ForInStep.run <$> visit as init where /-- Inner loop of `forIn`. -/ @[specialize] visit : RBNode α → σ → m (ForInStep σ) | nil, b => return ForInStep.yield b | node _ l v r, b => ForInStep.bindM (visit l b) fun b => ForInStep.bindM (f v b) (visit r ·) instance [Monad m] : ForIn m (RBNode α) α where forIn := RBNode.forIn /-- An auxiliary data structure (an iterator) over an `RBNode` which lazily pulls elements from the left. -/ protected inductive Stream (α : Type _) /-- The stream is empty. -/ | nil /-- We are ready to deliver element `v` with right child `r`, and where `tail` represents all the subtrees we have yet to destructure. -/ | cons (v : α) (r : RBNode α) (tail : RBNode.Stream α) /-- `O(log n)`. Turn a node into a stream, by descending along the left spine. -/ def toStream : RBNode α → (_ : RBNode.Stream α := .nil) → RBNode.Stream α | nil, acc => acc | node _ l v r, acc => toStream l (.cons v r acc) namespace Stream /-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/ def next? : RBNode.Stream α → Option (α × RBNode.Stream α) | nil => none | cons v r tail => some (v, toStream r tail) /-- Fold a function on the values from left to right (in increasing order). -/ @[specialize] def foldl (f : σ → α → σ) : (init : σ) → RBNode.Stream α → σ | b, nil => b | b, cons v r tail => foldl f (r.foldl f (f b v)) tail /-- Fold a function on the values from right to left (in decreasing order). -/ @[specialize] def foldr (f : α → σ → σ) : RBNode.Stream α → (init : σ) → σ | nil, b => b | cons v r tail, b => f v <| r.foldr f <| tail.foldr f b /-- `O(n)`. Convert the stream to a list in ascending order. -/ def toList (t : RBNode.Stream α) : List α := t.foldr (·::·) [] end Stream instance : Std.ToStream (RBNode α) (RBNode.Stream α) := ⟨(·.toStream)⟩ instance : Std.Stream (RBNode.Stream α) α := ⟨Stream.next?⟩ /-- Returns `true` iff every element of the tree satisfies `p`. -/ @[specialize] def all (p : α → Bool) : RBNode α → Bool | nil => true | node _ l v r => p v && all p l && all p r /-- Returns `true` iff any element of the tree satisfies `p`. -/ @[specialize] def any (p : α → Bool) : RBNode α → Bool | nil => false | node _ l v r => p v || any p l || any p r /-- Asserts that `p` holds on every element of the tree. -/ def All (p : α → Prop) : RBNode α → Prop | nil => True | node _ l v r => p v ∧ All p l ∧ All p r theorem All.imp (H : ∀ {x : α}, p x → q x) : ∀ {t : RBNode α}, t.All p → t.All q | nil => id | node .. => fun ⟨h, hl, hr⟩ => ⟨H h, hl.imp H, hr.imp H⟩ theorem all_iff {t : RBNode α} : t.all p ↔ t.All (p ·) := by induction t <;> simp [*, all, All, and_assoc] instance {t : RBNode α} [DecidablePred p] : Decidable (t.All p) := decidable_of_iff (t.all p) (by simp [all_iff]) /-- Asserts that `p` holds on some element of the tree. -/ def Any (p : α → Prop) : RBNode α → Prop | nil => False | node _ l v r => p v ∨ Any p l ∨ Any p r theorem any_iff {t : RBNode α} : t.any p ↔ t.Any (p ·) := by induction t <;> simp [*, any, Any, or_assoc] instance {t : RBNode α} [DecidablePred p] : Decidable (t.Any p) := decidable_of_iff (t.any p) (by simp [any_iff]) /-- True if `x` is an element of `t` "exactly", i.e. up to equality, not the `cmp` relation. -/ def EMem (x : α) (t : RBNode α) : Prop := t.Any (x = ·) instance : Membership α (RBNode α) where mem t x := EMem x t /-- True if the specified `cut` matches at least one element of of `t`. -/ def MemP (cut : α → Ordering) (t : RBNode α) : Prop := t.Any (cut · = .eq) /-- True if `x` is equivalent to an element of `t`. -/ @[reducible] def Mem (cmp : α → α → Ordering) (x : α) (t : RBNode α) : Prop := MemP (cmp x) t -- These instances are put in a special namespace because they are usually not what users want -- when deciding membership in a RBSet, since this does a naive linear search through the tree. -- The real `O(log n)` instances are defined in `Data.RBMap.Lemmas`. @[nolint docBlame] scoped instance Slow.instDecidableEMem [DecidableEq α] {t : RBNode α} : Decidable (EMem x t) := inferInstanceAs (Decidable (Any ..)) @[nolint docBlame] scoped instance Slow.instDecidableMemP {t : RBNode α} : Decidable (MemP cut t) := inferInstanceAs (Decidable (Any ..)) @[nolint docBlame] scoped instance Slow.instDecidableMem {t : RBNode α} : Decidable (Mem cmp x t) := inferInstanceAs (Decidable (Any ..)) /-- Asserts that `t₁` and `t₂` have the same number of elements in the same order, and `R` holds pairwise between them. The tree structure is ignored. -/ @[specialize] def all₂ (R : α → β → Bool) (t₁ : RBNode α) (t₂ : RBNode β) : Bool := let result := StateT.run (s := t₂.toStream) <| t₁.forM fun a s => do let (b, s) ← s.next? bif R a b then pure (⟨⟩, s) else none result matches some (_, .nil) instance [BEq α] : BEq (RBNode α) where beq a b := a.all₂ (· == ·) b /-- We say that `x < y` under the comparator `cmp` if `cmp x y = .lt`. * In order to avoid assuming the comparator is always lawful, we use a local `∀ [Std.TransCmp cmp]` binder in the relation so that the ordering properties of the tree only need to hold if the comparator is lawful. * The `Nonempty` wrapper is a no-op because this is already a proposition, but it prevents the `[Std.TransCmp cmp]` binder from being introduced when we don't want it. -/ def cmpLT (cmp : α → α → Ordering) (x y : α) : Prop := Nonempty (∀ [Std.TransCmp cmp], cmp x y = .lt) theorem cmpLT_iff [Std.TransCmp cmp] : cmpLT cmp x y ↔ cmp x y = .lt := ⟨fun ⟨h⟩ => h, (⟨·⟩)⟩ instance (cmp) [Std.TransCmp cmp] : Decidable (cmpLT cmp x y) := decidable_of_iff' _ cmpLT_iff /-- We say that `x ≈ y` under the comparator `cmp` if `cmp x y = .eq`. See also `cmpLT`. -/ def cmpEq (cmp : α → α → Ordering) (x y : α) : Prop := Nonempty (∀ [Std.TransCmp cmp], cmp x y = .eq) theorem cmpEq_iff [Std.TransCmp cmp] : cmpEq cmp x y ↔ cmp x y = .eq := ⟨fun ⟨h⟩ => h, (⟨·⟩)⟩ instance (cmp) [Std.TransCmp cmp] : Decidable (cmpEq cmp x y) := decidable_of_iff' _ cmpEq_iff /-- `O(n)`. Verifies an ordering relation on the nodes of the tree. -/ def isOrdered (cmp : α → α → Ordering) (t : RBNode α) (l : Option α := none) (r : Option α := none) : Bool := match t with | nil => match l, r with | some l, some r => cmp l r = .lt | _, _ => true | node _ a v b => isOrdered cmp a l v && isOrdered cmp b v r /-- The first half of Okasaki's `balance`, concerning red-red sequences in the left child. -/ @[inline] def balance1 : RBNode α → α → RBNode α → RBNode α | node red (node red a x b) y c, z, d | node red a x (node red b y c), z, d => node red (node black a x b) y (node black c z d) | a, x, b => node black a x b /-- The second half of Okasaki's `balance`, concerning red-red sequences in the right child. -/ @[inline] def balance2 : RBNode α → α → RBNode α → RBNode α | a, x, node red b y (node red c z d) | a, x, node red (node red b y c) z d => node red (node black a x b) y (node black c z d) | a, x, b => node black a x b /-- Returns `red` if the node is red, otherwise `black`. (Nil nodes are treated as `black`.) -/ @[inline] def isRed : RBNode α → RBColor | node c .. => c | _ => black /-- Returns `black` if the node is black, otherwise `red`. (Nil nodes are treated as `red`, which is not the usual convention but useful for deletion.) -/ @[inline] def isBlack : RBNode α → RBColor | node c .. => c | _ => red /-- Changes the color of the root to `black`. -/ def setBlack : RBNode α → RBNode α | nil => nil | node _ l v r => node black l v r /-- `O(n)`. Reverses the ordering of the tree without any rebalancing. -/ @[simp] def reverse : RBNode α → RBNode α | nil => nil | node c l v r => node c r.reverse v l.reverse section Insert /-- The core of the `insert` function. This adds an element `x` to a balanced red-black tree. Importantly, the result of calling `ins` is not a proper red-black tree, because it has a broken balance invariant. (See `Balanced.ins` for the balance invariant of `ins`.) The `insert` function does the final fixup needed to restore the invariant. -/ @[specialize] def ins (cmp : α → α → Ordering) (x : α) : RBNode α → RBNode α | nil => node red nil x nil | node red a y b => match cmp x y with | Ordering.lt => node red (ins cmp x a) y b | Ordering.gt => node red a y (ins cmp x b) | Ordering.eq => node red a x b | node black a y b => match cmp x y with | Ordering.lt => balance1 (ins cmp x a) y b | Ordering.gt => balance2 a y (ins cmp x b) | Ordering.eq => node black a x b /-- `insert cmp t v` inserts element `v` into the tree, using the provided comparator `cmp` to put it in the right place and automatically rebalancing the tree as necessary. -/ @[specialize] def insert (cmp : α → α → Ordering) (t : RBNode α) (v : α) : RBNode α := match isRed t with | red => (ins cmp v t).setBlack | black => ins cmp v t end Insert /-- Recolor the root of the tree to `red` if possible. -/ def setRed : RBNode α → RBNode α | node _ a v b => node red a v b | nil => nil /-- Rebalancing a tree which has shrunk on the left. -/ def balLeft (l : RBNode α) (v : α) (r : RBNode α) : RBNode α := match l with | node red a x b => node red (node black a x b) v r | l => match r with | node black a y b => balance2 l v (node red a y b) | node red (node black a y b) z c => node red (node black l v a) y (balance2 b z (setRed c)) | r => node red l v r -- unreachable /-- Rebalancing a tree which has shrunk on the right. -/ def balRight (l : RBNode α) (v : α) (r : RBNode α) : RBNode α := match r with | node red b y c => node red l v (node black b y c) | r => match l with | node black a x b => balance1 (node red a x b) v r | node red a x (node black b y c) => node red (balance1 (setRed a) x b) y (node black c v r) | l => node red l v r -- unreachable /-- The number of nodes in the tree. -/ @[simp] def size : RBNode α → Nat | nil => 0 | node _ x _ y => x.size + y.size + 1 /-- Concatenate two trees with the same black-height. -/ def append : RBNode α → RBNode α → RBNode α | nil, x | x, nil => x | node red a x b, node red c y d => match append b c with | node red b' z c' => node red (node red a x b') z (node red c' y d) | bc => node red a x (node red bc y d) | node black a x b, node black c y d => match append b c with | node red b' z c' => node red (node black a x b') z (node black c' y d) | bc => balLeft a x (node black bc y d) | a@(node black ..), node red b x c => node red (append a b) x c | node red a x b, c@(node black ..) => node red a x (append b c) termination_by x y => x.size + y.size /-! ## erase -/ /-- The core of the `erase` function. The tree returned from this function has a broken invariant, which is restored in `erase`. -/ @[specialize] def del (cut : α → Ordering) : RBNode α → RBNode α | nil => nil | node _ a y b => match cut y with | .lt => match a.isBlack with | black => balLeft (del cut a) y b | red => node red (del cut a) y b | .gt => match b.isBlack with | black => balRight a y (del cut b) | red => node red a y (del cut b) | .eq => append a b /-- The `erase cut t` function removes an element from the tree `t`. The `cut` function is used to locate an element in the tree: it returns `.gt` if we go too high and `.lt` if we go too low; if it returns `.eq` we will remove the element. (The function `cmp k` for some key `k` is a valid cut function, but we can also use cuts that are not of this form as long as they are suitably monotonic.) -/ @[specialize] def erase (cut : α → Ordering) (t : RBNode α) : RBNode α := (del cut t).setBlack /-- Finds an element in the tree satisfying the `cut` function. -/ @[specialize] def find? (cut : α → Ordering) : RBNode α → Option α | nil => none | node _ a y b => match cut y with | .lt => find? cut a | .gt => find? cut b | .eq => some y /-- `upperBound? cut` retrieves the smallest entry larger than or equal to `cut`, if it exists. -/ @[specialize] def upperBound? (cut : α → Ordering) : RBNode α → (ub : Option α := .none) → Option α | nil, ub => ub | node _ a y b, ub => match cut y with | .lt => upperBound? cut a (some y) | .gt => upperBound? cut b ub | .eq => some y /-- `lowerBound? cut` retrieves the largest entry smaller than or equal to `cut`, if it exists. -/ @[specialize] def lowerBound? (cut : α → Ordering) : RBNode α → (lb : Option α := .none) → Option α | nil, lb => lb | node _ a y b, lb => match cut y with | .lt => lowerBound? cut a lb | .gt => lowerBound? cut b (some y) | .eq => some y /-- Returns the root of the tree, if any. -/ def root? : RBNode α → Option α | nil => none | node _ _ v _ => some v /-- `O(n)`. Map a function on every value in the tree. This requires `IsMonotone` on the function in order to preserve the order invariant. -/ @[specialize] def map (f : α → β) : RBNode α → RBNode β | nil => nil | node c l v r => node c (l.map f) (f v) (r.map f) /-- Converts the tree into an array in increasing sorted order. -/ def toArray (n : RBNode α) : Array α := n.foldl (init := #[]) (·.push ·) /-- A `RBNode.Path α` is a "cursor" into an `RBNode` which represents the path from the root to a subtree. Note that the path goes from the target subtree up to the root, which is reversed from the normal way data is stored in the tree. See [Zipper](https://en.wikipedia.org/wiki/Zipper_(data_structure)) for more information. -/ inductive Path (α : Type u) where /-- The root of the tree, which is the end of the path of parents. -/ | root /-- A path that goes down the left subtree. -/ | left (c : RBColor) (parent : Path α) (v : α) (r : RBNode α) /-- A path that goes down the right subtree. -/ | right (c : RBColor) (l : RBNode α) (v : α) (parent : Path α) /-- Fills the `Path` with a subtree. -/ def Path.fill : Path α → RBNode α → RBNode α | .root, t => t | .left c parent y b, a | .right c a y parent, b => parent.fill (node c a y b) /-- Like `find?`, but instead of just returning the element, it returns the entire subtree at the element and a path back to the root for reconstructing the tree. -/ @[specialize] def zoom (cut : α → Ordering) : RBNode α → (e : Path α := .root) → RBNode α × Path α | nil, path => (nil, path) | n@(node c a y b), path => match cut y with | .lt => zoom cut a (.left c path y b) | .gt => zoom cut b (.right c a y path) | .eq => (n, path) /-- This function does the second part of `RBNode.ins`, which unwinds the stack and rebuilds the tree. -/ def Path.ins : Path α → RBNode α → RBNode α | .root, t => t.setBlack | .left red parent y b, a | .right red a y parent, b => parent.ins (node red a y b) | .left black parent y b, a => parent.ins (balance1 a y b) | .right black a y parent, b => parent.ins (balance2 a y b) /-- `path.insertNew v` inserts element `v` into the tree, assuming that `path` is zoomed in on a `nil` node such that inserting a new element at this position is valid. -/ @[inline] def Path.insertNew (path : Path α) (v : α) : RBNode α := path.ins (node red nil v nil) /-- `path.insert t v` inserts element `v` into the tree, assuming that `(t, path)` was the result of a previous `zoom` operation (so either the root of `t` is equivalent to `v` or it is empty). -/ def Path.insert (path : Path α) (t : RBNode α) (v : α) : RBNode α := match t with | nil => path.insertNew v | node c a _ b => path.fill (node c a v b) /-- `path.del t c` does the second part of `RBNode.del`, which unwinds the stack and rebuilds the tree. The `c` argument is the color of the node before the deletion (we used `t₀.isBlack` for this in `RBNode.del` but the original tree is no longer available in this formulation). -/ def Path.del : Path α → RBNode α → RBColor → RBNode α | .root, t, _ => t.setBlack | .left c parent y b, a, red | .right c a y parent, b, red => parent.del (node red a y b) c | .left c parent y b, a, black => parent.del (balLeft a y b) c | .right c a y parent, b, black => parent.del (balRight a y b) c /-- `path.erase t v` removes the root element of `t` from the tree, assuming that `(t, path)` was the result of a previous `zoom` operation. -/ def Path.erase (path : Path α) (t : RBNode α) : RBNode α := match t with | nil => path.fill nil | node c a _ b => path.del (a.append b) c /-- `modify cut f t` uses `cut` to find an element, then modifies the element using `f` and reinserts it into the tree. Because the tree structure is not modified, `f` must not modify the ordering properties of the element. The element in `t` is used linearly if `t` is unshared. -/ @[specialize] def modify (cut : α → Ordering) (f : α → α) (t : RBNode α) : RBNode α := match zoom cut t with | (nil, _) => t -- TODO: profile whether it would be better to use `path.fill nil` here | (node c a x b, path) => path.fill (node c a (f x) b) /-- `alter cut f t` simultaneously handles inserting, erasing and replacing an element using a function `f : Option α → Option α`. It is passed the result of `t.find? cut` and can either return `none` to remove the element or `some a` to replace/insert the element with `a` (which must have the same ordering properties as the original element). The element is used linearly if `t` is unshared. -/ @[specialize] def alter (cut : α → Ordering) (f : Option α → Option α) (t : RBNode α) : RBNode α := match zoom cut t with | (nil, path) => match f none with | none => t -- TODO: profile whether it would be better to use `path.fill nil` here | some y => path.insertNew y | (node c a x b, path) => match f (some x) with | none => path.del (a.append b) c | some y => path.fill (node c a y b) /-- The ordering invariant of a red-black tree, which is a binary search tree. This says that every element of a left subtree is less than the root, and every element in the right subtree is greater than the root, where the less than relation `x < y` is understood to mean `cmp x y = .lt`. Because we do not assume that `cmp` is lawful when stating this property, we write it in such a way that if `cmp` is not lawful then the condition holds trivially. That way we can prove the ordering invariants without assuming `cmp` is lawful. -/ def Ordered (cmp : α → α → Ordering) : RBNode α → Prop | nil => True | node _ a x b => a.All (cmpLT cmp · x) ∧ b.All (cmpLT cmp x ·) ∧ a.Ordered cmp ∧ b.Ordered cmp -- This is in the Slow namespace because it is `O(n^2)` where a `O(n)` algorithm exists -- (see `isOrdered_iff` in `Data.RBMap.Lemmas`). Prefer `isOrdered` or the other instance. @[nolint docBlame] scoped instance Slow.instDecidableOrdered (cmp) [Std.TransCmp cmp] : ∀ t : RBNode α, Decidable (Ordered cmp t) | nil => inferInstanceAs (Decidable True) | node _ a _ b => haveI := instDecidableOrdered cmp a haveI := instDecidableOrdered cmp b inferInstanceAs (Decidable (And ..)) /-- The red-black balance invariant. `Balanced t c n` says that the color of the root node is `c`, and the black-height (the number of black nodes on any path from the root) of the tree is `n`. Additionally, every red node must have black children. -/ inductive Balanced : RBNode α → RBColor → Nat → Prop where /-- A nil node is balanced with black-height 0, and it is considered black. -/ | protected nil : Balanced nil black 0 /-- A red node is balanced with black-height `n` if its children are both black with with black-height `n`. -/ | protected red : Balanced x black n → Balanced y black n → Balanced (node red x v y) red n /-- A black node is balanced with black-height `n + 1` if its children both have black-height `n`. -/ | protected black : Balanced x c₁ n → Balanced y c₂ n → Balanced (node black x v y) black (n + 1) /-- The well-formedness invariant for a red-black tree. The first constructor is the real invariant, and the others allow us to "cheat" in this file and define `insert` and `erase`, which have more complex proofs that are delayed to `Batteries.Data.RBMap.Lemmas`. -/ inductive WF (cmp : α → α → Ordering) : RBNode α → Prop /-- The actual well-formedness invariant: a red-black tree has the ordering and balance invariants. -/ | mk : t.Ordered cmp → t.Balanced c n → WF cmp t /-- Inserting into a well-formed tree yields another well-formed tree. (See `Ordered.insert` and `Balanced.insert` for the actual proofs.) -/ | insert : WF cmp t → WF cmp (t.insert cmp a) /-- Erasing from a well-formed tree yields another well-formed tree. (See `Ordered.erase` and `Balanced.erase` for the actual proofs.) -/ | erase : WF cmp t → WF cmp (t.erase cut) end RBNode open RBNode /-- An `RBSet` is a self-balancing binary search tree. The `cmp` function is the comparator that will be used for performing searches; it should satisfy the requirements of `TransCmp` for it to have sensible behavior. -/ def RBSet (α : Type u) (cmp : α → α → Ordering) : Type u := {t : RBNode α // t.WF cmp} /-- `O(1)`. Construct a new empty tree. -/ @[inline] def mkRBSet (α : Type u) (cmp : α → α → Ordering) : RBSet α cmp := ⟨.nil, .mk ⟨⟩ .nil⟩ namespace RBSet /-- `O(1)`. Construct a new empty tree. -/ @[inline] def empty : RBSet α cmp := mkRBSet .. instance (α : Type u) (cmp : α → α → Ordering) : EmptyCollection (RBSet α cmp) := ⟨empty⟩ instance (α : Type u) (cmp : α → α → Ordering) : Inhabited (RBSet α cmp) := ⟨∅⟩ /-- `O(1)`. Construct a new tree with one element `v`. -/ @[inline] def single (v : α) : RBSet α cmp := ⟨.node .red .nil v .nil, .mk ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ (.red .nil .nil)⟩ /-- `O(n)`. Fold a function on the values from left to right (in increasing order). -/ @[inline] def foldl (f : σ → α → σ) (init : σ) (t : RBSet α cmp) : σ := t.1.foldl f init /-- `O(n)`. Fold a function on the values from right to left (in decreasing order). -/ @[inline] def foldr (f : α → σ → σ) (init : σ) (t : RBSet α cmp) : σ := t.1.foldr f init /-- `O(n)`. Fold a monadic function on the values from left to right (in increasing order). -/ @[inline] def foldlM [Monad m] (f : σ → α → m σ) (init : σ) (t : RBSet α cmp) : m σ := t.1.foldlM f init /-- `O(n)`. Run monadic function `f` on each element of the tree (in increasing order). -/ @[inline] def forM [Monad m] (f : α → m PUnit) (t : RBSet α cmp) : m PUnit := t.1.forM f instance [Monad m] : ForIn m (RBSet α cmp) α where forIn t := t.1.forIn instance : Std.ToStream (RBSet α cmp) (RBNode.Stream α) := ⟨fun x => x.1.toStream .nil⟩ /-- `O(1)`. Is the tree empty? -/ @[inline] def isEmpty : RBSet α cmp → Bool | ⟨nil, _⟩ => true | _ => false /-- `O(n)`. Convert the tree to a list in ascending order. -/ @[inline] def toList (t : RBSet α cmp) : List α := t.1.toList /-- `O(log n)`. Returns the entry `a` such that `a ≤ k` for all keys in the RBSet. -/ @[inline] protected def min? (t : RBSet α cmp) : Option α := t.1.min? /-- `O(log n)`. Returns the entry `a` such that `a ≥ k` for all keys in the RBSet. -/ @[inline] protected def max? (t : RBSet α cmp) : Option α := t.1.max? instance [Repr α] : Repr (RBSet α cmp) where reprPrec m prec := Repr.addAppParen ("RBSet.ofList " ++ repr m.toList) prec /-- `O(log n)`. Insert element `v` into the tree. -/ @[inline] def insert (t : RBSet α cmp) (v : α) : RBSet α cmp := ⟨t.1.insert cmp v, t.2.insert⟩ /-- Insert all elements from a collection into a `RBSet α cmp`. -/ def insertMany [ForIn Id ρ α] (s : RBSet α cmp) (as : ρ) : RBSet α cmp := Id.run do let mut s := s for a in as do s := s.insert a return s /-- `O(log n)`. Remove an element from the tree using a cut function. The `cut` function is used to locate an element in the tree: it returns `.gt` if we go too high and `.lt` if we go too low; if it returns `.eq` we will remove the element. (The function `cmp k` for some key `k` is a valid cut function, but we can also use cuts that are not of this form as long as they are suitably monotonic.) -/ @[inline] def erase (t : RBSet α cmp) (cut : α → Ordering) : RBSet α cmp := ⟨t.1.erase cut, t.2.erase⟩ /-- `O(log n)`. Find an element in the tree using a cut function. -/ @[inline] def findP? (t : RBSet α cmp) (cut : α → Ordering) : Option α := t.1.find? cut /-- `O(log n)`. Returns an element in the tree equivalent to `x` if one exists. -/ @[inline] def find? (t : RBSet α cmp) (x : α) : Option α := t.1.find? (cmp x) /-- `O(log n)`. Find an element in the tree, or return a default value `v₀`. -/ @[inline] def findPD (t : RBSet α cmp) (cut : α → Ordering) (v₀ : α) : α := (t.findP? cut).getD v₀ /-- `O(log n)`. `upperBoundP cut` retrieves the smallest entry comparing `gt` or `eq` under `cut`, if it exists. If multiple keys in the map return `eq` under `cut`, any of them may be returned. -/ @[inline] def upperBoundP? (t : RBSet α cmp) (cut : α → Ordering) : Option α := t.1.upperBound? cut /-- `O(log n)`. `upperBound? k` retrieves the largest entry smaller than or equal to `k`, if it exists. -/ @[inline] def upperBound? (t : RBSet α cmp) (k : α) : Option α := t.upperBoundP? (cmp k) /-- `O(log n)`. `lowerBoundP cut` retrieves the largest entry comparing `lt` or `eq` under `cut`, if it exists. If multiple keys in the map return `eq` under `cut`, any of them may be returned. -/ @[inline] def lowerBoundP? (t : RBSet α cmp) (cut : α → Ordering) : Option α := t.1.lowerBound? cut /-- `O(log n)`. `lowerBound? k` retrieves the largest entry smaller than or equal to `k`, if it exists. -/ @[inline] def lowerBound? (t : RBSet α cmp) (k : α) : Option α := t.lowerBoundP? (cmp k) /-- `O(log n)`. Returns true if the given cut returns `eq` for something in the RBSet. -/ @[inline] def containsP (t : RBSet α cmp) (cut : α → Ordering) : Bool := (t.findP? cut).isSome /-- `O(log n)`. Returns true if the given key `a` is in the RBSet. -/ @[inline] def contains (t : RBSet α cmp) (a : α) : Bool := (t.find? a).isSome /-- `O(n log n)`. Build a tree from an unsorted list by inserting them one at a time. -/ @[inline] def ofList (l : List α) (cmp : α → α → Ordering) : RBSet α cmp := l.foldl (fun r p => r.insert p) (mkRBSet α cmp) /-- `O(n log n)`. Build a tree from an unsorted array by inserting them one at a time. -/ @[inline] def ofArray (l : Array α) (cmp : α → α → Ordering) : RBSet α cmp := l.foldl (fun r p => r.insert p) (mkRBSet α cmp) /-- `O(n)`. Returns true if the given predicate is true for all items in the RBSet. -/ @[inline] def all (t : RBSet α cmp) (p : α → Bool) : Bool := t.1.all p /-- `O(n)`. Returns true if the given predicate is true for any item in the RBSet. -/ @[inline] def any (t : RBSet α cmp) (p : α → Bool) : Bool := t.1.any p /-- Asserts that `t₁` and `t₂` have the same number of elements in the same order, and `R` holds pairwise between them. The tree structure is ignored. -/ @[inline] def all₂ (R : α → β → Bool) (t₁ : RBSet α cmpα) (t₂ : RBSet β cmpβ) : Bool := t₁.1.all₂ R t₂.1 /-- True if `x` is an element of `t` "exactly", i.e. up to equality, not the `cmp` relation. -/ def EMem (x : α) (t : RBSet α cmp) : Prop := t.1.EMem x /-- True if the specified `cut` matches at least one element of of `t`. -/ def MemP (cut : α → Ordering) (t : RBSet α cmp) : Prop := t.1.MemP cut /-- True if `x` is equivalent to an element of `t`. -/ def Mem (x : α) (t : RBSet α cmp) : Prop := MemP (cmp x) t instance : Membership α (RBSet α cmp) where mem t x := Mem x t -- These instances are put in a special namespace because they are usually not what users want -- when deciding membership in a RBSet, since this does a naive linear search through the tree. -- The real `O(log n)` instances are defined in `Data.RBMap.Lemmas`. @[nolint docBlame] scoped instance Slow.instDecidableEMem [DecidableEq α] {t : RBSet α cmp} : Decidable (EMem x t) := inferInstanceAs (Decidable (Any ..)) @[nolint docBlame] scoped instance Slow.instDecidableMemP {t : RBSet α cmp} : Decidable (MemP cut t) := inferInstanceAs (Decidable (Any ..)) @[nolint docBlame] scoped instance Slow.instDecidableMem {t : RBSet α cmp} : Decidable (Mem x t) := inferInstanceAs (Decidable (Any ..)) /-- Returns true if `t₁` and `t₂` are equal as sets (assuming `cmp` and `==` are compatible), ignoring the internal tree structure. -/ instance [BEq α] : BEq (RBSet α cmp) where beq a b := a.all₂ (· == ·) b /-- `O(n)`. The number of items in the RBSet. -/ def size (m : RBSet α cmp) : Nat := m.1.size /-- `O(log n)`. Returns the minimum element of the tree, or panics if the tree is empty. -/ @[inline] def min! [Inhabited α] (t : RBSet α cmp) : α := t.min?.getD (panic! "tree is empty") /-- `O(log n)`. Returns the maximum element of the tree, or panics if the tree is empty. -/ @[inline] def max! [Inhabited α] (t : RBSet α cmp) : α := t.max?.getD (panic! "tree is empty") /-- `O(log n)`. Attempts to find the value with key `k : α` in `t` and panics if there is no such key. -/ @[inline] def findP! [Inhabited α] (t : RBSet α cmp) (cut : α → Ordering) : α := (t.findP? cut).getD (panic! "key is not in the tree") /-- `O(log n)`. Attempts to find the value with key `k : α` in `t` and panics if there is no such key. -/ @[inline] def find! [Inhabited α] (t : RBSet α cmp) (k : α) : α := (t.find? k).getD (panic! "key is not in the tree") /-- The predicate asserting that the result of `modifyP` is safe to construct. -/ class ModifyWF (t : RBSet α cmp) (cut : α → Ordering) (f : α → α) : Prop where /-- The resulting tree is well formed. -/ wf : (t.1.modify cut f).WF cmp /-- `O(log n)`. In-place replace an element found by `cut`. This takes the element out of the tree while `f` runs, so it uses the element linearly if `t` is unshared. The `ModifyWF` assumption is required because `f` may change the ordering properties of the element, which would break the invariants. -/ def modifyP (t : RBSet α cmp) (cut : α → Ordering) (f : α → α) [wf : ModifyWF t cut f] : RBSet α cmp := ⟨t.1.modify cut f, wf.wf⟩ /-- The predicate asserting that the result of `alterP` is safe to construct. -/ class AlterWF (t : RBSet α cmp) (cut : α → Ordering) (f : Option α → Option α) : Prop where /-- The resulting tree is well formed. -/ wf : (t.1.alter cut f).WF cmp /-- `O(log n)`. `alterP cut f t` simultaneously handles inserting, erasing and replacing an element using a function `f : Option α → Option α`. It is passed the result of `t.findP? cut` and can either return `none` to remove the element or `some a` to replace/insert the element with `a` (which must have the same ordering properties as the original element). The element is used linearly if `t` is unshared. The `AlterWF` assumption is required because `f` may change the ordering properties of the element, which would break the invariants. -/ def alterP (t : RBSet α cmp) (cut : α → Ordering) (f : Option α → Option α) [wf : AlterWF t cut f] : RBSet α cmp := ⟨t.1.alter cut f, wf.wf⟩ /-- `O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`. If equal keys exist in both, the key from `t₂` is preferred. -/ def union (t₁ t₂ : RBSet α cmp) : RBSet α cmp := t₂.foldl .insert t₁ instance : Union (RBSet α cmp) := ⟨RBSet.union⟩ /-- `O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`. If equal keys exist in both, then use `mergeFn a₁ a₂` to produce the new merged value. -/ def mergeWith (mergeFn : α → α → α) (t₁ t₂ : RBSet α cmp) : RBSet α cmp := t₂.foldl (init := t₁) fun t₁ a₂ => t₁.insert <| match t₁.find? a₂ with | some a₁ => mergeFn a₁ a₂ | none => a₂ /-- `O(n₁ * log (n₁ + n₂))`. Intersects the maps `t₁` and `t₂` using `mergeFn a b` to produce the new value. -/ def intersectWith (cmp : α → β → Ordering) (mergeFn : α → β → γ) (t₁ : RBSet α cmpα) (t₂ : RBSet β cmpβ) : RBSet γ cmpγ := t₁.foldl (init := ∅) fun acc a => match t₂.findP? (cmp a) with | some b => acc.insert <| mergeFn a b | none => acc /-- `O(n * log n)`. Constructs the set of all elements satisfying `p`. -/ def filter (t : RBSet α cmp) (p : α → Bool) : RBSet α cmp := t.foldl (init := ∅) fun acc a => bif p a then acc.insert a else acc /-- `O(n * log n)`. Map a function on every value in the set. If the function is monotone, consider using the more efficient `RBSet.mapMonotone` instead. -/ def map (t : RBSet α cmpα) (f : α → β) : RBSet β cmpβ := t.foldl (init := ∅) fun acc a => acc.insert <| f a /-- `O(n₁ * (log n₁ + log n₂))`. Constructs the set of all elements of `t₁` that are not in `t₂`. -/ def sdiff (t₁ t₂ : RBSet α cmp) : RBSet α cmp := t₁.filter (!t₂.contains ·) instance : SDiff (Batteries.RBSet α cmp) := ⟨RBSet.sdiff⟩ end RBSet /- TODO(Leo): define dRBMap -/ /-- An `RBMap` is a self-balancing binary search tree, used to store a key-value map. The `cmp` function is the comparator that will be used for performing searches; it should satisfy the requirements of `TransCmp` for it to have sensible behavior. -/ def RBMap (α : Type u) (β : Type v) (cmp : α → α → Ordering) : Type (max u v) := RBSet (α × β) (Ordering.byKey Prod.fst cmp) /-- `O(1)`. Construct a new empty map. -/ @[inline] def mkRBMap (α : Type u) (β : Type v) (cmp : α → α → Ordering) : RBMap α β cmp := mkRBSet .. /-- `O(1)`. Construct a new empty map. -/ @[inline] def RBMap.empty {α : Type u} {β : Type v} {cmp : α → α → Ordering} : RBMap α β cmp := mkRBMap .. instance (α : Type u) (β : Type v) (cmp : α → α → Ordering) : EmptyCollection (RBMap α β cmp) := ⟨RBMap.empty⟩ instance (α : Type u) (β : Type v) (cmp : α → α → Ordering) : Inhabited (RBMap α β cmp) := ⟨∅⟩ /-- `O(1)`. Construct a new tree with one key-value pair `k, v`. -/ @[inline] def RBMap.single (k : α) (v : β) : RBMap α β cmp := RBSet.single (k, v) namespace RBMap variable {α : Type u} {β : Type v} {σ : Type w} {cmp : α → α → Ordering} /-- `O(n)`. Fold a function on the values from left to right (in increasing order). -/ @[inline] def foldl (f : σ → α → β → σ) : (init : σ) → RBMap α β cmp → σ | b, ⟨t, _⟩ => t.foldl (fun s (a, b) => f s a b) b /-- `O(n)`. Fold a function on the values from right to left (in decreasing order). -/ @[inline] def foldr (f : α → β → σ → σ) : (init : σ) → RBMap α β cmp → σ | b, ⟨t, _⟩ => t.foldr (fun (a, b) s => f a b s) b /-- `O(n)`. Fold a monadic function on the values from left to right (in increasing order). -/ @[inline] def foldlM [Monad m] (f : σ → α → β → m σ) : (init : σ) → RBMap α β cmp → m σ | b, ⟨t, _⟩ => t.foldlM (fun s (a, b) => f s a b) b /-- `O(n)`. Run monadic function `f` on each element of the tree (in increasing order). -/ @[inline] def forM [Monad m] (f : α → β → m PUnit) (t : RBMap α β cmp) : m PUnit := t.1.forM (fun (a, b) => f a b) instance [Monad m] : ForIn m (RBMap α β cmp) (α × β) := inferInstanceAs (ForIn _ (RBSet ..) _) instance : Std.ToStream (RBMap α β cmp) (RBNode.Stream (α × β)) := inferInstanceAs (Std.ToStream (RBSet ..) _) /-- `O(n)`. Constructs the array of keys of the map. -/ @[inline] def keysArray (t : RBMap α β cmp) : Array α := t.1.foldl (init := #[]) (·.push ·.1) /-- `O(n)`. Constructs the list of keys of the map. -/ @[inline] def keysList (t : RBMap α β cmp) : List α := t.1.foldr (init := []) (·.1 :: ·) /-- An "iterator" over the keys of the map. This is a trivial wrapper over the underlying map, but it comes with a small API to use it in a `for` loop or convert it to an array or list. -/ def Keys (α β cmp) := RBMap α β cmp /-- The keys of the map. This is an `O(1)` wrapper operation, which can be used in `for` loops or converted to an array or list. -/ @[inline] def keys (t : RBMap α β cmp) : Keys α β cmp := t @[inline, inherit_doc keysArray] def Keys.toArray := @keysArray @[inline, inherit_doc keysList] def Keys.toList := @keysList instance : CoeHead (Keys α β cmp) (Array α) := ⟨keysArray⟩ instance : CoeHead (Keys α β cmp) (List α) := ⟨keysList⟩ instance [Monad m] : ForIn m (Keys α β cmp) α where forIn t init f := t.val.forIn init (f ·.1) instance [Monad m] : ForM m (Keys α β cmp) α where forM t f := t.val.forM (f ·.1) /-- The result of `toStream` on a `Keys`. -/ def Keys.Stream (α β) := RBNode.Stream (α × β) /-- A stream over the iterator. -/ def Keys.toStream (t : Keys α β cmp) : Keys.Stream α β := t.1.toStream /-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/ def Keys.Stream.next? (t : Stream α β) : Option (α × Stream α β) := match inline (RBNode.Stream.next? t) with | none => none | some ((a, _), t) => some (a, t) instance : Std.ToStream (Keys α β cmp) (Keys.Stream α β) := ⟨Keys.toStream⟩ instance : Std.Stream (Keys.Stream α β) α := ⟨Keys.Stream.next?⟩ /-- `O(n)`. Constructs the array of values of the map. -/ @[inline] def valuesArray (t : RBMap α β cmp) : Array β := t.1.foldl (init := #[]) (·.push ·.2) /-- `O(n)`. Constructs the list of values of the map. -/ @[inline] def valuesList (t : RBMap α β cmp) : List β := t.1.foldr (init := []) (·.2 :: ·) /-- An "iterator" over the values of the map. This is a trivial wrapper over the underlying map, but it comes with a small API to use it in a `for` loop or convert it to an array or list. -/ def Values (α β cmp) := RBMap α β cmp /-- The "keys" of the map. This is an `O(1)` wrapper operation, which can be used in `for` loops or converted to an array or list. -/ @[inline] def values (t : RBMap α β cmp) : Values α β cmp := t @[inline, inherit_doc valuesArray] def Values.toArray := @valuesArray @[inline, inherit_doc valuesList] def Values.toList := @valuesList instance : CoeHead (Values α β cmp) (Array β) := ⟨valuesArray⟩ instance : CoeHead (Values α β cmp) (List β) := ⟨valuesList⟩ instance [Monad m] : ForIn m (Values α β cmp) β where forIn t init f := t.val.forIn init (f ·.2) instance [Monad m] : ForM m (Values α β cmp) β where forM t f := t.val.forM (f ·.2) /-- The result of `toStream` on a `Values`. -/ def Values.Stream (α β) := RBNode.Stream (α × β) /-- A stream over the iterator. -/ def Values.toStream (t : Values α β cmp) : Values.Stream α β := t.1.toStream /-- `O(1)` amortized, `O(log n)` worst case: Get the next element from the stream. -/ def Values.Stream.next? (t : Stream α β) : Option (β × Stream α β) := match inline (RBNode.Stream.next? t) with | none => none | some ((_, b), t) => some (b, t) instance : Std.ToStream (Values α β cmp) (Values.Stream α β) := ⟨Values.toStream⟩ instance : Std.Stream (Values.Stream α β) β := ⟨Values.Stream.next?⟩ /-- `O(1)`. Is the tree empty? -/ @[inline] def isEmpty : RBMap α β cmp → Bool := RBSet.isEmpty /-- `O(n)`. Convert the tree to a list in ascending order. -/ @[inline] def toList : RBMap α β cmp → List (α × β) := RBSet.toList /-- `O(log n)`. Returns the key-value pair `(a, b)` such that `a ≤ k` for all keys in the RBMap. -/ @[inline] protected def min? : RBMap α β cmp → Option (α × β) := RBSet.min? /-- `O(log n)`. Returns the key-value pair `(a, b)` such that `a ≥ k` for all keys in the RBMap. -/ @[inline] protected def max? : RBMap α β cmp → Option (α × β) := RBSet.max? instance [Repr α] [Repr β] : Repr (RBMap α β cmp) where reprPrec m prec := Repr.addAppParen ("RBMap.ofList " ++ repr m.toList) prec /-- `O(log n)`. Insert key-value pair `(k, v)` into the tree. -/ @[inline] def insert (t : RBMap α β cmp) (k : α) (v : β) : RBMap α β cmp := RBSet.insert t (k, v) /-- `O(log n)`. Remove an element `k` from the map. -/ @[inline] def erase (t : RBMap α β cmp) (k : α) : RBMap α β cmp := RBSet.erase t (cmp k ·.1) /-- `O(n log n)`. Build a tree from an unsorted list by inserting them one at a time. -/ @[inline] def ofList (l : List (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp := RBSet.ofList l _ /-- `O(n log n)`. Build a tree from an unsorted array by inserting them one at a time. -/ @[inline] def ofArray (l : Array (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp := RBSet.ofArray l _ /-- `O(log n)`. Find an entry in the tree with key equal to `k`. -/ @[inline] def findEntry? (t : RBMap α β cmp) (k : α) : Option (α × β) := t.findP? (cmp k ·.1) /-- `O(log n)`. Find the value corresponding to key `k`. -/ @[inline] def find? (t : RBMap α β cmp) (k : α) : Option β := t.findEntry? k |>.map (·.2) /-- `O(log n)`. Find the value corresponding to key `k`, or return `v₀` if it is not in the map. -/ @[inline] def findD (t : RBMap α β cmp) (k : α) (v₀ : β) : β := (t.find? k).getD v₀ /-- `O(log n)`. `lowerBound? k` retrieves the key-value pair of the largest key smaller than or equal to `k`, if it exists. -/ @[inline] def lowerBound? (t : RBMap α β cmp) (k : α) : Option (α × β) := RBSet.lowerBoundP? t (cmp k ·.1) /-- `O(log n)`. Returns true if the given key `a` is in the RBMap. -/ @[inline] def contains (t : RBMap α β cmp) (a : α) : Bool := (t.findEntry? a).isSome /-- `O(n)`. Returns true if the given predicate is true for all items in the RBMap. -/ @[inline] def all (t : RBMap α β cmp) (p : α → β → Bool) : Bool := RBSet.all t fun (a, b) => p a b /-- `O(n)`. Returns true if the given predicate is true for any item in the RBMap. -/ @[inline] def any (t : RBMap α β cmp) (p : α → β → Bool) : Bool := RBSet.any t fun (a, b) => p a b /-- Asserts that `t₁` and `t₂` have the same number of elements in the same order, and `R` holds pairwise between them. The tree structure is ignored. -/ @[inline] def all₂ (R : α × β → γ × δ → Bool) (t₁ : RBMap α β cmpα) (t₂ : RBMap γ δ cmpγ) : Bool := RBSet.all₂ R t₁ t₂ /-- Asserts that `t₁` and `t₂` have the same set of keys (up to equality). -/ @[inline] def eqKeys (t₁ : RBMap α β cmp) (t₂ : RBMap α γ cmp) : Bool := t₁.all₂ (cmp ·.1 ·.1 = .eq) t₂ /-- Returns true if `t₁` and `t₂` have the same keys and values (assuming `cmp` and `==` are compatible), ignoring the internal tree structure. -/ instance [BEq α] [BEq β] : BEq (RBMap α β cmp) := inferInstanceAs (BEq (RBSet ..)) /-- `O(n)`. The number of items in the RBMap. -/ def size : RBMap α β cmp → Nat := RBSet.size /-- `O(log n)`. Returns the minimum element of the map, or panics if the map is empty. -/ @[inline] def min! [Inhabited α] [Inhabited β] : RBMap α β cmp → α × β := RBSet.min! /-- `O(log n)`. Returns the maximum element of the map, or panics if the map is empty. -/ @[inline] def max! [Inhabited α] [Inhabited β] : RBMap α β cmp → α × β := RBSet.max! /-- Attempts to find the value with key `k : α` in `t` and panics if there is no such key. -/ @[inline] def find! [Inhabited β] (t : RBMap α β cmp) (k : α) : β := (t.find? k).getD (panic! "key is not in the map") /-- `O(n₂ * log (n₁ + n₂))`. Merges the maps `t₁` and `t₂`, if a key `a : α` exists in both, then use `mergeFn a b₁ b₂` to produce the new merged value. -/ def mergeWith (mergeFn : α → β → β → β) (t₁ t₂ : RBMap α β cmp) : RBMap α β cmp := RBSet.mergeWith (fun (_, b₁) (a, b₂) => (a, mergeFn a b₁ b₂)) t₁ t₂ /-- `O(n₁ * log (n₁ + n₂))`. Intersects the maps `t₁` and `t₂` using `mergeFn a b` to produce the new value. -/ def intersectWith (mergeFn : α → β → γ → δ) (t₁ : RBMap α β cmp) (t₂ : RBMap α γ cmp) : RBMap α δ cmp := RBSet.intersectWith (cmp ·.1 ·.1) (fun (a, b₁) (_, b₂) => (a, mergeFn a b₁ b₂)) t₁ t₂ /-- `O(n * log n)`. Constructs the set of all elements satisfying `p`. -/ def filter (t : RBMap α β cmp) (p : α → β → Bool) : RBMap α β cmp := RBSet.filter t fun (a, b) => p a b /-- `O(n₁ * (log n₁ + log n₂))`. Constructs the set of all elements of `t₁` that are not in `t₂`. -/ def sdiff (t₁ t₂ : RBMap α β cmp) : RBMap α β cmp := t₁.filter fun a _ => !t₂.contains a end RBMap end Batteries open Batteries @[inherit_doc RBMap.ofList] abbrev List.toRBMap (l : List (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp := RBMap.ofList l cmp ================================================ FILE: Batteries/Data/RBMap/Depth.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.RBMap.WF @[expose] public section /-! # RBNode depth bounds -/ namespace Batteries.RBNode open RBColor /-- `O(n)`. `depth t` is the maximum number of nodes on any path to a leaf. It is an upper bound on most tree operations. -/ def depth : RBNode α → Nat | nil => 0 | node _ a _ b => max a.depth b.depth + 1 theorem size_lt_depth : ∀ t : RBNode α, t.size < 2 ^ t.depth | .nil => (by decide : 0 < 1) | .node _ a _ b => by rw [size, depth, Nat.add_right_comm, Nat.pow_succ, Nat.mul_two] refine Nat.add_le_add (Nat.lt_of_lt_of_le a.size_lt_depth ?_) (Nat.lt_of_lt_of_le b.size_lt_depth ?_) · exact Nat.pow_le_pow_right (by decide) (Nat.le_max_left ..) · exact Nat.pow_le_pow_right (by decide) (Nat.le_max_right ..) /-- `depthLB c n` is the best upper bound on the depth of any balanced red-black tree with root colored `c` and black-height `n`. -/ def depthLB : RBColor → Nat → Nat | red, n => n + 1 | black, n => n theorem depthLB_le : ∀ c n, n ≤ depthLB c n | red, _ => Nat.le_succ _ | black, _ => Nat.le_refl _ /-- `depthUB c n` is the best upper bound on the depth of any balanced red-black tree with root colored `c` and black-height `n`. -/ def depthUB : RBColor → Nat → Nat | red, n => 2 * n + 1 | black, n => 2 * n theorem depthUB_le : ∀ c n, depthUB c n ≤ 2 * n + 1 | red, _ => Nat.le_refl _ | black, _ => Nat.le_succ _ theorem depthUB_le_two_depthLB : ∀ c n, depthUB c n ≤ 2 * depthLB c n | red, _ => Nat.le_succ _ | black, _ => Nat.le_refl _ theorem Balanced.depth_le : @Balanced α t c n → t.depth ≤ depthUB c n | .nil => Nat.le_refl _ | .red hl hr => Nat.succ_le_succ <| Nat.max_le.2 ⟨hl.depth_le, hr.depth_le⟩ | .black hl hr => Nat.succ_le_succ <| Nat.max_le.2 ⟨Nat.le_trans hl.depth_le (depthUB_le ..), Nat.le_trans hr.depth_le (depthUB_le ..)⟩ theorem Balanced.le_size : @Balanced α t c n → 2 ^ depthLB c n ≤ t.size + 1 | .nil => Nat.le_refl _ | .red hl hr => by rw [size, Nat.add_right_comm (size _), Nat.add_assoc, depthLB, Nat.pow_succ, Nat.mul_two] exact Nat.add_le_add hl.le_size hr.le_size | .black hl hr => by rw [size, Nat.add_right_comm (size _), Nat.add_assoc, depthLB, Nat.pow_succ, Nat.mul_two] refine Nat.add_le_add (Nat.le_trans ?_ hl.le_size) (Nat.le_trans ?_ hr.le_size) <;> exact Nat.pow_le_pow_right (by decide) (depthLB_le ..) theorem Balanced.depth_bound (h : @Balanced α t c n) : t.depth ≤ 2 * (t.size + 1).log2 := Nat.le_trans h.depth_le <| Nat.le_trans (depthUB_le_two_depthLB ..) <| Nat.mul_le_mul_left _ <| (Nat.le_log2 (Nat.succ_ne_zero _)).2 h.le_size /-- A well formed tree has `t.depth ∈ O(log t.size)`, that is, it is well balanced. This justifies the `O(log n)` bounds on most searching operations of `RBSet`. -/ theorem WF.depth_bound {t : RBNode α} (h : t.WF cmp) : t.depth ≤ 2 * (t.size + 1).log2 := let ⟨_, _, h⟩ := h.out.2; h.depth_bound ================================================ FILE: Batteries/Data/RBMap/Lemmas.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Tactic.Basic public import Batteries.Data.RBMap.Alter public import Batteries.Data.List.Lemmas @[expose] public section /-! # Additional lemmas for Red-black trees -/ namespace Batteries namespace RBNode open RBColor attribute [simp] fold foldl foldr Any forM foldlM Ordered @[simp] theorem min?_reverse (t : RBNode α) : t.reverse.min? = t.max? := by unfold RBNode.max?; split <;> simp [RBNode.min?] unfold RBNode.min?; rw [min?.match_1.eq_3] · apply min?_reverse · simpa [reverse_eq_iff] @[simp] theorem max?_reverse (t : RBNode α) : t.reverse.max? = t.min? := by rw [← min?_reverse, reverse_reverse] @[simp] theorem mem_nil {x} : ¬x ∈ (.nil : RBNode α) := by simp [Membership.mem, EMem] @[simp] theorem mem_node {y c a x b} : y ∈ (.node c a x b : RBNode α) ↔ y = x ∨ y ∈ a ∨ y ∈ b := by simp [Membership.mem, EMem] theorem All_def {t : RBNode α} : t.All p ↔ ∀ x ∈ t, p x := by induction t <;> simp [or_imp, forall_and, *] theorem Any_def {t : RBNode α} : t.Any p ↔ ∃ x ∈ t, p x := by induction t <;> simp [or_and_right, exists_or, *] theorem memP_def : MemP cut t ↔ ∃ x ∈ t, cut x = .eq := Any_def theorem mem_def : Mem cmp x t ↔ ∃ y ∈ t, cmp x y = .eq := Any_def theorem mem_congr [Std.TransCmp (α := α) cmp] {t : RBNode α} (h : cmp x y = .eq) : Mem cmp x t ↔ Mem cmp y t := by rw [Mem, Mem, iff_iff_eq]; congr 1; funext; rw [Std.TransCmp.congr_left h] theorem isOrdered_iff' [Std.TransCmp (α := α) cmp] {t : RBNode α} : isOrdered cmp t L R ↔ (∀ a ∈ L, t.All (cmpLT cmp a ·)) ∧ (∀ a ∈ R, t.All (cmpLT cmp · a)) ∧ (∀ a ∈ L, ∀ b ∈ R, cmpLT cmp a b) ∧ Ordered cmp t := by induction t generalizing L R with | nil => simp [isOrdered]; split <;> simp [cmpLT_iff] next h => intro _ ha _ hb; cases h _ _ ha hb | node _ l v r => simp [isOrdered, *] exact ⟨ fun ⟨⟨Ll, lv, Lv, ol⟩, ⟨vr, rR, vR, or⟩⟩ => ⟨ fun _ h => ⟨Lv _ h, Ll _ h, (Lv _ h).trans_l vr⟩, fun _ h => ⟨vR _ h, (vR _ h).trans_r lv, rR _ h⟩, fun _ hL _ hR => (Lv _ hL).trans (vR _ hR), lv, vr, ol, or⟩, fun ⟨hL, hR, _, lv, vr, ol, or⟩ => ⟨ ⟨fun _ h => (hL _ h).2.1, lv, fun _ h => (hL _ h).1, ol⟩, ⟨vr, fun _ h => (hR _ h).2.2, fun _ h => (hR _ h).1, or⟩⟩⟩ theorem isOrdered_iff [Std.TransCmp (α := α) cmp] {t : RBNode α} : isOrdered cmp t ↔ Ordered cmp t := by simp [isOrdered_iff'] instance (cmp) [Std.TransCmp (α := α) cmp] (t) : Decidable (Ordered cmp t) := decidable_of_iff _ isOrdered_iff /-- A cut is like a homomorphism of orderings: it is a monotonic predicate with respect to `cmp`, but it can make things that are distinguished by `cmp` equal. This is sufficient for `find?` to locate an element on which `cut` returns `.eq`, but there may be other elements, not returned by `find?`, on which `cut` also returns `.eq`. -/ class IsCut (cmp : α → α → Ordering) (cut : α → Ordering) : Prop where /-- The set `{x | cut x = .lt}` is downward-closed. -/ le_lt_trans [Std.TransCmp cmp] : cmp x y ≠ .gt → cut x = .lt → cut y = .lt /-- The set `{x | cut x = .gt}` is upward-closed. -/ le_gt_trans [Std.TransCmp cmp] : cmp x y ≠ .gt → cut y = .gt → cut x = .gt theorem IsCut.lt_trans [IsCut cmp cut] [Std.TransCmp cmp] (H : cmp x y = .lt) : cut x = .lt → cut y = .lt := IsCut.le_lt_trans <| Std.OrientedCmp.not_gt_of_gt <| Std.OrientedCmp.gt_iff_lt.2 H theorem IsCut.gt_trans [IsCut cmp cut] [Std.TransCmp cmp] (H : cmp x y = .lt) : cut y = .gt → cut x = .gt := IsCut.le_gt_trans <| Std.OrientedCmp.not_gt_of_gt <| Std.OrientedCmp.gt_iff_lt.2 H theorem IsCut.congr [IsCut cmp cut] [Std.TransCmp cmp] (H : cmp x y = .eq) : cut x = cut y := by cases ey : cut y · exact IsCut.le_lt_trans (fun h => nomatch H.symm.trans <| Std.OrientedCmp.gt_iff_lt.1 h) ey · cases ex : cut x · exact IsCut.le_lt_trans (fun h => nomatch H.symm.trans h) ex |>.symm.trans ey · rfl · refine IsCut.le_gt_trans (cmp := cmp) (fun h => ?_) ex |>.symm.trans ey cases H.symm.trans <| Std.OrientedCmp.gt_iff_lt.1 h · exact IsCut.le_gt_trans (fun h => nomatch H.symm.trans h) ey instance (cmp cut) [@IsCut α cmp cut] : IsCut (flip cmp) (cut · |>.swap) where le_lt_trans h₁ h₂ := by have : Std.TransCmp cmp := inferInstanceAs (Std.TransCmp (flip (flip cmp))) rw [IsCut.le_gt_trans (cmp := cmp) h₁ (Ordering.swap_inj.1 h₂)]; rfl le_gt_trans h₁ h₂ := by have : Std.TransCmp cmp := inferInstanceAs (Std.TransCmp (flip (flip cmp))) rw [IsCut.le_lt_trans (cmp := cmp) h₁ (Ordering.swap_inj.1 h₂)]; rfl /-- `IsStrictCut` upgrades the `IsCut` property to ensure that at most one element of the tree can match the cut, and hence `find?` will return the unique such element if one exists. -/ class IsStrictCut (cmp : α → α → Ordering) (cut : α → Ordering) : Prop extends IsCut cmp cut where /-- If `cut = x`, then `cut` and `x` have compare the same with respect to other elements. -/ exact [Std.TransCmp cmp] : cut x = .eq → cmp x y = cut y /-- A "representable cut" is one generated by `cmp a` for some `a`. This is always a valid cut. -/ instance (cmp) (a : α) : IsStrictCut cmp (cmp a) where le_lt_trans h₁ h₂ := Std.TransCmp.lt_of_lt_of_le h₂ h₁ le_gt_trans h₁ := Decidable.not_imp_not.1 (Std.TransCmp.le_trans · h₁) exact h := (Std.TransCmp.congr_left h).symm instance (cmp cut) [@IsStrictCut α cmp cut] : IsStrictCut (flip cmp) (cut · |>.swap) where exact h := by have : Std.TransCmp cmp := inferInstanceAs (Std.TransCmp (flip (flip cmp))) rw [← IsStrictCut.exact (cmp := cmp) (Ordering.swap_inj.1 h), ← Std.OrientedCmp.eq_swap]; rfl section fold theorem foldr_cons (t : RBNode α) (l) : t.foldr (·::·) l = t.toList ++ l := by unfold toList induction t generalizing l with | nil => rfl | node _ a _ b iha ihb => rw [foldr, foldr, iha, iha (_::_), ihb]; simp @[simp] theorem toList_nil : (.nil : RBNode α).toList = [] := rfl @[simp] theorem toList_node : (.node c a x b : RBNode α).toList = a.toList ++ x :: b.toList := by rw [toList, foldr, foldr_cons]; rfl @[simp] theorem toList_reverse (t : RBNode α) : t.reverse.toList = t.toList.reverse := by induction t <;> simp [*] @[simp] theorem mem_toList {t : RBNode α} : x ∈ t.toList ↔ x ∈ t := by induction t <;> simp [*, or_left_comm] @[simp] theorem mem_reverse {t : RBNode α} : a ∈ t.reverse ↔ a ∈ t := by rw [← mem_toList]; simp theorem min?_eq_toList_head? {t : RBNode α} : t.min? = t.toList.head? := by induction t with | nil => rfl | node _ l _ _ ih => cases l <;> simp [RBNode.min?, ih] theorem max?_eq_toList_getLast? {t : RBNode α} : t.max? = t.toList.getLast? := by rw [← min?_reverse, min?_eq_toList_head?]; simp theorem foldr_eq_foldr_toList {t : RBNode α} : t.foldr f init = t.toList.foldr f init := by induction t generalizing init <;> simp [*] theorem foldl_eq_foldl_toList {t : RBNode α} : t.foldl f init = t.toList.foldl f init := by induction t generalizing init <;> simp [*] theorem foldl_reverse {α β : Type _} {t : RBNode α} {f : β → α → β} {init : β} : t.reverse.foldl f init = t.foldr (flip f) init := by simp (config := {unfoldPartialApp := true}) [foldr_eq_foldr_toList, foldl_eq_foldl_toList, flip] theorem foldr_reverse {α β : Type _} {t : RBNode α} {f : α → β → β} {init : β} : t.reverse.foldr f init = t.foldl (flip f) init := foldl_reverse.symm.trans (by simp; rfl) theorem forM_eq_forM_toList [Monad m] [LawfulMonad m] {t : RBNode α} : t.forM (m := m) f = t.toList.forM f := by induction t <;> simp [*] theorem foldlM_eq_foldlM_toList [Monad m] [LawfulMonad m] {t : RBNode α} : t.foldlM (m := m) f init = t.toList.foldlM f init := by induction t generalizing init <;> simp [*] theorem forIn_visit_eq_bindList [Monad m] [LawfulMonad m] {t : RBNode α} : forIn.visit (m := m) f t init = (ForInStep.yield init).bindList f t.toList := by induction t generalizing init <;> simp [*, forIn.visit] theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBNode α} : forIn (m := m) t init f = forIn t.toList init f := by conv => lhs; simp only [forIn, RBNode.forIn] rw [List.forIn_eq_bindList, forIn_visit_eq_bindList] end fold namespace Stream attribute [simp] foldl foldr theorem foldr_cons (t : RBNode.Stream α) (l) : t.foldr (·::·) l = t.toList ++ l := by unfold toList; apply Eq.symm; induction t <;> simp [*, foldr, RBNode.foldr_cons] @[simp] theorem toList_nil : (.nil : RBNode.Stream α).toList = [] := rfl @[simp] theorem toList_cons : (.cons x r s : RBNode.Stream α).toList = x :: r.toList ++ s.toList := by rw [toList, toList, foldr, RBNode.foldr_cons]; rfl theorem foldr_eq_foldr_toList {s : RBNode.Stream α} : s.foldr f init = s.toList.foldr f init := by induction s <;> simp [*, RBNode.foldr_eq_foldr_toList] theorem foldl_eq_foldl_toList {t : RBNode.Stream α} : t.foldl f init = t.toList.foldl f init := by induction t generalizing init <;> simp [*, RBNode.foldl_eq_foldl_toList] theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBNode α} : forIn (m := m) t init f = forIn t.toList init f := by conv => lhs; simp only [forIn, RBNode.forIn] rw [List.forIn_eq_bindList, forIn_visit_eq_bindList] end Stream theorem toStream_toList' {t : RBNode α} {s} : (t.toStream s).toList = t.toList ++ s.toList := by induction t generalizing s <;> simp [*, toStream] @[simp] theorem toStream_toList {t : RBNode α} : t.toStream.toList = t.toList := by simp [toStream_toList'] theorem Stream.next?_toList {s : RBNode.Stream α} : (s.next?.map fun (a, b) => (a, b.toList)) = s.toList.next? := by cases s <;> simp [next?, toStream_toList'] theorem ordered_iff {t : RBNode α} : t.Ordered cmp ↔ t.toList.Pairwise (cmpLT cmp) := by induction t with | nil => simp | node c l v r ihl ihr => simp [*, List.pairwise_append, Ordered, All_def, and_assoc, and_left_comm, and_comm, imp_and, forall_and] exact fun _ _ hl hr a ha b hb => (hl _ ha).trans (hr _ hb) theorem Ordered.toList_sorted {t : RBNode α} : t.Ordered cmp → t.toList.Pairwise (cmpLT cmp) := ordered_iff.1 theorem min?_mem {t : RBNode α} (h : t.min? = some a) : a ∈ t := by rw [min?_eq_toList_head?] at h rw [← mem_toList] revert h; cases toList t <;> rintro ⟨⟩; constructor theorem Ordered.min?_le {t : RBNode α} [Std.TransCmp cmp] (ht : t.Ordered cmp) (h : t.min? = some a) (x) (hx : x ∈ t) : cmp a x ≠ .gt := by rw [min?_eq_toList_head?] at h rw [← mem_toList] at hx have := ht.toList_sorted revert h hx this; cases toList t <;> rintro ⟨⟩ (_ | ⟨_, hx⟩) (_ | ⟨h1,h2⟩) · rw [Std.ReflCmp.compare_self (cmp := cmp)]; decide · rw [(h1 _ hx).1]; decide theorem max?_mem {t : RBNode α} (h : t.max? = some a) : a ∈ t := by simpa using min?_mem ((min?_reverse _).trans h) theorem Ordered.le_max? {t : RBNode α} [Std.TransCmp cmp] (ht : t.Ordered cmp) (h : t.max? = some a) (x) (hx : x ∈ t) : cmp x a ≠ .gt := ht.reverse.min?_le ((min?_reverse _).trans h) _ (by simpa using hx) @[simp] theorem setBlack_toList {t : RBNode α} : t.setBlack.toList = t.toList := by cases t <;> simp [setBlack] @[simp] theorem setRed_toList {t : RBNode α} : t.setRed.toList = t.toList := by cases t <;> simp [setRed] @[simp] theorem balance1_toList {l : RBNode α} {v r} : (l.balance1 v r).toList = l.toList ++ v :: r.toList := by unfold balance1; split <;> simp @[simp] theorem balance2_toList {l : RBNode α} {v r} : (l.balance2 v r).toList = l.toList ++ v :: r.toList := by unfold balance2; split <;> simp @[simp] theorem balLeft_toList {l : RBNode α} {v r} : (l.balLeft v r).toList = l.toList ++ v :: r.toList := by unfold balLeft; split <;> (try simp); split <;> simp @[simp] theorem balRight_toList {l : RBNode α} {v r} : (l.balRight v r).toList = l.toList ++ v :: r.toList := by unfold balRight; split <;> (try simp); split <;> simp theorem size_eq {t : RBNode α} : t.size = t.toList.length := by induction t <;> simp [*, size]; rfl @[simp] theorem reverse_size (t : RBNode α) : t.reverse.size = t.size := by simp [size_eq] @[simp] theorem Any_reverse {t : RBNode α} : t.reverse.Any p ↔ t.Any p := by simp [Any_def] @[simp] theorem memP_reverse {t : RBNode α} : MemP cut t.reverse ↔ MemP (cut · |>.swap) t := by simp [MemP] theorem Mem_reverse [Std.OrientedCmp (α := α) cmp] {t : RBNode α} : Mem cmp x t.reverse ↔ Mem (flip cmp) x t := by simp [Mem]; apply Iff.of_eq; congr; funext x; rw [← Std.OrientedCmp.eq_swap]; rfl section find? theorem find?_some_eq_eq {t : RBNode α} : x ∈ t.find? cut → cut x = .eq := by induction t <;> simp [find?]; split <;> try assumption intro | rfl => assumption theorem find?_some_mem {t : RBNode α} : x ∈ t.find? cut → x ∈ t := by induction t <;> simp [find?]; split <;> simp (config := {contextual := true}) [*] theorem find?_some_memP {t : RBNode α} (h : x ∈ t.find? cut) : MemP cut t := memP_def.2 ⟨_, find?_some_mem h, find?_some_eq_eq h⟩ theorem Ordered.memP_iff_find? [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (ht : Ordered cmp t) : MemP cut t ↔ ∃ x, t.find? cut = some x := by refine ⟨fun H => ?_, fun ⟨x, h⟩ => find?_some_memP h⟩ induction t with simp [find?] at H ⊢ | nil => cases H | node _ l _ r ihl ihr => let ⟨lx, xr, hl, hr⟩ := ht split · next ev => refine ihl hl ?_ rcases H with ev' | hx | hx · cases ev.symm.trans ev' · exact hx · have ⟨z, hz, ez⟩ := Any_def.1 hx cases ez.symm.trans <| IsCut.lt_trans (All_def.1 xr _ hz).1 ev · next ev => refine ihr hr ?_ rcases H with ev' | hx | hx · cases ev.symm.trans ev' · have ⟨z, hz, ez⟩ := Any_def.1 hx cases ez.symm.trans <| IsCut.gt_trans (All_def.1 lx _ hz).1 ev · exact hx · exact ⟨_, rfl⟩ theorem Ordered.unique [Std.TransCmp (α := α) cmp] (ht : Ordered cmp t) (hx : x ∈ t) (hy : y ∈ t) (e : cmp x y = .eq) : x = y := by induction t with | nil => cases hx | node _ l _ r ihl ihr => let ⟨lx, xr, hl, hr⟩ := ht rcases hx, hy with ⟨rfl | hx | hx, rfl | hy | hy⟩ · rfl · cases e.symm.trans <| Std.OrientedCmp.gt_iff_lt.2 (All_def.1 lx _ hy).1 · cases e.symm.trans (All_def.1 xr _ hy).1 · cases e.symm.trans (All_def.1 lx _ hx).1 · exact ihl hl hx hy · cases e.symm.trans ((All_def.1 lx _ hx).trans (All_def.1 xr _ hy)).1 · cases e.symm.trans <| Std.OrientedCmp.gt_iff_lt.2 (All_def.1 xr _ hx).1 · cases e.symm.trans <| Std.OrientedCmp.gt_iff_lt.2 ((All_def.1 lx _ hy).trans (All_def.1 xr _ hx)).1 · exact ihr hr hx hy theorem Ordered.find?_some [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] (ht : Ordered cmp t) : t.find? cut = some x ↔ x ∈ t ∧ cut x = .eq := by refine ⟨fun h => ⟨find?_some_mem h, find?_some_eq_eq h⟩, fun ⟨hx, e⟩ => ?_⟩ have ⟨y, hy⟩ := ht.memP_iff_find?.1 (memP_def.2 ⟨_, hx, e⟩) exact ht.unique hx (find?_some_mem hy) ((IsStrictCut.exact e).trans (find?_some_eq_eq hy)) ▸ hy @[simp] theorem find?_reverse (t : RBNode α) (cut : α → Ordering) : t.reverse.find? cut = t.find? (cut · |>.swap) := by induction t <;> simp [*, find?] cases cut _ <;> simp [Ordering.swap] /-- Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary. -/ def setRoot (v : α) : RBNode α → RBNode α | nil => node red nil v nil | node c a _ b => node c a v b /-- Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary. -/ def delRoot : RBNode α → RBNode α | nil => nil | node _ a _ b => a.append b end find? section «upperBound? and lowerBound?» @[simp] theorem upperBound?_reverse (t : RBNode α) (cut ub) : t.reverse.upperBound? cut ub = t.lowerBound? (cut · |>.swap) ub := by induction t generalizing ub <;> simp [lowerBound?, upperBound?] split <;> simp [*, Ordering.swap] @[simp] theorem lowerBound?_reverse (t : RBNode α) (cut lb) : t.reverse.lowerBound? cut lb = t.upperBound? (cut · |>.swap) lb := by simpa using (upperBound?_reverse t.reverse (cut · |>.swap) lb).symm theorem upperBound?_eq_find? {t : RBNode α} {cut} (ub) (H : t.find? cut = some x) : t.upperBound? cut ub = some x := by induction t generalizing ub with simp [find?] at H | node c a y b iha ihb => simp [upperBound?]; split at H · apply iha _ H · apply ihb _ H · exact H theorem lowerBound?_eq_find? {t : RBNode α} {cut} (lb) (H : t.find? cut = some x) : t.lowerBound? cut lb = some x := by rw [← reverse_reverse t] at H ⊢; rw [lowerBound?_reverse]; rw [find?_reverse] at H exact upperBound?_eq_find? _ H /-- The value `x` returned by `upperBound?` is greater or equal to the `cut`. -/ theorem upperBound?_ge' {t : RBNode α} (H : ∀ {x}, x ∈ ub → cut x ≠ .gt) : t.upperBound? cut ub = some x → cut x ≠ .gt := by induction t generalizing ub with | nil => exact H | node _ _ _ _ ihl ihr => simp [upperBound?]; split · next hv => exact ihl fun | rfl, e => nomatch hv.symm.trans e · exact ihr H · next hv => intro | rfl, e => cases hv.symm.trans e /-- The value `x` returned by `upperBound?` is greater or equal to the `cut`. -/ theorem upperBound?_ge {t : RBNode α} : t.upperBound? cut = some x → cut x ≠ .gt := upperBound?_ge' nofun /-- The value `x` returned by `lowerBound?` is less or equal to the `cut`. -/ theorem lowerBound?_le' {t : RBNode α} (H : ∀ {x}, x ∈ lb → cut x ≠ .lt) : t.lowerBound? cut lb = some x → cut x ≠ .lt := by rw [← reverse_reverse t, lowerBound?_reverse, Ne, ← Ordering.swap_inj] exact upperBound?_ge' fun h => by specialize H h; rwa [Ne, ← Ordering.swap_inj] at H /-- The value `x` returned by `lowerBound?` is less or equal to the `cut`. -/ theorem lowerBound?_le {t : RBNode α} : t.lowerBound? cut = some x → cut x ≠ .lt := lowerBound?_le' nofun theorem All.upperBound?_ub {t : RBNode α} (hp : t.All p) (H : ∀ {x}, ub = some x → p x) : t.upperBound? cut ub = some x → p x := by induction t generalizing ub with | nil => exact H | node _ _ _ _ ihl ihr => simp [upperBound?]; split · exact ihl hp.2.1 fun | rfl => hp.1 · exact ihr hp.2.2 H · exact fun | rfl => hp.1 theorem All.upperBound? {t : RBNode α} (hp : t.All p) : t.upperBound? cut = some x → p x := hp.upperBound?_ub nofun theorem All.lowerBound?_lb {t : RBNode α} (hp : t.All p) (H : ∀ {x}, lb = some x → p x) : t.lowerBound? cut lb = some x → p x := by rw [← reverse_reverse t, lowerBound?_reverse] exact All.upperBound?_ub (All.reverse.2 hp) H theorem All.lowerBound? {t : RBNode α} (hp : t.All p) : t.lowerBound? cut = some x → p x := hp.lowerBound?_lb nofun theorem upperBound?_mem_ub {t : RBNode α} (h : t.upperBound? cut ub = some x) : x ∈ t ∨ ub = some x := All.upperBound?_ub (p := fun x => x ∈ t ∨ ub = some x) (All_def.2 fun _ => .inl) Or.inr h theorem upperBound?_mem {t : RBNode α} (h : t.upperBound? cut = some x) : x ∈ t := (upperBound?_mem_ub h).resolve_right nofun theorem lowerBound?_mem_lb {t : RBNode α} (h : t.lowerBound? cut lb = some x) : x ∈ t ∨ lb = some x := All.lowerBound?_lb (p := fun x => x ∈ t ∨ lb = some x) (All_def.2 fun _ => .inl) Or.inr h theorem lowerBound?_mem {t : RBNode α} (h : t.lowerBound? cut = some x) : x ∈ t := (lowerBound?_mem_lb h).resolve_right nofun theorem upperBound?_of_some {t : RBNode α} : ∃ x, t.upperBound? cut (some y) = some x := by induction t generalizing y <;> simp [upperBound?]; split <;> simp [*] theorem lowerBound?_of_some {t : RBNode α} : ∃ x, t.lowerBound? cut (some y) = some x := by rw [← reverse_reverse t, lowerBound?_reverse]; exact upperBound?_of_some theorem Ordered.upperBound?_exists [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (h : Ordered cmp t) : (∃ x, t.upperBound? cut = some x) ↔ ∃ x ∈ t, cut x ≠ .gt := by refine ⟨fun ⟨x, hx⟩ => ⟨_, upperBound?_mem hx, upperBound?_ge hx⟩, fun H => ?_⟩ obtain ⟨x, hx, e⟩ := H induction t generalizing x with | nil => cases hx | node _ _ _ _ _ ihr => simp [upperBound?]; split · exact upperBound?_of_some · rcases hx with rfl | hx | hx · contradiction · next hv => cases e <| IsCut.gt_trans (All_def.1 h.1 _ hx).1 hv · exact ihr h.2.2.2 _ hx e · exact ⟨_, rfl⟩ theorem Ordered.lowerBound?_exists [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (h : Ordered cmp t) : (∃ x, t.lowerBound? cut = some x) ↔ ∃ x ∈ t, cut x ≠ .lt := by conv => enter [2, 1, x]; rw [Ne, ← Ordering.swap_inj] rw [← reverse_reverse t, lowerBound?_reverse] simpa [-Ordering.swap_inj] using h.reverse.upperBound?_exists (cut := (cut · |>.swap)) theorem Ordered.upperBound?_least_ub [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (h : Ordered cmp t) (hub : ∀ {x}, ub = some x → t.All (cmpLT cmp · x)) : t.upperBound? cut ub = some x → y ∈ t → cut x = .lt → cmp y x = .lt → cut y = .gt := by induction t generalizing ub with | nil => nofun | node _ _ _ _ ihl ihr => simp [upperBound?]; split <;> rename_i hv <;> rintro h₁ (rfl | hy' | hy') hx h₂ · rcases upperBound?_mem_ub h₁ with h₁ | ⟨⟨⟩⟩ · cases Std.OrientedCmp.not_lt_of_lt h₂ (All_def.1 h.1 _ h₁).1 · cases Std.OrientedCmp.not_lt_of_lt h₂ h₂ · exact ihl h.2.2.1 (by rintro _ ⟨⟨⟩⟩; exact h.1) h₁ hy' hx h₂ · refine (Std.OrientedCmp.not_lt_of_lt h₂ ?_).elim; have := (All_def.1 h.2.1 _ hy').1 rcases upperBound?_mem_ub h₁ with h₁ | ⟨⟨⟩⟩ · exact Std.TransCmp.lt_trans (All_def.1 h.1 _ h₁).1 this · exact this · exact hv · exact IsCut.gt_trans (cut := cut) (cmp := cmp) (All_def.1 h.1 _ hy').1 hv · exact ihr h.2.2.2 (fun h => (hub h).2.2) h₁ hy' hx h₂ · cases h₁; cases Std.OrientedCmp.not_lt_of_lt h₂ h₂ · cases h₁; cases hx.symm.trans hv · cases h₁; cases hx.symm.trans hv theorem Ordered.lowerBound?_greatest_lb [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (h : Ordered cmp t) (hlb : ∀ {x}, lb = some x → t.All (cmpLT cmp x ·)) : t.lowerBound? cut lb = some x → y ∈ t → cut x = .gt → cmp x y = .lt → cut y = .lt := by intro h1 h2 h3 h4 rw [← reverse_reverse t, lowerBound?_reverse] at h1 rw [← Ordering.swap_inj] at h3 ⊢ revert h2 h3 h4 simpa [-Ordering.swap_inj] using h.reverse.upperBound?_least_ub (fun h => All.reverse.2 <| (hlb h).imp .flip) h1 /-- A statement of the least-ness of the result of `upperBound?`. If `x` is the return value of `upperBound?` and it is strictly greater than the cut, then any other `y < x` in the tree is in fact strictly less than the cut (so there is no exact match, and nothing closer to the cut). -/ theorem Ordered.upperBound?_least [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (ht : Ordered cmp t) (H : t.upperBound? cut = some x) (hy : y ∈ t) (xy : cmp y x = .lt) (hx : cut x = .lt) : cut y = .gt := ht.upperBound?_least_ub (by nofun) H hy hx xy /-- A statement of the greatest-ness of the result of `lowerBound?`. If `x` is the return value of `lowerBound?` and it is strictly less than the cut, then any other `y > x` in the tree is in fact strictly greater than the cut (so there is no exact match, and nothing closer to the cut). -/ theorem Ordered.lowerBound?_greatest [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (ht : Ordered cmp t) (H : t.lowerBound? cut none = some x) (hy : y ∈ t) (xy : cmp x y = .lt) (hx : cut x = .gt) : cut y = .lt := ht.lowerBound?_greatest_lb (by nofun) H hy hx xy theorem Ordered.memP_iff_upperBound? [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (ht : Ordered cmp t) : t.MemP cut ↔ ∃ x, t.upperBound? cut = some x ∧ cut x = .eq := by refine memP_def.trans ⟨fun ⟨y, hy, ey⟩ => ?_, fun ⟨x, hx, e⟩ => ⟨_, upperBound?_mem hx, e⟩⟩ have ⟨x, hx⟩ := ht.upperBound?_exists.2 ⟨_, hy, fun h => nomatch ey.symm.trans h⟩ refine ⟨x, hx, ?_⟩; cases ex : cut x · cases e : cmp x y · cases ey.symm.trans <| IsCut.lt_trans e ex · cases ey.symm.trans <| IsCut.congr e |>.symm.trans ex · cases ey.symm.trans <| ht.upperBound?_least hx hy (Std.OrientedCmp.gt_iff_lt.1 e) ex · rfl · cases upperBound?_ge hx ex theorem Ordered.memP_iff_lowerBound? [Std.TransCmp (α := α) cmp] [IsCut cmp cut] (ht : Ordered cmp t) : t.MemP cut ↔ ∃ x, t.lowerBound? cut = some x ∧ cut x = .eq := by refine memP_def.trans ⟨fun ⟨y, hy, ey⟩ => ?_, fun ⟨x, hx, e⟩ => ⟨_, lowerBound?_mem hx, e⟩⟩ have ⟨x, hx⟩ := ht.lowerBound?_exists.2 ⟨_, hy, fun h => nomatch ey.symm.trans h⟩ refine ⟨x, hx, ?_⟩; cases ex : cut x · cases lowerBound?_le hx ex · rfl · cases e : cmp x y · cases ey.symm.trans <| ht.lowerBound?_greatest hx hy e ex · cases ey.symm.trans <| IsCut.congr e |>.symm.trans ex · cases ey.symm.trans <| IsCut.gt_trans (Std.OrientedCmp.gt_iff_lt.1 e) ex /-- A stronger version of `lowerBound?_greatest` that holds when the cut is strict. -/ theorem Ordered.lowerBound?_lt [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] (ht : Ordered cmp t) (H : t.lowerBound? cut = some x) (hy : y ∈ t) : cmp x y = .lt ↔ cut y = .lt := by refine ⟨fun h => ?_, fun h => Std.OrientedCmp.gt_iff_lt.1 ?_⟩ · cases e : cut x · cases lowerBound?_le H e · exact IsStrictCut.exact e |>.symm.trans h · exact ht.lowerBound?_greatest H hy h e · by_contra h'; exact lowerBound?_le H <| IsCut.le_lt_trans (cmp := cmp) (cut := cut) h' h /-- A stronger version of `upperBound?_least` that holds when the cut is strict. -/ theorem Ordered.lt_upperBound? [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] (ht : Ordered cmp t) (H : t.upperBound? cut = some x) (hy : y ∈ t) : cmp y x = .lt ↔ cut y = .gt := by rw [← reverse_reverse t, upperBound?_reverse] at H rw [← Ordering.swap_inj (o₂ := .gt)] revert hy; simpa [-Ordering.swap_inj] using ht.reverse.lowerBound?_lt H end «upperBound? and lowerBound?» namespace Path attribute [simp] RootOrdered Ordered /-- The list of elements to the left of the hole. (This function is intended for specification purposes only.) -/ @[simp] def listL : Path α → List α | .root => [] | .left _ parent _ _ => parent.listL | .right _ l v parent => parent.listL ++ (l.toList ++ [v]) /-- The list of elements to the right of the hole. (This function is intended for specification purposes only.) -/ @[simp] def listR : Path α → List α | .root => [] | .left _ parent v r => v :: r.toList ++ parent.listR | .right _ _ _ parent => parent.listR /-- Wraps a list of elements with the left and right elements of the path. -/ abbrev withList (p : Path α) (l : List α) : List α := p.listL ++ l ++ p.listR theorem rootOrdered_iff {p : Path α} (hp : p.Ordered cmp) : p.RootOrdered cmp v ↔ (∀ a ∈ p.listL, cmpLT cmp a v) ∧ (∀ a ∈ p.listR, cmpLT cmp v a) := by induction p with (simp [All_def] at hp; simp [*, and_assoc, and_left_comm, and_comm, or_imp, forall_and]) | left _ _ x _ ih => exact fun vx _ _ _ ha => vx.trans (hp.2.1 _ ha) | right _ _ x _ ih => exact fun xv _ _ _ ha => (hp.2.1 _ ha).trans xv theorem ordered_iff {p : Path α} : p.Ordered cmp ↔ p.listL.Pairwise (cmpLT cmp) ∧ p.listR.Pairwise (cmpLT cmp) ∧ ∀ x ∈ p.listL, ∀ y ∈ p.listR, cmpLT cmp x y := by induction p with | root => simp | left _ _ x _ ih | right _ _ x _ ih => ?_ all_goals rw [Ordered, and_congr_right_eq fun h => by simp [All_def, rootOrdered_iff h]; rfl] simp [List.pairwise_append, or_imp, forall_and, ih, RBNode.ordered_iff] -- FIXME: simp [and_assoc, and_left_comm, and_comm] is really slow here · exact ⟨ fun ⟨⟨hL, hR, LR⟩, xr, ⟨Lx, xR⟩, ⟨rL, rR⟩, hr⟩ => ⟨hL, ⟨⟨xr, xR⟩, hr, hR, rR⟩, Lx, fun _ ha _ hb => rL _ hb _ ha, LR⟩, fun ⟨hL, ⟨⟨xr, xR⟩, hr, hR, rR⟩, Lx, Lr, LR⟩ => ⟨⟨hL, hR, LR⟩, xr, ⟨Lx, xR⟩, ⟨fun _ ha _ hb => Lr _ hb _ ha, rR⟩, hr⟩⟩ · exact ⟨ fun ⟨⟨hL, hR, LR⟩, lx, ⟨Lx, xR⟩, ⟨lL, lR⟩, hl⟩ => ⟨⟨hL, ⟨hl, lx⟩, fun _ ha _ hb => lL _ hb _ ha, Lx⟩, hR, LR, lR, xR⟩, fun ⟨⟨hL, ⟨hl, lx⟩, Ll, Lx⟩, hR, LR, lR, xR⟩ => ⟨⟨hL, hR, LR⟩, lx, ⟨Lx, xR⟩, ⟨fun _ ha _ hb => Ll _ hb _ ha, lR⟩, hl⟩⟩ theorem zoom_zoomed₁ (e : zoom cut t path = (t', path')) : t'.OnRoot (cut · = .eq) := match t, e with | nil, rfl => trivial | node .., e => by revert e; unfold zoom; split · exact zoom_zoomed₁ · exact zoom_zoomed₁ · next H => intro e; cases e; exact H @[simp] theorem fill_toList {p : Path α} : (p.fill t).toList = p.withList t.toList := by induction p generalizing t <;> simp [*] theorem _root_.Batteries.RBNode.zoom_toList {t : RBNode α} (eq : t.zoom cut = (t', p')) : p'.withList t'.toList = t.toList := by rw [← fill_toList, ← zoom_fill eq]; rfl @[simp] theorem ins_toList {p : Path α} : (p.ins t).toList = p.withList t.toList := by match p with | .root | .left red .. | .right red .. | .left black .. | .right black .. => simp [ins, ins_toList] @[simp] theorem insertNew_toList {p : Path α} : (p.insertNew v).toList = p.withList [v] := by simp [insertNew] theorem insert_toList {p : Path α} : (p.insert t v).toList = p.withList (t.setRoot v).toList := by simp [insert]; split <;> simp [setRoot] protected theorem Balanced.insert {path : Path α} (hp : path.Balanced c₀ n₀ c n) : t.Balanced c n → ∃ c n, (path.insert t v).Balanced c n | .nil => ⟨_, hp.insertNew⟩ | .red ha hb => ⟨_, _, hp.fill (.red ha hb)⟩ | .black ha hb => ⟨_, _, hp.fill (.black ha hb)⟩ theorem Ordered.insert : ∀ {path : Path α} {t : RBNode α}, path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → path.RootOrdered cmp v → t.OnRoot (cmpEq cmp v) → (path.insert t v).Ordered cmp | _, nil, hp, _, _, vp, _ => hp.insertNew vp | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩, vp, xv => Ordered.fill.2 ⟨hp, ⟨ax.imp xv.lt_congr_right.2, xb.imp xv.lt_congr_left.2, ha, hb⟩, vp, ap, bp⟩ theorem Ordered.erase : ∀ {path : Path α} {t : RBNode α}, path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → (path.erase t).Ordered cmp | _, nil, hp, ht, tp => Ordered.fill.2 ⟨hp, ht, tp⟩ | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩ => hp.del (ha.append ax xb hb) (ap.append bp) theorem zoom_ins {t : RBNode α} {cmp : α → α → Ordering} : t.zoom (cmp v) path = (t', path') → path.ins (t.ins cmp v) = path'.ins (t'.setRoot v) := by unfold RBNode.ins; split <;> simp [zoom] · intro | rfl, rfl => rfl all_goals · split · exact zoom_ins · exact zoom_ins · intro | rfl => rfl theorem insertNew_eq_insert (h : zoom (cmp v) t = (nil, path)) : path.insertNew v = (t.insert cmp v).setBlack := insert_setBlack .. ▸ (zoom_ins h).symm theorem ins_eq_fill {path : Path α} {t : RBNode α} : path.Balanced c₀ n₀ c n → t.Balanced c n → path.ins t = (path.fill t).setBlack | .root, h => rfl | .redL hb H, ha | .redR ha H, hb => by unfold ins; exact ins_eq_fill H (.red ha hb) | .blackL hb H, ha => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance1_eq ha] | .blackR ha H, hb => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance2_eq hb] theorem zoom_insert {path : Path α} {t : RBNode α} (ht : t.Balanced c n) (H : zoom (cmp v) t = (t', path)) : (path.insert t' v).setBlack = (t.insert cmp v).setBlack := by have ⟨_, _, ht', hp'⟩ := ht.zoom .root H cases ht' with simp [insert] | nil => simp [insertNew_eq_insert H, setBlack_idem] | red hl hr => rw [← ins_eq_fill hp' (.red hl hr), insert_setBlack]; exact (zoom_ins H).symm | black hl hr => rw [← ins_eq_fill hp' (.black hl hr), insert_setBlack]; exact (zoom_ins H).symm theorem zoom_del {t : RBNode α} : t.zoom cut path = (t', path') → path.del (t.del cut) (match t with | node c .. => c | _ => red) = path'.del t'.delRoot (match t' with | node c .. => c | _ => red) := by rw [RBNode.del.eq_def]; split <;> simp [zoom] · intro | rfl, rfl => rfl · next c a y b => split · have IH := @zoom_del (t := a) match a with | nil => intro | rfl => rfl | node black .. | node red .. => apply IH · have IH := @zoom_del (t := b) match b with | nil => intro | rfl => rfl | node black .. | node red .. => apply IH · intro | rfl => rfl /-- Asserts that `p` holds on all elements to the left of the hole. -/ def AllL (p : α → Prop) : Path α → Prop | .root => True | .left _ parent _ _ => parent.AllL p | .right _ a x parent => a.All p ∧ p x ∧ parent.AllL p /-- Asserts that `p` holds on all elements to the right of the hole. -/ def AllR (p : α → Prop) : Path α → Prop | .root => True | .left _ parent x b => parent.AllR p ∧ p x ∧ b.All p | .right _ _ _ parent => parent.AllR p end Path theorem insert_toList_zoom {t : RBNode α} (ht : Balanced t c n) (e : zoom (cmp v) t = (t', p)) : (t.insert cmp v).toList = p.withList (t'.setRoot v).toList := by rw [← setBlack_toList, ← Path.zoom_insert ht e, setBlack_toList, Path.insert_toList] theorem insert_toList_zoom_nil {t : RBNode α} (ht : Balanced t c n) (e : zoom (cmp v) t = (nil, p)) : (t.insert cmp v).toList = p.withList [v] := insert_toList_zoom ht e theorem exists_insert_toList_zoom_nil {t : RBNode α} (ht : Balanced t c n) (e : zoom (cmp v) t = (nil, p)) : ∃ L R, t.toList = L ++ R ∧ (t.insert cmp v).toList = L ++ v :: R := ⟨p.listL, p.listR, by simp [← zoom_toList e, insert_toList_zoom_nil ht e]⟩ theorem insert_toList_zoom_node {t : RBNode α} (ht : Balanced t c n) (e : zoom (cmp v) t = (node c' l v' r, p)) : (t.insert cmp v).toList = p.withList (node c l v r).toList := insert_toList_zoom ht e theorem exists_insert_toList_zoom_node {t : RBNode α} (ht : Balanced t c n) (e : zoom (cmp v) t = (node c' l v' r, p)) : ∃ L R, t.toList = L ++ v' :: R ∧ (t.insert cmp v).toList = L ++ v :: R := by refine ⟨p.listL ++ l.toList, r.toList ++ p.listR, ?_⟩ simp [← zoom_toList e, insert_toList_zoom_node ht e] theorem mem_insert_self {t : RBNode α} (ht : Balanced t c n) : v ∈ t.insert cmp v := by rw [← mem_toList, List.mem_iff_append] exact match e : zoom (cmp v) t with | (nil, p) => let ⟨_, _, _, h⟩ := exists_insert_toList_zoom_nil ht e; ⟨_, _, h⟩ | (node .., p) => let ⟨_, _, _, h⟩ := exists_insert_toList_zoom_node ht e; ⟨_, _, h⟩ theorem mem_insert_of_mem {t : RBNode α} (ht : Balanced t c n) (h : v' ∈ t) : v' ∈ t.insert cmp v ∨ cmp v v' = .eq := by match e : zoom (cmp v) t with | (nil, p) => let ⟨_, _, h₁, h₂⟩ := exists_insert_toList_zoom_nil ht e simp [← mem_toList, h₁] at h simp [← mem_toList, h₂]; cases h <;> simp [*] | (node .., p) => let ⟨_, _, h₁, h₂⟩ := exists_insert_toList_zoom_node ht e simp [← mem_toList, h₁] at h simp [← mem_toList, h₂]; rcases h with h|h|h <;> simp [*] exact .inr (Path.zoom_zoomed₁ e) theorem exists_find?_insert_self [Std.TransCmp (α := α) cmp] [IsCut cmp cut] {t : RBNode α} (ht : Balanced t c n) (ht₂ : Ordered cmp t) (hv : cut v = .eq) : ∃ x, (t.insert cmp v).find? cut = some x := ht₂.insert.memP_iff_find?.1 <| memP_def.2 ⟨_, mem_insert_self ht, hv⟩ theorem find?_insert_self [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] {t : RBNode α} (ht : Balanced t c n) (ht₂ : Ordered cmp t) (hv : cut v = .eq) : (t.insert cmp v).find? cut = some v := ht₂.insert.find?_some.2 ⟨mem_insert_self ht, hv⟩ theorem mem_insert [Std.TransCmp (α := α) cmp] {t : RBNode α} (ht : Balanced t c n) (ht₂ : Ordered cmp t) : v' ∈ t.insert cmp v ↔ (v' ∈ t ∧ t.find? (cmp v) ≠ some v') ∨ v' = v := by refine ⟨fun h => ?_, fun | .inl ⟨h₁, h₂⟩ => ?_ | .inr h => ?_⟩ · match e : zoom (cmp v) t with | (nil, p) => let ⟨_, _, h₁, h₂⟩ := exists_insert_toList_zoom_nil ht e simp [← mem_toList, h₂] at h; rw [← or_assoc, or_right_comm] at h refine h.imp_left fun h => ?_ simp [← mem_toList, h₁, h] rw [find?_eq_zoom, e]; nofun | (node .., p) => let ⟨_, _, h₁, h₂⟩ := exists_insert_toList_zoom_node ht e simp [← mem_toList, h₂] at h; simp [← mem_toList, h₁]; rw [or_left_comm] at h ⊢ rcases h with _|h <;> simp [*] refine .inl fun h => ?_ rw [find?_eq_zoom, e] at h; cases h suffices cmpLT cmp v' v' by cases Std.ReflCmp.compare_self.symm.trans this.1 have := ht₂.toList_sorted; simp [h₁, List.pairwise_append] at this exact h.elim (this.2.2 _ · |>.1) (this.2.1.1 _) · exact (mem_insert_of_mem ht h₁).resolve_right fun h' => h₂ <| ht₂.find?_some.2 ⟨h₁, h'⟩ · exact h ▸ mem_insert_self ht end RBNode open RBNode (IsCut IsStrictCut) namespace RBSet @[simp] theorem val_toList {t : RBSet α cmp} : t.1.toList = t.toList := rfl @[simp] theorem mkRBSet_eq : mkRBSet α cmp = ∅ := rfl @[simp] theorem empty_eq : @RBSet.empty α cmp = ∅ := rfl @[simp] theorem default_eq : (default : RBSet α cmp) = ∅ := rfl @[simp] theorem empty_toList : toList (∅ : RBSet α cmp) = [] := rfl @[simp] theorem single_toList : toList (single a : RBSet α cmp) = [a] := rfl theorem mem_toList {t : RBSet α cmp} : x ∈ toList t ↔ x ∈ t.1 := RBNode.mem_toList theorem mem_congr [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} (h : cmp x y = .eq) : x ∈ t ↔ y ∈ t := RBNode.mem_congr h theorem mem_iff_mem_toList {t : RBSet α cmp} : x ∈ t ↔ ∃ y ∈ toList t, cmp x y = .eq := RBNode.mem_def.trans <| by simp [mem_toList] theorem mem_of_mem_toList [Std.OrientedCmp (α := α) cmp] {t : RBSet α cmp} (h : x ∈ toList t) : x ∈ t := mem_iff_mem_toList.2 ⟨_, h, Std.ReflCmp.compare_self⟩ theorem foldl_eq_foldl_toList {t : RBSet α cmp} : t.foldl f init = t.toList.foldl f init := RBNode.foldl_eq_foldl_toList theorem foldr_eq_foldr_toList {t : RBSet α cmp} : t.foldr f init = t.toList.foldr f init := RBNode.foldr_eq_foldr_toList theorem foldlM_eq_foldlM_toList [Monad m] [LawfulMonad m] {t : RBSet α cmp} : t.foldlM (m := m) f init = t.toList.foldlM f init := RBNode.foldlM_eq_foldlM_toList theorem forM_eq_forM_toList [Monad m] [LawfulMonad m] {t : RBSet α cmp} : t.forM (m := m) f = t.toList.forM f := RBNode.forM_eq_forM_toList theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBSet α cmp} : forIn (m := m) t init f = forIn t.toList init f := RBNode.forIn_eq_forIn_toList theorem toStream_eq {t : RBSet α cmp} : Std.toStream t = t.1.toStream .nil := rfl @[simp] theorem toStream_toList {t : RBSet α cmp} : (Std.toStream t).toList = t.toList := by simp [toStream_eq] theorem isEmpty_iff_toList_eq_nil {t : RBSet α cmp} : t.isEmpty ↔ t.toList = [] := by obtain ⟨⟨⟩, _⟩ := t <;> simp [toList, isEmpty] theorem toList_sorted {t : RBSet α cmp} : t.toList.Pairwise (RBNode.cmpLT cmp) := t.2.out.1.toList_sorted theorem findP?_some_eq_eq {t : RBSet α cmp} : t.findP? cut = some y → cut y = .eq := RBNode.find?_some_eq_eq theorem find?_some_eq_eq {t : RBSet α cmp} : t.find? x = some y → cmp x y = .eq := findP?_some_eq_eq theorem findP?_some_mem_toList {t : RBSet α cmp} (h : t.findP? cut = some y) : y ∈ toList t := mem_toList.2 <| RBNode.find?_some_mem h theorem find?_some_mem_toList {t : RBSet α cmp} (h : t.find? x = some y) : y ∈ toList t := findP?_some_mem_toList h theorem findP?_some_memP {t : RBSet α cmp} (h : t.findP? cut = some y) : t.MemP cut := RBNode.find?_some_memP h theorem find?_some_mem {t : RBSet α cmp} (h : t.find? x = some y) : x ∈ t := findP?_some_memP h theorem mem_toList_unique [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} (hx : x ∈ toList t) (hy : y ∈ toList t) (e : cmp x y = .eq) : x = y := t.2.out.1.unique (mem_toList.1 hx) (mem_toList.1 hy) e theorem findP?_some [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] {t : RBSet α cmp} : t.findP? cut = some y ↔ y ∈ toList t ∧ cut y = .eq := t.2.out.1.find?_some.trans <| by simp [mem_toList] theorem find?_some [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : t.find? x = some y ↔ y ∈ toList t ∧ cmp x y = .eq := findP?_some theorem memP_iff_findP? [Std.TransCmp (α := α) cmp] [IsCut cmp cut] {t : RBSet α cmp} : MemP cut t ↔ ∃ y, t.findP? cut = some y := t.2.out.1.memP_iff_find? theorem mem_iff_find? [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : x ∈ t ↔ ∃ y, t.find? x = some y := memP_iff_findP? @[simp] theorem contains_iff [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : t.contains x ↔ x ∈ t := Option.isSome_iff_exists.trans mem_iff_find?.symm instance [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : Decidable (x ∈ t) := decidable_of_iff _ contains_iff theorem size_eq (t : RBSet α cmp) : t.size = t.toList.length := RBNode.size_eq theorem mem_toList_insert_self (v) (t : RBSet α cmp) : v ∈ toList (t.insert v) := let ⟨_, _, h⟩ := t.2.out.2; mem_toList.2 (RBNode.mem_insert_self h) theorem mem_insert_self [Std.OrientedCmp (α := α) cmp] (v) (t : RBSet α cmp) : v ∈ t.insert v := mem_of_mem_toList <| mem_toList_insert_self v t theorem mem_insert_of_eq [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (h : cmp v v' = .eq) : v' ∈ t.insert v := (mem_congr h).1 (mem_insert_self ..) theorem mem_toList_insert_of_mem (v) {t : RBSet α cmp} (h : v' ∈ toList t) : v' ∈ toList (t.insert v) ∨ cmp v v' = .eq := let ⟨_, _, ht⟩ := t.2.out.2 .imp_left mem_toList.2 <| RBNode.mem_insert_of_mem ht <| mem_toList.1 h theorem mem_insert_of_mem_toList [Std.OrientedCmp (α := α) cmp] (v) {t : RBSet α cmp} (h : v' ∈ toList t) : v' ∈ t.insert v := match mem_toList_insert_of_mem v h with | .inl h' => mem_of_mem_toList h' | .inr h' => mem_iff_mem_toList.2 ⟨_, mem_toList_insert_self .., Std.OrientedCmp.eq_comm.1 h'⟩ theorem mem_insert_of_mem [Std.TransCmp (α := α) cmp] (v) {t : RBSet α cmp} (h : v' ∈ t) : v' ∈ t.insert v := let ⟨_, h₁, h₂⟩ := mem_iff_mem_toList.1 h (mem_congr h₂).2 (mem_insert_of_mem_toList v h₁) theorem mem_toList_insert [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : v' ∈ toList (t.insert v) ↔ (v' ∈ toList t ∧ t.find? v ≠ some v') ∨ v' = v := by let ⟨ht₁, _, _, ht₂⟩ := t.2.out simpa [mem_toList] using RBNode.mem_insert ht₂ ht₁ theorem mem_insert [Std.TransCmp (α := α) cmp] {t : RBSet α cmp} : v' ∈ t.insert v ↔ v' ∈ t ∨ cmp v v' = .eq := by refine ⟨fun h => ?_, fun | .inl h => mem_insert_of_mem _ h | .inr h => mem_insert_of_eq _ h⟩ let ⟨_, h₁, h₂⟩ := mem_iff_mem_toList.1 h match mem_toList_insert.1 h₁ with | .inl ⟨h₃, _⟩ => exact .inl <| mem_iff_mem_toList.2 ⟨_, h₃, h₂⟩ | .inr rfl => exact .inr <| Std.OrientedCmp.eq_comm.1 h₂ theorem find?_congr [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (h : cmp v₁ v₂ = .eq) : t.find? v₁ = t.find? v₂ := by simp only [find?]; congr 1; funext; rw [Std.TransCmp.congr_left h] theorem findP?_insert_of_eq [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] (t : RBSet α cmp) (h : cut v = .eq) : (t.insert v).findP? cut = some v := findP?_some.2 ⟨mem_toList_insert_self .., h⟩ theorem find?_insert_of_eq [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (h : cmp v' v = .eq) : (t.insert v).find? v' = some v := findP?_insert_of_eq t h theorem findP?_insert_of_ne [Std.TransCmp (α := α) cmp] [IsStrictCut cmp cut] (t : RBSet α cmp) (h : cut v ≠ .eq) : (t.insert v).findP? cut = t.findP? cut := by refine Option.ext fun u => findP?_some.trans <| .trans (and_congr_left fun h' => ?_) findP?_some.symm rw [mem_toList_insert, or_iff_left, and_iff_left] · exact mt (fun h => by rwa [IsCut.congr (cut := cut) (find?_some_eq_eq h)]) h · rintro rfl; contradiction theorem find?_insert_of_ne [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (h : cmp v' v ≠ .eq) : (t.insert v).find? v' = t.find? v' := findP?_insert_of_ne t h theorem findP?_insert [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (v cut) [IsStrictCut cmp cut] : (t.insert v).findP? cut = if cut v = .eq then some v else t.findP? cut := by split <;> [exact findP?_insert_of_eq t ‹_›; exact findP?_insert_of_ne t ‹_›] theorem find?_insert [Std.TransCmp (α := α) cmp] (t : RBSet α cmp) (v v') : (t.insert v).find? v' = if cmp v' v = .eq then some v else t.find? v' := findP?_insert .. theorem upperBoundP?_eq_findP? {t : RBSet α cmp} {cut} (H : t.findP? cut = some x) : t.upperBoundP? cut = some x := RBNode.upperBound?_eq_find? _ H theorem lowerBoundP?_eq_findP? {t : RBSet α cmp} {cut} (H : t.findP? cut = some x) : t.lowerBoundP? cut = some x := RBNode.lowerBound?_eq_find? _ H theorem upperBound?_eq_find? {t : RBSet α cmp} (H : t.find? x = some y) : t.upperBound? x = some y := upperBoundP?_eq_findP? H theorem lowerBound?_eq_find? {t : RBSet α cmp} (H : t.find? x = some y) : t.lowerBound? x = some y := lowerBoundP?_eq_findP? H /-- The value `x` returned by `upperBoundP?` is greater or equal to the `cut`. -/ theorem upperBoundP?_ge {t : RBSet α cmp} : t.upperBoundP? cut = some x → cut x ≠ .gt := RBNode.upperBound?_ge /-- The value `y` returned by `upperBound? x` is greater or equal to `x`. -/ theorem upperBound?_ge {t : RBSet α cmp} : t.upperBound? x = some y → cmp x y ≠ .gt := upperBoundP?_ge /-- The value `x` returned by `lowerBoundP?` is less or equal to the `cut`. -/ theorem lowerBoundP?_le {t : RBSet α cmp} : t.lowerBoundP? cut = some x → cut x ≠ .lt := RBNode.lowerBound?_le /-- The value `y` returned by `lowerBound? x` is less or equal to `x`. -/ theorem lowerBound?_le {t : RBSet α cmp} : t.lowerBound? x = some y → cmp x y ≠ .lt := lowerBoundP?_le theorem upperBoundP?_mem_toList {t : RBSet α cmp} (h : t.upperBoundP? cut = some x) : x ∈ t.toList := mem_toList.2 (RBNode.upperBound?_mem h) theorem upperBound?_mem_toList {t : RBSet α cmp} (h : t.upperBound? x = some y) : y ∈ t.toList := upperBoundP?_mem_toList h theorem lowerBoundP?_mem_toList {t : RBSet α cmp} (h : t.lowerBoundP? cut = some x) : x ∈ t.toList := mem_toList.2 (RBNode.lowerBound?_mem h) theorem lowerBound?_mem_toList {t : RBSet α cmp} (h : t.lowerBound? x = some y) : y ∈ t.toList := lowerBoundP?_mem_toList h theorem upperBoundP?_mem [Std.OrientedCmp (α := α) cmp] {t : RBSet α cmp} (h : t.upperBoundP? cut = some x) : x ∈ t := mem_of_mem_toList (upperBoundP?_mem_toList h) theorem lowerBoundP?_mem [Std.OrientedCmp (α := α) cmp] {t : RBSet α cmp} (h : t.lowerBoundP? cut = some x) : x ∈ t := mem_of_mem_toList (lowerBoundP?_mem_toList h) theorem upperBound?_mem [Std.OrientedCmp (α := α) cmp] {t : RBSet α cmp} (h : t.upperBound? x = some y) : y ∈ t := upperBoundP?_mem h theorem lowerBound?_mem [Std.OrientedCmp (α := α) cmp] {t : RBSet α cmp} (h : t.lowerBound? x = some y) : y ∈ t := lowerBoundP?_mem h theorem upperBoundP?_exists {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] : (∃ x, t.upperBoundP? cut = some x) ↔ ∃ x ∈ t, cut x ≠ .gt := by simp [upperBoundP?, t.2.out.1.upperBound?_exists, mem_toList, mem_iff_mem_toList] exact ⟨ fun ⟨x, h1, h2⟩ => ⟨x, ⟨x, h1, Std.ReflCmp.compare_self⟩, h2⟩, fun ⟨x, ⟨y, h1, h2⟩, eq⟩ => ⟨y, h1, IsCut.congr (cut := cut) h2 ▸ eq⟩⟩ theorem lowerBoundP?_exists {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] : (∃ x, t.lowerBoundP? cut = some x) ↔ ∃ x ∈ t, cut x ≠ .lt := by simp [lowerBoundP?, t.2.out.1.lowerBound?_exists, mem_toList, mem_iff_mem_toList] exact ⟨ fun ⟨x, h1, h2⟩ => ⟨x, ⟨x, h1, Std.ReflCmp.compare_self⟩, h2⟩, fun ⟨x, ⟨y, h1, h2⟩, eq⟩ => ⟨y, h1, IsCut.congr (cut := cut) h2 ▸ eq⟩⟩ theorem upperBound?_exists {t : RBSet α cmp} [Std.TransCmp cmp] : (∃ y, t.upperBound? x = some y) ↔ ∃ y ∈ t, cmp x y ≠ .gt := upperBoundP?_exists theorem lowerBound?_exists {t : RBSet α cmp} [Std.TransCmp cmp] : (∃ y, t.lowerBound? x = some y) ↔ ∃ y ∈ t, cmp x y ≠ .lt := lowerBoundP?_exists /-- A statement of the least-ness of the result of `upperBoundP?`. If `x` is the return value of `upperBoundP?` and it is strictly greater than the cut, then any other `y < x` in the tree is in fact strictly less than the cut (so there is no exact match, and nothing closer to the cut). -/ theorem upperBoundP?_least {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] (H : t.upperBoundP? cut = some x) (hy : y ∈ t) (xy : cmp y x = .lt) (hx : cut x = .lt) : cut y = .gt := let ⟨_, h1, h2⟩ := mem_iff_mem_toList.1 hy IsCut.congr (cut := cut) h2 ▸ t.2.out.1.upperBound?_least H (mem_toList.1 h1) (Std.TransCmp.congr_left h2 ▸ xy) hx /-- A statement of the greatest-ness of the result of `lowerBoundP?`. If `x` is the return value of `lowerBoundP?` and it is strictly less than the cut, then any other `y > x` in the tree is in fact strictly greater than the cut (so there is no exact match, and nothing closer to the cut). -/ theorem lowerBoundP?_greatest {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] (H : t.lowerBoundP? cut = some x) (hy : y ∈ t) (xy : cmp x y = .lt) (hx : cut x = .gt) : cut y = .lt := let ⟨_, h1, h2⟩ := mem_iff_mem_toList.1 hy IsCut.congr (cut := cut) h2 ▸ t.2.out.1.lowerBound?_greatest H (mem_toList.1 h1) (Std.TransCmp.congr_right h2 ▸ xy) hx theorem memP_iff_upperBoundP? {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] : t.MemP cut ↔ ∃ x, t.upperBoundP? cut = some x ∧ cut x = .eq := t.2.out.1.memP_iff_upperBound? theorem memP_iff_lowerBoundP? {t : RBSet α cmp} [Std.TransCmp cmp] [IsCut cmp cut] : t.MemP cut ↔ ∃ x, t.lowerBoundP? cut = some x ∧ cut x = .eq := t.2.out.1.memP_iff_lowerBound? theorem mem_iff_upperBound? {t : RBSet α cmp} [Std.TransCmp cmp] : x ∈ t ↔ ∃ y, t.upperBound? x = some y ∧ cmp x y = .eq := memP_iff_upperBoundP? theorem mem_iff_lowerBound? {t : RBSet α cmp} [Std.TransCmp cmp] : x ∈ t ↔ ∃ y, t.lowerBound? x = some y ∧ cmp x y = .eq := memP_iff_lowerBoundP? /-- A stronger version of `upperBoundP?_least` that holds when the cut is strict. -/ theorem lt_upperBoundP? {t : RBSet α cmp} [Std.TransCmp cmp] [IsStrictCut cmp cut] (H : t.upperBoundP? cut = some x) (hy : y ∈ t) : cmp y x = .lt ↔ cut y = .gt := let ⟨_, h1, h2⟩ := mem_iff_mem_toList.1 hy IsCut.congr (cut := cut) h2 ▸ Std.TransCmp.congr_left h2 ▸ t.2.out.1.lt_upperBound? H (mem_toList.1 h1) /-- A stronger version of `lowerBoundP?_greatest` that holds when the cut is strict. -/ theorem lowerBoundP?_lt {t : RBSet α cmp} [Std.TransCmp cmp] [IsStrictCut cmp cut] (H : t.lowerBoundP? cut = some x) (hy : y ∈ t) : cmp x y = .lt ↔ cut y = .lt := let ⟨_, h1, h2⟩ := mem_iff_mem_toList.1 hy IsCut.congr (cut := cut) h2 ▸ Std.TransCmp.congr_right h2 ▸ t.2.out.1.lowerBound?_lt H (mem_toList.1 h1) theorem lt_upperBound? {t : RBSet α cmp} [Std.TransCmp cmp] (H : t.upperBound? x = some y) (hz : z ∈ t) : cmp z y = .lt ↔ cmp z x = .lt := (lt_upperBoundP? H hz).trans Std.OrientedCmp.gt_iff_lt theorem lowerBound?_lt {t : RBSet α cmp} [Std.TransCmp cmp] (H : t.lowerBound? x = some y) (hz : z ∈ t) : cmp y z = .lt ↔ cmp x z = .lt := lowerBoundP?_lt H hz end RBSet namespace RBMap -- @[simp] -- FIXME: RBSet.val_toList already triggers here, seems bad? theorem val_toList {t : RBMap α β cmp} : t.1.toList = t.toList := rfl @[simp] theorem mkRBSet_eq : mkRBMap α β cmp = ∅ := rfl @[simp] theorem empty_eq : @RBMap.empty α β cmp = ∅ := rfl @[simp] theorem default_eq : (default : RBMap α β cmp) = ∅ := rfl @[simp] theorem empty_toList : toList (∅ : RBMap α β cmp) = [] := rfl @[simp] theorem single_toList : toList (single a b : RBMap α β cmp) = [(a, b)] := rfl theorem mem_toList {t : RBMap α β cmp} : x ∈ toList t ↔ x ∈ t.1 := RBNode.mem_toList theorem foldl_eq_foldl_toList {t : RBMap α β cmp} : t.foldl f init = t.toList.foldl (fun r p => f r p.1 p.2) init := RBNode.foldl_eq_foldl_toList theorem foldr_eq_foldr_toList {t : RBMap α β cmp} : t.foldr f init = t.toList.foldr (fun p r => f p.1 p.2 r) init := RBNode.foldr_eq_foldr_toList theorem foldlM_eq_foldlM_toList [Monad m] [LawfulMonad m] {t : RBMap α β cmp} : t.foldlM (m := m) f init = t.toList.foldlM (fun r p => f r p.1 p.2) init := RBNode.foldlM_eq_foldlM_toList theorem forM_eq_forM_toList [Monad m] [LawfulMonad m] {t : RBMap α β cmp} : t.forM (m := m) f = t.toList.forM (fun p => f p.1 p.2) := RBNode.forM_eq_forM_toList theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBMap α β cmp} : forIn (m := m) t init f = forIn t.toList init f := RBNode.forIn_eq_forIn_toList theorem toStream_eq {t : RBMap α β cmp} : Std.toStream t = t.1.toStream .nil := rfl @[simp] theorem toStream_toList {t : RBMap α β cmp} : (Std.toStream t).toList = t.toList := RBSet.toStream_toList theorem toList_sorted {t : RBMap α β cmp} : t.toList.Pairwise (RBNode.cmpLT (cmp ·.1 ·.1)) := RBSet.toList_sorted theorem findEntry?_some_eq_eq {t : RBMap α β cmp} : t.findEntry? x = some (y, v) → cmp x y = .eq := RBSet.findP?_some_eq_eq theorem findEntry?_some_mem_toList {t : RBMap α β cmp} (h : t.findEntry? x = some y) : y ∈ toList t := RBSet.findP?_some_mem_toList h theorem find?_some_mem_toList {t : RBMap α β cmp} (h : t.find? x = some v) : ∃ y, (y, v) ∈ toList t ∧ cmp x y = .eq := by obtain ⟨⟨y, v⟩, h', rfl⟩ := Option.map_eq_some_iff.1 h exact ⟨_, findEntry?_some_mem_toList h', findEntry?_some_eq_eq h'⟩ theorem mem_toList_unique [Std.TransCmp (α := α) cmp] {t : RBMap α β cmp} (hx : x ∈ toList t) (hy : y ∈ toList t) (e : cmp x.1 y.1 = .eq) : x = y := RBSet.mem_toList_unique hx hy e /-- A "representable cut" is one generated by `cmp a` for some `a`. This is always a valid cut. -/ instance (cmp) (a : α) : IsStrictCut cmp (cmp a) where le_lt_trans h₁ h₂ := Std.TransCmp.lt_of_lt_of_le h₂ h₁ le_gt_trans h₁ := Decidable.not_imp_not.1 (Std.TransCmp.le_trans · h₁) exact h := (Std.TransCmp.congr_left h).symm instance (f : α → β) (cmp) [Std.TransCmp (α := β) cmp] (x : β) : IsStrictCut (Ordering.byKey f cmp) (fun y => cmp x (f y)) where le_lt_trans h₁ h₂ := Std.TransCmp.lt_of_lt_of_le h₂ h₁ le_gt_trans h₁ := Decidable.not_imp_not.1 (Std.TransCmp.le_trans · h₁) exact h := (Std.TransCmp.congr_left h).symm theorem findEntry?_some [Std.TransCmp (α := α) cmp] {t : RBMap α β cmp} : t.findEntry? x = some y ↔ y ∈ toList t ∧ cmp x y.1 = .eq := RBSet.findP?_some theorem find?_some [Std.TransCmp (α := α) cmp] {t : RBMap α β cmp} : t.find? x = some v ↔ ∃ y, (y, v) ∈ toList t ∧ cmp x y = .eq := by simp only [find?, findEntry?_some, Option.map_eq_some_iff]; constructor · rintro ⟨_, h, rfl⟩; exact ⟨_, h⟩ · rintro ⟨b, h⟩; exact ⟨_, h, rfl⟩ theorem contains_iff_findEntry? {t : RBMap α β cmp} : t.contains x ↔ ∃ v, t.findEntry? x = some v := Option.isSome_iff_exists theorem contains_iff_find? {t : RBMap α β cmp} : t.contains x ↔ ∃ v, t.find? x = some v := by simp only [contains_iff_findEntry?, Prod.exists, find?, Option.map_eq_some_iff, and_comm, exists_eq_left] rw [exists_comm] theorem size_eq (t : RBMap α β cmp) : t.size = t.toList.length := RBNode.size_eq theorem mem_toList_insert_self (v) (t : RBMap α β cmp) : (k, v) ∈ toList (t.insert k v) := RBSet.mem_toList_insert_self .. theorem mem_toList_insert_of_mem (v) {t : RBMap α β cmp} (h : y ∈ toList t) : y ∈ toList (t.insert k v) ∨ cmp k y.1 = .eq := RBSet.mem_toList_insert_of_mem _ h theorem mem_toList_insert [Std.TransCmp (α := α) cmp] {t : RBMap α β cmp} : y ∈ toList (t.insert k v) ↔ (y ∈ toList t ∧ t.findEntry? k ≠ some y) ∨ y = (k, v) := RBSet.mem_toList_insert theorem findEntry?_congr [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k₁ k₂ = .eq) : t.findEntry? k₁ = t.findEntry? k₂ := by simp only [findEntry?]; congr; funext; rw [Std.TransCmp.congr_left h] theorem find?_congr [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k₁ k₂ = .eq) : t.find? k₁ = t.find? k₂ := by simp [find?, findEntry?_congr _ h] theorem findEntry?_insert_of_eq [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k' k = .eq) : (t.insert k v).findEntry? k' = some (k, v) := RBSet.findP?_insert_of_eq _ h theorem find?_insert_of_eq [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k' k = .eq) : (t.insert k v).find? k' = some v := by rw [find?, findEntry?_insert_of_eq _ h]; rfl theorem findEntry?_insert_of_ne [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k' k ≠ .eq) : (t.insert k v).findEntry? k' = t.findEntry? k' := RBSet.findP?_insert_of_ne _ h theorem find?_insert_of_ne [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (h : cmp k' k ≠ .eq) : (t.insert k v).find? k' = t.find? k' := by simp [find?, findEntry?_insert_of_ne _ h] theorem findEntry?_insert [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (k v k') : (t.insert k v).findEntry? k' = if cmp k' k = .eq then some (k, v) else t.findEntry? k' := RBSet.findP?_insert .. theorem find?_insert [Std.TransCmp (α := α) cmp] (t : RBMap α β cmp) (k v k') : (t.insert k v).find? k' = if cmp k' k = .eq then some v else t.find? k' := by split <;> [exact find?_insert_of_eq t ‹_›; exact find?_insert_of_ne t ‹_›] end RBMap ================================================ FILE: Batteries/Data/RBMap/WF.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.RBMap.Basic public import Batteries.Tactic.SeqFocus @[expose] public section /-! # Lemmas for Red-black trees The main theorem in this file is `WF_def`, which shows that the `RBNode.WF.mk` constructor subsumes the others, by showing that `insert` and `erase` satisfy the red-black invariants. -/ namespace Batteries namespace RBNode open RBColor attribute [simp] All theorem All.trivial (H : ∀ {x : α}, p x) : ∀ {t : RBNode α}, t.All p | nil => _root_.trivial | node .. => ⟨H, All.trivial H, All.trivial H⟩ theorem All_and {t : RBNode α} : t.All (fun a => p a ∧ q a) ↔ t.All p ∧ t.All q := by induction t <;> simp [*, and_assoc, and_left_comm] protected theorem cmpLT.flip (h₁ : cmpLT cmp x y) : cmpLT (flip cmp) y x := ⟨have : Std.TransCmp cmp := inferInstanceAs (Std.TransCmp (flip (flip cmp))); h₁.1⟩ theorem cmpLT.trans (h₁ : cmpLT cmp x y) (h₂ : cmpLT cmp y z) : cmpLT cmp x z := ⟨Std.TransCmp.lt_trans h₁.1 h₂.1⟩ theorem cmpLT.trans_l {cmp x y} (H : cmpLT cmp x y) {t : RBNode α} (h : t.All (cmpLT cmp y ·)) : t.All (cmpLT cmp x ·) := h.imp fun h => H.trans h theorem cmpLT.trans_r {cmp x y} (H : cmpLT cmp x y) {a : RBNode α} (h : a.All (cmpLT cmp · x)) : a.All (cmpLT cmp · y) := h.imp fun h => h.trans H theorem cmpEq.lt_congr_left (H : cmpEq cmp x y) : cmpLT cmp x z ↔ cmpLT cmp y z := ⟨fun ⟨h⟩ => ⟨Std.TransCmp.congr_left H.1 ▸ h⟩, fun ⟨h⟩ => ⟨Std.TransCmp.congr_left H.1 ▸ h⟩⟩ theorem cmpEq.lt_congr_right (H : cmpEq cmp y z) : cmpLT cmp x y ↔ cmpLT cmp x z := ⟨fun ⟨h⟩ => ⟨Std.TransCmp.congr_right H.1 ▸ h⟩, fun ⟨h⟩ => ⟨Std.TransCmp.congr_right H.1 ▸ h⟩⟩ @[simp] theorem reverse_reverse (t : RBNode α) : t.reverse.reverse = t := by induction t <;> simp [*] theorem reverse_eq_iff {t t' : RBNode α} : t.reverse = t' ↔ t = t'.reverse := by constructor <;> rintro rfl <;> simp @[simp] theorem reverse_balance1 (l : RBNode α) (v : α) (r : RBNode α) : (balance1 l v r).reverse = balance2 r.reverse v l.reverse := by unfold balance1 balance2; split <;> simp · rw [balance2.match_1.eq_2]; simp [reverse_eq_iff]; intros; solve_by_elim · rw [balance2.match_1.eq_3] <;> (simp [reverse_eq_iff]; intros; solve_by_elim) @[simp] theorem reverse_balance2 (l : RBNode α) (v : α) (r : RBNode α) : (balance2 l v r).reverse = balance1 r.reverse v l.reverse := by refine Eq.trans ?_ (reverse_reverse _); rw [reverse_balance1]; simp @[simp] theorem All.reverse {t : RBNode α} : t.reverse.All p ↔ t.All p := by induction t <;> simp [*, and_comm] /-- The `reverse` function reverses the ordering invariants. -/ protected theorem Ordered.reverse : ∀ {t : RBNode α}, t.Ordered cmp → t.reverse.Ordered (flip cmp) | .nil, _ => ⟨⟩ | .node .., ⟨lv, vr, hl, hr⟩ => ⟨(All.reverse.2 vr).imp cmpLT.flip, (All.reverse.2 lv).imp cmpLT.flip, hr.reverse, hl.reverse⟩ protected theorem Balanced.reverse {t : RBNode α} : t.Balanced c n → t.reverse.Balanced c n | .nil => .nil | .black hl hr => .black hr.reverse hl.reverse | .red hl hr => .red hr.reverse hl.reverse /-- The `balance1` function preserves the ordering invariants. -/ protected theorem Ordered.balance1 {l : RBNode α} {v : α} {r : RBNode α} (lv : l.All (cmpLT cmp · v)) (vr : r.All (cmpLT cmp v ·)) (hl : l.Ordered cmp) (hr : r.Ordered cmp) : (balance1 l v r).Ordered cmp := by unfold balance1; split · next a x b y c => have ⟨yv, _, cv⟩ := lv; have ⟨xy, yc, hx, hc⟩ := hl exact ⟨xy, ⟨yv, yc, yv.trans_l vr⟩, hx, cv, vr, hc, hr⟩ · next a x b y c _ => have ⟨_, _, yv, _, cv⟩ := lv; have ⟨ax, ⟨xy, xb, _⟩, ha, by_, yc, hb, hc⟩ := hl exact ⟨⟨xy, xy.trans_r ax, by_⟩, ⟨yv, yc, yv.trans_l vr⟩, ⟨ax, xb, ha, hb⟩, cv, vr, hc, hr⟩ · exact ⟨lv, vr, hl, hr⟩ @[simp] theorem balance1_All {l : RBNode α} {v : α} {r : RBNode α} : (balance1 l v r).All p ↔ p v ∧ l.All p ∧ r.All p := by unfold balance1; split <;> simp [and_assoc, and_left_comm] /-- The `balance2` function preserves the ordering invariants. -/ protected theorem Ordered.balance2 {l : RBNode α} {v : α} {r : RBNode α} (lv : l.All (cmpLT cmp · v)) (vr : r.All (cmpLT cmp v ·)) (hl : l.Ordered cmp) (hr : r.Ordered cmp) : (balance2 l v r).Ordered cmp := by rw [← reverse_reverse (balance2 ..), reverse_balance2] exact .reverse <| hr.reverse.balance1 ((All.reverse.2 vr).imp cmpLT.flip) ((All.reverse.2 lv).imp cmpLT.flip) hl.reverse @[simp] theorem balance2_All {l : RBNode α} {v : α} {r : RBNode α} : (balance2 l v r).All p ↔ p v ∧ l.All p ∧ r.All p := by unfold balance2; split <;> simp [and_assoc, and_left_comm] @[simp] theorem reverse_setBlack {t : RBNode α} : (setBlack t).reverse = setBlack t.reverse := by unfold setBlack; split <;> simp protected theorem Ordered.setBlack {t : RBNode α} : (setBlack t).Ordered cmp ↔ t.Ordered cmp := by unfold setBlack; split <;> simp [Ordered] protected theorem Balanced.setBlack : t.Balanced c n → ∃ n', (setBlack t).Balanced black n' | .nil => ⟨_, .nil⟩ | .black hl hr | .red hl hr => ⟨_, hl.black hr⟩ theorem setBlack_idem {t : RBNode α} : t.setBlack.setBlack = t.setBlack := by cases t <;> rfl @[simp] theorem reverse_ins [inst : Std.OrientedCmp (α := α) cmp] {t : RBNode α} : (ins cmp x t).reverse = ins (flip cmp) x t.reverse := by induction t with | nil => simp [ins] | node c a y b iha ihb => cases c <;> (simp only [ins, Std.OrientedCmp.eq_swap (cmp := cmp) (a := x) (b := y)]; split) <;> simp_all [ins, reverse, flip] protected theorem All.ins {x : α} {t : RBNode α} (h₁ : p x) (h₂ : t.All p) : (ins cmp x t).All p := by induction t <;> unfold ins <;> try simp [*] split <;> cases ‹_=_› <;> split <;> simp at h₂ <;> simp [*] /-- The `ins` function preserves the ordering invariants. -/ protected theorem Ordered.ins : ∀ {t : RBNode α}, t.Ordered cmp → (ins cmp x t).Ordered cmp | nil, _ => ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ | node red a y b, ⟨ay, yb, ha, hb⟩ => by unfold ins; split · next h => exact ⟨ay.ins ⟨h⟩, yb, ha.ins, hb⟩ · next h => exact ⟨ay, yb.ins ⟨Std.OrientedCmp.gt_iff_lt.1 h⟩, ha, hb.ins⟩ · next h => exact (⟨ ay.imp fun ⟨h'⟩ => ⟨(Std.TransCmp.congr_right h).trans h'⟩, yb.imp fun ⟨h'⟩ => ⟨(Std.TransCmp.congr_left h).trans h'⟩, ha, hb⟩) | node black a y b, ⟨ay, yb, ha, hb⟩ => by unfold ins; split · next h => exact ha.ins.balance1 (ay.ins ⟨h⟩) yb hb · next h => exact ha.balance2 ay (yb.ins ⟨Std.OrientedCmp.gt_iff_lt.1 h⟩) hb.ins · next h => exact (⟨ ay.imp fun ⟨h'⟩ => ⟨(Std.TransCmp.congr_right h).trans h'⟩, yb.imp fun ⟨h'⟩ => ⟨(Std.TransCmp.congr_left h).trans h'⟩, ha, hb⟩) @[simp] theorem isRed_reverse {t : RBNode α} : t.reverse.isRed = t.isRed := by cases t <;> simp [isRed] @[simp] theorem reverse_insert [inst : Std.OrientedCmp (α := α) cmp] {t : RBNode α} : (insert cmp t x).reverse = insert (flip cmp) t.reverse x := by simp [insert]; split <;> simp theorem insert_setBlack {t : RBNode α} : (t.insert cmp v).setBlack = (t.ins cmp v).setBlack := by unfold insert; split <;> simp [setBlack_idem] /-- The `insert` function preserves the ordering invariants. -/ protected theorem Ordered.insert (h : t.Ordered cmp) : (insert cmp t v).Ordered cmp := by unfold RBNode.insert; split <;> simp [Ordered.setBlack, h.ins (x := v)] /-- The red-red invariant is a weakening of the red-black balance invariant which allows the root to be red with red children, but does not allow any other violations. It occurs as a temporary condition in the `insert` and `erase` functions. The `p` parameter allows the `.redred` case to be dependent on an additional condition. If it is false, then this is equivalent to the usual red-black invariant. -/ inductive RedRed (p : Prop) : RBNode α → Nat → Prop where /-- A balanced tree has the red-red invariant. -/ | balanced : Balanced t c n → RedRed p t n /-- A red node with balanced red children has the red-red invariant (if `p` is true). -/ | redred : p → Balanced a c₁ n → Balanced b c₂ n → RedRed p (node red a x b) n /-- When `p` is false, the red-red case is impossible so the tree is balanced. -/ protected theorem RedRed.of_false (h : ¬p) : RedRed p t n → ∃ c, Balanced t c n | .balanced h => ⟨_, h⟩ | .redred hp .. => nomatch h hp /-- A `red` node with the red-red invariant has balanced children. -/ protected theorem RedRed.of_red : RedRed p (node red a x b) n → ∃ c₁ c₂, Balanced a c₁ n ∧ Balanced b c₂ n | .balanced (.red ha hb) | .redred _ ha hb => ⟨_, _, ha, hb⟩ /-- The red-red invariant is monotonic in `p`. -/ protected theorem RedRed.imp (h : p → q) : RedRed p t n → RedRed q t n | .balanced h => .balanced h | .redred hp ha hb => .redred (h hp) ha hb protected theorem RedRed.reverse : RedRed p t n → RedRed p t.reverse n | .balanced h => .balanced h.reverse | .redred hp ha hb => .redred hp hb.reverse ha.reverse /-- If `t` has the red-red invariant, then setting the root to black yields a balanced tree. -/ protected theorem RedRed.setBlack : t.RedRed p n → ∃ n', (setBlack t).Balanced black n' | .balanced h => h.setBlack | .redred _ hl hr => ⟨_, hl.black hr⟩ /-- The `balance1` function repairs the balance invariant when the first argument is red-red. -/ protected theorem RedRed.balance1 {l : RBNode α} {v : α} {r : RBNode α} (hl : l.RedRed p n) (hr : r.Balanced c n) : ∃ c, (balance1 l v r).Balanced c (n + 1) := by unfold balance1; split · have .redred _ (.red ha hb) hc := hl; exact ⟨_, .red (.black ha hb) (.black hc hr)⟩ · have .redred _ ha (.red hb hc) := hl; exact ⟨_, .red (.black ha hb) (.black hc hr)⟩ · next H1 H2 => match hl with | .balanced hl => exact ⟨_, .black hl hr⟩ | .redred _ (c₁ := black) (c₂ := black) ha hb => exact ⟨_, .black (.red ha hb) hr⟩ | .redred _ (c₁ := red) (.red ..) _ => cases H1 _ _ _ _ _ rfl | .redred _ (c₂ := red) _ (.red ..) => cases H2 _ _ _ _ _ rfl /-- The `balance2` function repairs the balance invariant when the second argument is red-red. -/ protected theorem RedRed.balance2 {l : RBNode α} {v : α} {r : RBNode α} (hl : l.Balanced c n) (hr : r.RedRed p n) : ∃ c, (balance2 l v r).Balanced c (n + 1) := (hr.reverse.balance1 hl.reverse (v := v)).imp fun _ h => by simpa using h.reverse /-- The `balance1` function does nothing if the first argument is already balanced. -/ theorem balance1_eq {l : RBNode α} {v : α} {r : RBNode α} (hl : l.Balanced c n) : balance1 l v r = node black l v r := by unfold balance1; split <;> first | rfl | nomatch hl /-- The `balance2` function does nothing if the second argument is already balanced. -/ theorem balance2_eq {l : RBNode α} {v : α} {r : RBNode α} (hr : r.Balanced c n) : balance2 l v r = node black l v r := (reverse_reverse _).symm.trans <| by simp [balance1_eq hr.reverse] /-! ## insert -/ /-- The balance invariant of the `ins` function. The result of inserting into the tree either yields a balanced tree, or a tree which is almost balanced except that it has a red-red violation at the root. -/ protected theorem Balanced.ins (cmp v) {t : RBNode α} (h : t.Balanced c n) : (ins cmp v t).RedRed (t.isRed = red) n := by induction h with | nil => exact .balanced (.red .nil .nil) | @red a n b x hl hr ihl ihr => unfold ins; split · match ins cmp v a, ihl with | _, .balanced .nil => exact .balanced (.red .nil hr) | _, .balanced (.red ha hb) => exact .redred rfl (.red ha hb) hr | _, .balanced (.black ha hb) => exact .balanced (.red (.black ha hb) hr) | _, .redred h .. => cases hl <;> cases h · match ins cmp v b, ihr with | _, .balanced .nil => exact .balanced (.red hl .nil) | _, .balanced (.red ha hb) => exact .redred rfl hl (.red ha hb) | _, .balanced (.black ha hb) => exact .balanced (.red hl (.black ha hb)) | _, .redred h .. => cases hr <;> cases h · exact .balanced (.red hl hr) | @black a ca n b cb x hl hr ihl ihr => unfold ins; split · exact have ⟨c, h⟩ := ihl.balance1 hr; .balanced h · exact have ⟨c, h⟩ := ihr.balance2 hl; .balanced h · exact .balanced (.black hl hr) /-- The `insert` function is balanced if the input is balanced. (We lose track of both the color and the black-height of the result, so this is only suitable for use on the root of the tree.) -/ theorem Balanced.insert {t : RBNode α} (h : t.Balanced c n) : ∃ c' n', (insert cmp t v).Balanced c' n' := by unfold RBNode.insert match ins cmp v t, h.ins cmp v with | _, .balanced h => split <;> [exact ⟨_, h.setBlack⟩; exact ⟨_, _, h⟩] | _, .redred _ ha hb => have .node red .. := t; exact ⟨_, _, .black ha hb⟩ @[simp] theorem reverse_setRed {t : RBNode α} : (setRed t).reverse = setRed t.reverse := by unfold setRed; split <;> simp protected theorem All.setRed {t : RBNode α} (h : t.All p) : (setRed t).All p := by unfold setRed; split <;> simp_all /-- The `setRed` function preserves the ordering invariants. -/ protected theorem Ordered.setRed {t : RBNode α} : (setRed t).Ordered cmp ↔ t.Ordered cmp := by unfold setRed; split <;> simp [Ordered] @[simp] theorem reverse_balLeft (l : RBNode α) (v : α) (r : RBNode α) : (balLeft l v r).reverse = balRight r.reverse v l.reverse := by suffices ∀ r' l', r' = r.reverse → l' = l.reverse → (balLeft l v r).reverse = balRight r' v l' from this _ _ rfl rfl intros r' l' hr hl fun_cases balLeft l v r <;> fun_cases balRight r' v l' <;> grind [reverse, reverse_reverse, reverse_balance2, reverse_setRed] @[simp] theorem reverse_balRight (l : RBNode α) (v : α) (r : RBNode α) : (balRight l v r).reverse = balLeft r.reverse v l.reverse := by rw [← reverse_reverse (balLeft ..)]; simp protected theorem All.balLeft (hl : l.All p) (hv : p v) (hr : r.All p) : (balLeft l v r).All p := by unfold balLeft; split <;> (try simp_all); split <;> simp_all [All.setRed] /-- The `balLeft` function preserves the ordering invariants. -/ protected theorem Ordered.balLeft {l : RBNode α} {v : α} {r : RBNode α} (lv : l.All (cmpLT cmp · v)) (vr : r.All (cmpLT cmp v ·)) (hl : l.Ordered cmp) (hr : r.Ordered cmp) : (balLeft l v r).Ordered cmp := by unfold balLeft; split · exact ⟨lv, vr, hl, hr⟩ split · exact hl.balance2 lv vr hr · have ⟨vy, va, _⟩ := vr.2.1; have ⟨⟨yz, _, bz⟩, zc, ⟨ay, yb, ha, hb⟩, hc⟩ := hr exact ⟨⟨vy, vy.trans_r lv, ay⟩, balance2_All.2 ⟨yz, yb, (yz.trans_l zc).setRed⟩, ⟨lv, va, hl, ha⟩, hb.balance2 bz zc.setRed (Ordered.setRed.2 hc)⟩ · exact ⟨lv, vr, hl, hr⟩ /-- The balancing properties of the `balLeft` function. -/ protected theorem Balanced.balLeft (hl : l.RedRed True n) (hr : r.Balanced cr (n + 1)) : (balLeft l v r).RedRed (cr = red) (n + 1) := by unfold balLeft; split · next a x b => exact let ⟨ca, cb, ha, hb⟩ := hl.of_red match cr with | red => .redred rfl (.black ha hb) hr | black => .balanced (.red (.black ha hb) hr) · next H => exact match hl with | .redred .. => nomatch H _ _ _ rfl | .balanced hl => match hr with | .black ha hb => let ⟨c, h⟩ := RedRed.balance2 hl (.redred trivial ha hb); .balanced h | .red (.black ha hb) (.black hc hd) => let ⟨c, h⟩ := RedRed.balance2 hb (.redred trivial hc hd); .redred rfl (.black hl ha) h protected theorem All.balRight (hl : l.All p) (hv : p v) (hr : r.All p) : (balRight l v r).All p := All.reverse.1 <| reverse_balRight .. ▸ (All.reverse.2 hr).balLeft hv (All.reverse.2 hl) /-- The `balRight` function preserves the ordering invariants. -/ protected theorem Ordered.balRight {l : RBNode α} {v : α} {r : RBNode α} (lv : l.All (cmpLT cmp · v)) (vr : r.All (cmpLT cmp v ·)) (hl : l.Ordered cmp) (hr : r.Ordered cmp) : (balRight l v r).Ordered cmp := by rw [← reverse_reverse (balRight ..), reverse_balRight] exact .reverse <| hr.reverse.balLeft ((All.reverse.2 vr).imp cmpLT.flip) ((All.reverse.2 lv).imp cmpLT.flip) hl.reverse /-- The balancing properties of the `balRight` function. -/ protected theorem Balanced.balRight (hl : l.Balanced cl (n + 1)) (hr : r.RedRed True n) : (balRight l v r).RedRed (cl = red) (n + 1) := by rw [← reverse_reverse (balRight ..), reverse_balRight] exact .reverse <| hl.reverse.balLeft hr.reverse -- note: reverse_append is false! protected theorem All.append (hl : l.All p) (hr : r.All p) : (append l r).All p := by unfold append; split <;> try simp [*] · have ⟨hx, ha, hb⟩ := hl; have ⟨hy, hc, hd⟩ := hr have := hb.append hc; split <;> simp_all · have ⟨hx, ha, hb⟩ := hl; have ⟨hy, hc, hd⟩ := hr have := hb.append hc; split <;> simp_all [All.balLeft] · simp_all [hl.append hr.2.1] · simp_all [hl.2.2.append hr] termination_by l.size + r.size /-- The `append` function preserves the ordering invariants. -/ protected theorem Ordered.append {l : RBNode α} {v : α} {r : RBNode α} (lv : l.All (cmpLT cmp · v)) (vr : r.All (cmpLT cmp v ·)) (hl : l.Ordered cmp) (hr : r.Ordered cmp) : (append l r).Ordered cmp := by unfold append; split · exact hr · exact hl · have ⟨xv, _, bv⟩ := lv; have ⟨ax, xb, ha, hb⟩ := hl have ⟨vy, vc, _⟩ := vr; have ⟨cy, yd, hc, hd⟩ := hr have : _ ∧ _ ∧ _ := ⟨hb.append bv vc hc, xb.append (xv.trans_l vc), (vy.trans_r bv).append cy⟩ split · next H => have ⟨⟨b'z, c'z, hb', hc'⟩, ⟨xz, xb', _⟩, zy, _, c'y⟩ := H ▸ this have az := xz.trans_r ax; have zd := zy.trans_l yd exact ⟨⟨xz, az, b'z⟩, ⟨zy, c'z, zd⟩, ⟨ax, xb', ha, hb'⟩, c'y, yd, hc', hd⟩ · have ⟨hbc, xbc, bcy⟩ := this; have xy := xv.trans vy exact ⟨ax, ⟨xy, xbc, xy.trans_l yd⟩, ha, bcy, yd, hbc, hd⟩ · have ⟨xv, _, bv⟩ := lv; have ⟨ax, xb, ha, hb⟩ := hl have ⟨vy, vc, _⟩ := vr; have ⟨cy, yd, hc, hd⟩ := hr have : _ ∧ _ ∧ _ := ⟨hb.append bv vc hc, xb.append (xv.trans_l vc), (vy.trans_r bv).append cy⟩ split · next H => have ⟨⟨b'z, c'z, hb', hc'⟩, ⟨xz, xb', _⟩, zy, _, c'y⟩ := H ▸ this have az := xz.trans_r ax; have zd := zy.trans_l yd exact ⟨⟨xz, az, b'z⟩, ⟨zy, c'z, zd⟩, ⟨ax, xb', ha, hb'⟩, c'y, yd, hc', hd⟩ · have ⟨hbc, xbc, bcy⟩ := this; have xy := xv.trans vy exact ha.balLeft ax ⟨xy, xbc, xy.trans_l yd⟩ ⟨bcy, yd, hbc, hd⟩ · have ⟨vx, vb, _⟩ := vr; have ⟨bx, yc, hb, hc⟩ := hr exact ⟨(vx.trans_r lv).append bx, yc, hl.append lv vb hb, hc⟩ · have ⟨xv, _, bv⟩ := lv; have ⟨ax, xb, ha, hb⟩ := hl exact ⟨ax, xb.append (xv.trans_l vr), ha, hb.append bv vr hr⟩ termination_by l.size + r.size /-- The balance properties of the `append` function. -/ protected theorem Balanced.append {l r : RBNode α} (hl : l.Balanced c₁ n) (hr : r.Balanced c₂ n) : (l.append r).RedRed (c₁ = black → c₂ ≠ black) n := by unfold append; split · exact .balanced hr · exact .balanced hl · next b c _ _ => have .red ha hb := hl; have .red hc hd := hr have ⟨_, IH⟩ := (hb.append hc).of_false (· rfl rfl); split · next e => have .red hb' hc' := e ▸ IH exact .redred nofun (.red ha hb') (.red hc' hd) · next bcc _ H => match bcc, append b c, IH, H with | black, _, IH, _ => exact .redred nofun ha (.red IH hd) | red, _, .red .., H => cases H _ _ _ rfl · next b c _ _ => have .black ha hb := hl; have .black hc hd := hr have IH := hb.append hc; split · next e => match e ▸ IH with | .balanced (.red hb' hc') | .redred _ hb' hc' => exact .balanced (.red (.black ha hb') (.black hc' hd)) · next H => match append b c, IH, H with | bc, .balanced hbc, _ => unfold balLeft; split · have .red ha' hb' := ha exact .balanced (.red (.black ha' hb') (.black hbc hd)) · exact have ⟨c, h⟩ := RedRed.balance2 ha (.redred trivial hbc hd); .balanced h | _, .redred .., H => cases H _ _ _ rfl · have .red hc hd := hr; have IH := hl.append hc have .black ha hb := hl; have ⟨c, IH⟩ := IH.of_false (· rfl rfl) exact .redred nofun IH hd · have .red ha hb := hl; have IH := hb.append hr have .black hc hd := hr; have ⟨c, IH⟩ := IH.of_false (· rfl rfl) exact .redred nofun ha IH termination_by l.size + r.size /-! ## erase -/ /-- The invariant of the `del` function. * If the input tree is black, then the result of deletion is a red-red tree with black-height lowered by 1. * If the input tree is red or nil, then the result of deletion is a balanced tree with some color and the same black-height. -/ def DelProp (p : RBColor) (t : RBNode α) (n : Nat) : Prop := match p with | black => ∃ n', n = n' + 1 ∧ RedRed True t n' | red => ∃ c, Balanced t c n /-- The `DelProp` property is a strengthened version of the red-red invariant. -/ theorem DelProp.redred (h : DelProp c t n) : ∃ n', RedRed (c = black) t n' := by unfold DelProp at h exact match c, h with | red, ⟨_, h⟩ => ⟨_, .balanced h⟩ | black, ⟨_, _, h⟩ => ⟨_, h.imp fun _ => rfl⟩ protected theorem All.del : ∀ {t : RBNode α}, t.All p → (del cut t).All p | .nil, h => h | .node .., ⟨hy, ha, hb⟩ => by unfold del; split · split · exact ha.del.balLeft hy hb · exact ⟨hy, ha.del, hb⟩ · split · exact ha.balRight hy hb.del · exact ⟨hy, ha, hb.del⟩ · exact ha.append hb /-- The `del` function preserves the ordering invariants. -/ protected theorem Ordered.del : ∀ {t : RBNode α}, t.Ordered cmp → (del cut t).Ordered cmp | .nil, _ => ⟨⟩ | .node _ a y b, ⟨ay, yb, ha, hb⟩ => by unfold del; split · split · exact ha.del.balLeft ay.del yb hb · exact ⟨ay.del, yb, ha.del, hb⟩ · split · exact ha.balRight ay yb.del hb.del · exact ⟨ay, yb.del, ha, hb.del⟩ · exact ha.append ay yb hb /-- The `del` function has the `DelProp` property. -/ protected theorem Balanced.del {t : RBNode α} (h : t.Balanced c n) : (t.del cut).DelProp t.isBlack n := by induction h with | nil => exact ⟨_, .nil⟩ | @black a _ n b _ _ ha hb iha ihb => refine ⟨_, rfl, ?_⟩ unfold del; split · exact match a, n, iha with | .nil, _, ⟨c, ha⟩ | .node red .., _, ⟨c, ha⟩ => .redred ⟨⟩ ha hb | .node black .., _, ⟨n, rfl, ha⟩ => (hb.balLeft ha).imp fun _ => ⟨⟩ · exact match b, n, ihb with | .nil, _, ⟨c, hb⟩ | .node .red .., _, ⟨c, hb⟩ => .redred ⟨⟩ ha hb | .node black .., _, ⟨n, rfl, hb⟩ => (ha.balRight hb).imp fun _ => ⟨⟩ · exact (ha.append hb).imp fun _ => ⟨⟩ | @red a n b _ ha hb iha ihb => unfold del; split · exact match a, n, iha with | .nil, _, _ => ⟨_, .red ha hb⟩ | .node black .., _, ⟨n, rfl, ha⟩ => (hb.balLeft ha).of_false nofun · exact match b, n, ihb with | .nil, _, _ => ⟨_, .red ha hb⟩ | .node black .., _, ⟨n, rfl, hb⟩ => (ha.balRight hb).of_false nofun · exact (ha.append hb).of_false (· rfl rfl) /-- The `erase` function preserves the ordering invariants. -/ protected theorem Ordered.erase {t : RBNode α} (h : t.Ordered cmp) : (erase cut t).Ordered cmp := Ordered.setBlack.2 h.del /-- The `erase` function preserves the balance invariants. -/ protected theorem Balanced.erase {t : RBNode α} (h : t.Balanced c n) : ∃ n, (t.erase cut).Balanced black n := have ⟨_, h⟩ := h.del.redred; h.setBlack /-- The well-formedness invariant implies the ordering and balance properties. -/ theorem WF.out {t : RBNode α} (h : t.WF cmp) : t.Ordered cmp ∧ ∃ c n, t.Balanced c n := by induction h with | mk o h => exact ⟨o, _, _, h⟩ | insert _ ih => have ⟨o, _, _, h⟩ := ih; exact ⟨o.insert, h.insert⟩ | erase _ ih => have ⟨o, _, _, h⟩ := ih; exact ⟨o.erase, _, h.erase⟩ /-- The well-formedness invariant for a red-black tree is exactly the `mk` constructor, because the other constructors of `WF` are redundant. -/ @[simp] theorem WF_iff {t : RBNode α} : t.WF cmp ↔ t.Ordered cmp ∧ ∃ c n, t.Balanced c n := ⟨fun h => h.out, fun ⟨o, _, _, h⟩ => .mk o h⟩ /-- The `map` function preserves the balance invariants. -/ protected theorem Balanced.map {t : RBNode α} : t.Balanced c n → (t.map f).Balanced c n | .nil => .nil | .red hl hr => .red hl.map hr.map | .black hl hr => .black hl.map hr.map /-- The property of a map function `f` which ensures the `map` operation is valid. -/ class IsMonotone (cmpα cmpβ) (f : α → β) : Prop where /-- If `x < y` then `f x < f y`. -/ lt_mono : cmpLT cmpα x y → cmpLT cmpβ (f x) (f y) /-- Sufficient condition for `map` to preserve an `All` quantifier. -/ protected theorem All.map {f : α → β} (H : ∀ {x}, p x → q (f x)) : ∀ {t : RBNode α}, t.All p → (t.map f).All q | nil, _ => ⟨⟩ | node .., ⟨hx, ha, hb⟩ => ⟨H hx, ha.map H, hb.map H⟩ /-- The `map` function preserves the order invariants if `f` is monotone. -/ protected theorem Ordered.map (f : α → β) [IsMonotone cmpα cmpβ f] : ∀ {t : RBNode α}, t.Ordered cmpα → (t.map f).Ordered cmpβ | nil, _ => ⟨⟩ | node _ a x b, ⟨ax, xb, ha, hb⟩ => by refine ⟨ax.map ?_, xb.map ?_, ha.map f, hb.map f⟩ <;> exact IsMonotone.lt_mono end RBNode namespace RBSet export RBNode (IsMonotone) /-- `O(n)`. Map a function on every value in the set. This requires `IsMonotone` on the function in order to preserve the order invariant. If the function is not monotone, use `RBSet.map` instead. -/ @[inline] def mapMonotone (f : α → β) [IsMonotone cmpα cmpβ f] (t : RBSet α cmpα) : RBSet β cmpβ := ⟨t.1.map f, have ⟨h₁, _, _, h₂⟩ := t.2.out; .mk (h₁.map _) h₂.map⟩ end RBSet namespace RBMap export RBNode (IsMonotone) namespace Imp /-- Applies `f` to the second component. We extract this as a function so that `IsMonotone (mapSnd f)` can be an instance. -/ @[inline] def mapSnd (f : α → β → γ) := fun (a, b) => (a, f a b) open Ordering (byKey) instance (cmp : α → α → Ordering) (f : α → β → γ) : IsMonotone (byKey Prod.fst cmp) (byKey Prod.fst cmp) (mapSnd f) where lt_mono | ⟨h⟩ => ⟨@fun _ => @h { eq_swap := @fun (a₁, b₁) (a₂, b₂) => Std.OrientedCmp.eq_swap (cmp := byKey Prod.fst cmp) (a := (a₁, f a₁ b₁)) (b := (a₂, f a₂ b₂)) isLE_trans := @fun (a₁, b₁) (a₂, b₂) (a₃, b₃) => Std.TransCmp.isLE_trans (cmp := byKey Prod.fst cmp) (a := (a₁, f a₁ b₁)) (b := (a₂, f a₂ b₂)) (c := (a₃, f a₃ b₃)) }⟩ end Imp /-- `O(n)`. Map a function on the values in the map. -/ def mapVal (f : α → β → γ) (t : RBMap α β cmp) : RBMap α γ cmp := t.mapMonotone (Imp.mapSnd f) end RBMap ================================================ FILE: Batteries/Data/RBMap.lean ================================================ module public import Batteries.Data.RBMap.Alter public import Batteries.Data.RBMap.Basic public import Batteries.Data.RBMap.Depth public import Batteries.Data.RBMap.Lemmas public import Batteries.Data.RBMap.WF ================================================ FILE: Batteries/Data/Random/MersenneTwister.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public section /-! # Mersenne Twister Generic implementation for the Mersenne Twister pseudorandom number generator. All choices of parameters from Matsumoto and Nishimura (1998) are supported, along with later refinements. Parameters for the standard 32-bit MT19937 and 64-bit MT19937-64 algorithms are provided. Both `RandomGen` and `Stream` interfaces are provided. Use `mt19937.init seed` to create a MT19937 PRNG with a 32 bit seed value; use `mt19937_64.init seed` to create a MT19937-64 PRNG with a 64 bit seed value. If omitted, default seed choices will be used. Sample usage: ``` import Batteries.Data.Random.MersenneTwister open Batteries.Random.MersenneTwister def mtgen := mt19937.init -- default seed 4357 #eval (Stream.take mtgen 5).fst -- [874448474, 2424656266, 2174085406, 1265871120, 3155244894] ``` ### References: - Matsumoto, Makoto and Nishimura, Takuji (1998), [**Mersenne twister: A 623-dimensionally equidistributed uniform pseudo-random number generator**](https://doi.org/10.1145/272991.272995), ACM Trans. Model. Comput. Simul. 8, No. 1, 3-30. [ZBL0917.65005](https://zbmath.org/?q=an:0917.65005). - Nishimura, Takuji (2000), [**Tables of 64-bit Mersenne twisters**](https://doi.org/10.1145/369534.369540), ACM Trans. Model. Comput. Simul. 10, No. 4, 348-357. [ZBL1390.65014](https://zbmath.org/?q=an:1390.65014). -/ namespace Batteries.Random.MersenneTwister /-- Mersenne Twister configuration. Letters in parentheses correspond to variable names used by Matsumoto and Nishimura (1998) and Nishimura (2000). -/ structure Config where /-- Word size (`w`). -/ wordSize : Nat /-- Degree of recurrence (`n`). -/ stateSize : Nat /-- Middle word (`m`). -/ shiftSize : Fin stateSize /-- Twist value (`r`). -/ maskBits : Fin wordSize /-- Coefficients of the twist matrix (`a`). -/ xorMask : BitVec wordSize /-- Tempering shift parameters (`u`, `s`, `t`, `l`). -/ temperingShifts : Nat × Nat × Nat × Nat /-- Tempering mask parameters (`d`, `b`, `c`). -/ temperingMasks : BitVec wordSize × BitVec wordSize × BitVec wordSize /-- Initialization multiplier (`f`). -/ initMult : BitVec wordSize /-- Default initialization seed value. -/ initSeed : BitVec wordSize private abbrev Config.uMask (cfg : Config) : BitVec cfg.wordSize := BitVec.allOnes cfg.wordSize <<< cfg.maskBits.val private abbrev Config.lMask (cfg : Config) : BitVec cfg.wordSize := BitVec.allOnes cfg.wordSize >>> (cfg.wordSize - cfg.maskBits.val) @[simp] theorem Config.zero_lt_wordSize (cfg : Config) : 0 < cfg.wordSize := Nat.zero_lt_of_lt cfg.maskBits.is_lt @[simp] theorem Config.zero_lt_stateSize (cfg : Config) : 0 < cfg.stateSize := Nat.zero_lt_of_lt cfg.shiftSize.is_lt /-- Mersenne Twister State. -/ structure State (cfg : Config) where /-- Data for current state. -/ data : Vector (BitVec cfg.wordSize) cfg.stateSize /-- Current data index. -/ index : Fin cfg.stateSize /-- Mersenne Twister initialization given an optional seed. -/ @[specialize cfg] protected def Config.init (cfg : MersenneTwister.Config) (seed : BitVec cfg.wordSize := cfg.initSeed) : State cfg := ⟨loop seed (.mkEmpty cfg.stateSize) (Nat.zero_le _), 0, cfg.zero_lt_stateSize⟩ where /-- Inner loop for Mersenne Twister initalization. -/ loop (w : BitVec cfg.wordSize) (v : Array (BitVec cfg.wordSize)) (h : v.size ≤ cfg.stateSize) := if heq : v.size = cfg.stateSize then ⟨v, heq⟩ else let v := v.push w let w := cfg.initMult * (w ^^^ (w >>> cfg.wordSize - 2)) + v.size loop w v (by simp only [v, Array.size_push]; omega) /-- Apply the twisting transformation to the given state. -/ @[specialize cfg] protected def State.twist (state : State cfg) : State cfg := let i := state.index let i' : Fin cfg.stateSize := if h : i.val+1 < cfg.stateSize then ⟨i.val+1, h⟩ else ⟨0, cfg.zero_lt_stateSize⟩ let y := state.data[i] &&& cfg.uMask ||| state.data[i'] &&& cfg.lMask let x := state.data[i+cfg.shiftSize] ^^^ bif y[0] then y >>> 1 ^^^ cfg.xorMask else y >>> 1 ⟨state.data.set i x, i'⟩ /-- Update the state by a number of generation steps (default 1). -/ -- TODO: optimize to `O(log(steps))` using the minimal polynomial protected def State.update (state : State cfg) : (steps : Nat := 1) → State cfg | 0 => state | steps+1 => state.twist.update steps /-- Mersenne Twister iteration. -/ @[specialize cfg] protected def State.next (state : State cfg) : BitVec cfg.wordSize × State cfg := let i := state.index let s := state.twist (temper s.data[i], s) where /-- Tempering step for Mersenne Twister. -/ @[inline] temper (x : BitVec cfg.wordSize) := match cfg.temperingShifts, cfg.temperingMasks with | (u, s, t, l), (d, b, c) => let x := x ^^^ x >>> u &&& d let x := x ^^^ x <<< s &&& b let x := x ^^^ x <<< t &&& c x ^^^ x >>> l instance (cfg) : Std.Stream (State cfg) (BitVec cfg.wordSize) where next? s := s.next /-- 32 bit Mersenne Twister (MT19937) configuration. -/ def mt19937 : Config where wordSize := 32 stateSize := 624 shiftSize := 397 maskBits := 31 xorMask := 0x9908b0df temperingShifts := (11, 7, 15, 18) temperingMasks := (0xffffffff, 0x9d2c5680, 0xefc60000) initMult := 1812433253 initSeed := 4357 /-- 64 bit Mersenne Twister (MT19937-64) configuration. -/ def mt19937_64 : Config where wordSize := 64 stateSize := 312 shiftSize := 156 maskBits := 31 xorMask := 0xb5026f5aa96619e9 temperingShifts := (29, 17, 37, 43) temperingMasks := (0x5555555555555555, 0x71d67fffeda60000, 0xfff7eee000000000) initMult := 6364136223846793005 initSeed := 19650218 ================================================ FILE: Batteries/Data/Random.lean ================================================ module public import Batteries.Data.Random.MersenneTwister ================================================ FILE: Batteries/Data/Range/Lemmas.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Tactic.SeqFocus public import Batteries.Tactic.Alias @[expose] public section namespace Std.Legacy.Range theorem size_stop_le_start : ∀ r : Range, r.stop ≤ r.start → r.size = 0 | ⟨start, stop, step, _⟩, h => by simp_all [size] omega theorem size_step_1 (start stop) : size ⟨start, stop, 1, by decide⟩ = stop - start := by simp [size] ================================================ FILE: Batteries/Data/Range.lean ================================================ module public import Batteries.Data.Range.Lemmas ================================================ FILE: Batteries/Data/Rat/Float.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Lean.Float @[expose] public section /-! # Rational Numbers and Float -/ namespace Rat /-- Convert this rational number to a `Float` value. -/ protected def toFloat (a : Rat) : Float := a.num.divFloat a.den /-- Convert this floating point number to a rational value. -/ protected def _root_.Float.toRat? (a : Float) : Option Rat := a.toRatParts.map fun (v, exp) => mkRat (v.sign * v.natAbs <<< exp.toNat) (1 <<< (-exp).toNat) /-- Convert this floating point number to a rational value, mapping non-finite values (`inf`, `-inf`, `nan`) to 0. -/ protected def _root_.Float.toRat0 (a : Float) : Rat := a.toRat?.getD 0 instance : Coe Rat Float := ⟨Rat.toFloat⟩ end Rat ================================================ FILE: Batteries/Data/Rat.lean ================================================ module public import Batteries.Data.Rat.Float ================================================ FILE: Batteries/Data/RunningStats.lean ================================================ /- Copyright (c) 2025 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module public import Init.Data.Nat section /-! # Running Statistics This module implements Welford's one-pass algorithm for calculating the mean and standard deviation of a sample or a population. The advantage of this algorithm is that it is not necessary to store the data. The algorithm uses the recurrence formulas for the mean `μ`, variance `σ²` and the sample variance `s²`: ``` μₖ = μₖ₋₁ + (xₖ − μₖ₋₁)/k σ²ₖ = σ²ₖ₋₁*(k-1)/k + (xₖ − μₖ₋₁)*(xₖ − μₖ)/k s²ₖ = s²ₖ₋₁*(k-2)/(k-1) + (xₖ - μₖ₋₁)²/k ``` To improve performance, Welford's algorithm keeps track of the two running quantities: ``` Mₖ = Mₖ₋₁ + (xₖ - Mₖ₋₁)/k Sₖ = Sₖ₋₁ + (xₖ - Mₖ₋₁)*(xₖ - Mₖ) ``` Then: `μₖ = Mₖ`, `σ²ₖ = Sₖ/k`, `s²ₖ = Sₖ/(k-1)`. -/ namespace Batteries /-- Compute running statistics of a data stream using Welford's algorithm. -/ public structure RunningStats where /-- Initialize running statistics. -/ init :: /-- Number of data points, -/ count : Nat := 0 /-- Mean of data points. -/ mean : Float := 0.0 /-- Variance of data points times the number of data points. -/ var : Float := 0.0 namespace RunningStats /-- Add a new data point to running statistics. -/ @[inline] public def push (data : Float) (s : RunningStats) : RunningStats := let count := s.count + 1 let mean := s.mean + (data - s.mean) / count.toFloat let var := s.var + (data - s.mean) * (data - mean) {count, mean, var} /-- Variance of running data stream. -/ @[inline] public def variance (s : RunningStats) : Float := if s.count ≤ 1 then 0.0 else s.var / s.count.toFloat /-- Unbiased variance of running data stream. -/ @[inline] public def sampleVariance (s : RunningStats) : Float := if s.count ≤ 2 then 0.0 else s.var / (s.count - 1).toFloat /-- Standard deviation of running data stream. -/ @[inline] public def standardDeviation (s : RunningStats) : Float := Float.sqrt s.sampleVariance ================================================ FILE: Batteries/Data/Stream.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2. license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section namespace Std.Stream /-- Drop up to `n` values from the stream `s`. -/ def drop [Stream σ α] (s : σ) : Nat → σ | 0 => s | n+1 => match next? s with | none => s | some (_, s) => drop s n /-- Read up to `n` values from the stream `s` as a list from first to last. -/ def take [Stream σ α] (s : σ) : Nat → List α × σ | 0 => ([], s) | n+1 => match next? s with | none => ([], s) | some (a, s) => match take s n with | (as, s) => (a :: as, s) @[simp] theorem fst_take_zero [Stream σ α] (s : σ) : (take s 0).fst = [] := rfl theorem fst_take_succ [Stream σ α] (s : σ) : (take s (n+1)).fst = match next? s with | none => [] | some (a, s) => a :: (take s n).fst := by simp only [take]; split <;> rfl @[simp] theorem snd_take_eq_drop [Stream σ α] (s : σ) (n : Nat) : (take s n).snd = drop s n := by induction n generalizing s with | zero => rfl | succ n ih => simp only [take, drop] split <;> simp [ih] /-- Tail recursive version of `Stream.take`. -/ def takeTR [Stream σ α] (s : σ) (n : Nat) : List α × σ := loop s [] n where /-- Inner loop for `Stream.takeTR`. -/ loop (s : σ) (acc : List α) | 0 => (acc.reverse, s) | n+1 => match next? s with | none => (acc.reverse, s) | some (a, s) => loop s (a :: acc) n theorem fst_takeTR_loop [Stream σ α] (s : σ) (acc : List α) (n : Nat) : (takeTR.loop s acc n).fst = acc.reverseAux (take s n).fst := by induction n generalizing acc s with | zero => rfl | succ n ih => simp only [take, takeTR.loop]; split; rfl; simp [ih] theorem fst_takeTR [Stream σ α] (s : σ) (n : Nat) : (takeTR s n).fst = (take s n).fst := fst_takeTR_loop .. theorem snd_takeTR_loop [Stream σ α] (s : σ) (acc : List α) (n : Nat) : (takeTR.loop s acc n).snd = drop s n := by induction n generalizing acc s with | zero => rfl | succ n ih => simp only [takeTR.loop, drop]; split; rfl; simp [ih] theorem snd_takeTR [Stream σ α] (s : σ) (n : Nat) : (takeTR s n).snd = drop s n := snd_takeTR_loop .. @[csimp] theorem take_eq_takeTR : @take = @takeTR := by funext; ext : 1; rw [fst_takeTR]; rw [snd_takeTR, snd_take_eq_drop] end Stream @[simp] theorem List.stream_drop_eq_drop (l : List α) : Stream.drop l n = l.drop n := by induction n generalizing l with | zero => rfl | succ n ih => match l with | [] => rfl | _::_ => simp [Stream.drop, List.drop_succ_cons, ih] @[simp] theorem List.stream_take_eq_take_drop (l : List α) : Stream.take l n = (l.take n, l.drop n) := by induction n generalizing l with | zero => rfl | succ n ih => match l with | [] => rfl | _::_ => simp [Stream.take, ih] ================================================ FILE: Batteries/Data/String/AsciiCasing.lean ================================================ /- Copyright (c) 2025 Christopher Bailey. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Christopher Bailey, F. G. Dorais -/ module /- Failing on nightly-2025-12-18 public import Batteries.Data.Char public import Batteries.Data.Char.AsciiCasing @[expose] public section namespace String /-- Case folding for ASCII characters only. Alphabetic ASCII characters are mapped to their lowercase form, all other characters are left unchanged. This agrees with the Unicode case folding algorithm for ASCII characters. ``` #eval "ABC".caseFoldAsciiOnly == "abc" -- true #eval "x".caseFoldAsciiOnly == "y" -- false #eval "Àà".caseFoldAsciiOnly == "Àà" -- true #eval "1$#!".caseFoldAsciiOnly == "1$#!" -- true ``` -/ abbrev caseFoldAsciiOnly (s : String) := s.map Char.caseFoldAsciiOnly -- TODO: Reimplement with finite iterators/streams when available for `String`. private partial def beqCaseInsensitiveAsciiOnlyImpl (s₁ s₂ : String) : Bool := s₁.length == s₂.length && loop (ToStream.toStream s₁) (ToStream.toStream s₂) where loop i₁ i₂ := match Stream.next? i₁, Stream.next? i₂ with | some (c₁, i₁), some (c₂, i₂) => c₁.beqCaseInsensitiveAsciiOnly c₂ && loop i₁ i₂ | none, none => true | _, _ => false /-- Bool-valued comparison of two `String`s for *ASCII*-case insensitive equality. #eval "abc".beqCaseInsensitiveAsciiOnly "ABC" -- true #eval "cba".beqCaseInsensitiveAsciiOnly "ABC" -- false #eval "$".beqCaseInsensitiveAsciiOnly "$" -- true #eval "a".beqCaseInsensitiveAsciiOnly "b" -- false #eval "γ".beqCaseInsensitiveAsciiOnly "Γ" -- false -/ @[implemented_by beqCaseInsensitiveAsciiOnlyImpl] def beqCaseInsensitiveAsciiOnly (s₁ s₂ : String) : Bool := s₁.caseFoldAsciiOnly == s₂.caseFoldAsciiOnly theorem beqCaseInsensitiveAsciiOnly.eqv : Equivalence (beqCaseInsensitiveAsciiOnly · ·) := { refl _ := BEq.rfl trans _ _ := by simp_all [beqCaseInsensitiveAsciiOnly] symm := by simp_all [beqCaseInsensitiveAsciiOnly] } /-- Setoid structure on `String` usig `beqCaseInsensitiveAsciiOnly` -/ def beqCaseInsensitiveAsciiOnly.isSetoid : Setoid String := ⟨(beqCaseInsensitiveAsciiOnly · ·), beqCaseInsensitiveAsciiOnly.eqv⟩ -- TODO: Reimplement with finite iterators/streams when available for `String`. private partial def cmpCaseInsensitiveAsciiOnlyImpl (s₁ s₂ : String) : Ordering := loop (ToStream.toStream s₁) (ToStream.toStream s₂) where loop i₁ i₂ := match Stream.next? i₁, Stream.next? i₂ with | some (c₁, i₁), some (c₂, i₂) => c₁.cmpCaseInsensitiveAsciiOnly c₂ |>.then (loop i₁ i₂) | some _, none => .gt | none, some _ => .lt | none, none => .eq /-- ASCII-case insensitive implementation comparison returning an `Ordering`. Useful for sorting. ``` #eval cmpCaseInsensitiveAsciiOnly "a" "A" -- eq #eval cmpCaseInsensitiveAsciiOnly "a" "a" -- eq #eval cmpCaseInsensitiveAsciiOnly "$" "$" -- eq #eval cmpCaseInsensitiveAsciiOnly "a" "b" -- lt #eval cmpCaseInsensitiveAsciiOnly "γ" "Γ" -- gt ``` -/ @[implemented_by cmpCaseInsensitiveAsciiOnlyImpl] def cmpCaseInsensitiveAsciiOnly (s₁ s₂ : String) : Ordering := compare s₁.caseFoldAsciiOnly s₂.caseFoldAsciiOnly -/ ================================================ FILE: Batteries/Data/String/Basic.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg, James Gallicchio, F. G. Dorais -/ module @[expose] public section instance : Coe String Substring.Raw := ⟨String.toRawSubstring⟩ namespace String /-- Count the occurrences of a character in a string. -/ def count (s : String) (c : Char) : Nat := s.foldl (fun n d => if d = c then n + 1 else n) 0 /-- Convert a string of assumed-ASCII characters into a byte array. (If any characters are non-ASCII they will be reduced modulo 256.) Note: if you just need the underlying `ByteArray` of a non-ASCII string, use `String.toUTF8`. -/ def toAsciiByteArray (s : String) : ByteArray := let rec /-- Internal implementation of `toAsciiByteArray`. `loop p out = out ++ toAsciiByteArray ({ s with startPos := p } : Substring)` -/ loop (p : Pos.Raw) (out : ByteArray) : ByteArray := if h : p.atEnd s then out else let c := p.get s have : utf8ByteSize s - (Pos.Raw.next s p).byteIdx < utf8ByteSize s - p.byteIdx := Nat.sub_lt_sub_left (Nat.lt_of_not_le <| mt decide_eq_true h) (Nat.lt_add_of_pos_right (Char.utf8Size_pos _)) loop (p.next s) (out.push c.toUInt8) termination_by utf8ByteSize s - p.byteIdx loop 0 ByteArray.empty ================================================ FILE: Batteries/Data/String/Legacy.lean ================================================ /- Copyright (c) 2016 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Author: Leonardo de Moura, Mario Carneiro -/ module /-! # Legacy implementations of `String` operations This file includes old definitions of `String` functions that were downstreamed from core to prevent `Batteries.Data.String.Lemmas` from breaking. -/ public section set_option linter.deprecated false namespace String private noncomputable def utf8ByteSize' : String → Nat | s => go s.toList where go : List Char → Nat | [] => 0 | c::cs => go cs + c.utf8Size private theorem utf8ByteSize'_eq (s : String) : s.utf8ByteSize' = s.utf8ByteSize := by suffices ∀ l, utf8ByteSize'.go l = (ofList l).utf8ByteSize by obtain ⟨m, rfl⟩ := s.exists_eq_ofList rw [utf8ByteSize', this, ofList_toList] intro l induction l with | nil => simp [utf8ByteSize'.go] | cons c cs ih => rw [utf8ByteSize'.go, ih, ← List.singleton_append, String.ofList_append, utf8ByteSize_append, Nat.add_comm] congr rw [← size_toByteArray, String.toByteArray_ofList, List.utf8Encode_singleton, List.size_toByteArray, length_utf8EncodeChar] private theorem set_next_add (s : String) (i : Pos.Raw) (c : Char) (b₁ b₂) (h : (i.next s).1 + b₁ = s.rawEndPos.1 + b₂) : (i.next (i.set s c)).1 + b₁ = (i.set s c).rawEndPos.1 + b₂ := by simp [Pos.Raw.next, Pos.Raw.get, Pos.Raw.set, rawEndPos, ← utf8ByteSize'_eq, utf8ByteSize'] at h ⊢ rw [Nat.add_comm i.1, Nat.add_assoc] at h ⊢ let rec foo : ∀ cs a b₁ b₂, (Pos.Raw.utf8GetAux cs a i).utf8Size + b₁ = utf8ByteSize'.go cs + b₂ → (Pos.Raw.utf8GetAux (Pos.Raw.utf8SetAux c cs a i) a i).utf8Size + b₁ = utf8ByteSize'.go (Pos.Raw.utf8SetAux c cs a i) + b₂ | [], _, _, _, h => h | c'::cs, a, b₁, b₂, h => by unfold Pos.Raw.utf8SetAux apply iteInduction (motive := fun p => (Pos.Raw.utf8GetAux p a i).utf8Size + b₁ = utf8ByteSize'.go p + b₂) <;> intro h' <;> simp [Pos.Raw.utf8GetAux, h', utf8ByteSize'.go] at h ⊢ next => rw [Nat.add_assoc, Nat.add_left_comm] at h ⊢; rw [Nat.add_left_cancel h] next => rw [Nat.add_assoc] at h ⊢ refine foo cs (a + c') b₁ (c'.utf8Size + b₂) h exact foo s.toList 0 _ _ h private theorem mapAux_lemma (s : String) (i : Pos.Raw) (c : Char) (h : ¬i.atEnd s) : (i.set s c).rawEndPos.1 - (i.next (i.set s c)).1 < s.rawEndPos.1 - i.1 := by suffices (i.set s c).rawEndPos.1 - (i.next (i.set s c)).1 = s.rawEndPos.1 - (i.next s).1 by rw [this] apply Nat.sub_lt_sub_left (Nat.gt_of_not_le (mt decide_eq_true h)) (Pos.Raw.lt_next ..) have := set_next_add s i c (s.rawEndPos.byteIdx - (i.next s).byteIdx) 0 have := set_next_add s i c 0 ((i.next s).byteIdx - s.rawEndPos.byteIdx) omega /-- Implementation of `String.Legacy.map`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), specialize] def Legacy.mapAux (f : Char → Char) (i : Pos.Raw) (s : String) : String := if h : i.atEnd s then s else let c := f (i.get s) have := mapAux_lemma s i c h let s := i.set s c mapAux f (i.next s) s termination_by s.rawEndPos.1 - i.1 /-- Applies the function `f` to every character in a string, returning a string that contains the resulting characters. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.map`. Examples: * `"abc123".map Char.toUpper = "ABC123"` * `"".map Char.toUpper = ""` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.map (f : Char → Char) (s : String) : String := mapAux f 0 s /-- Removes the specified number of characters (Unicode code points) from the start of the string. If `n` is greater than `s.length`, returns `""`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.drop`. Examples: * `"red green blue".drop 4 = "green blue"` * `"red green blue".drop 10 = "blue"` * `"red green blue".drop 50 = ""` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.drop (s : String) (n : Nat) : String := (s.toRawSubstring.drop n).toString /-- Creates a new string that contains the first `n` characters (Unicode code points) of `s`. If `n` is greater than `s.length`, returns `s`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.take`. Examples: * `"red green blue".take 3 = "red"` * `"red green blue".take 1 = "r"` * `"red green blue".take 0 = ""` * `"red green blue".take 100 = "red green blue"` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.take (s : String) (n : Nat) : String := (s.toRawSubstring.take n).toString /-- Creates a new string that contains the longest prefix of `s` in which `p` returns `true` for all characters. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.takeWhile`. Examples: * `"red green blue".takeWhile (·.isLetter) = "red"` * `"red green blue".takeWhile (· == 'r') = "r"` * `"red green blue".takeWhile (· != 'n') = "red gree"` * `"red green blue".takeWhile (fun _ => true) = "red green blue"` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.takeWhile (s : String) (p : Char → Bool) : String := (s.toRawSubstring.takeWhile p).toString /-- Creates a new string by removing the longest prefix from `s` in which `p` returns `true` for all characters. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.dropWhile`. Examples: * `"red green blue".dropWhile (·.isLetter) = " green blue"` * `"red green blue".dropWhile (· == 'r') = "ed green blue"` * `"red green blue".dropWhile (· != 'n') = "n blue"` * `"red green blue".dropWhile (fun _ => true) = ""` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.dropWhile (s : String) (p : Char → Bool) : String := (s.toRawSubstring.dropWhile p).toString /-- Auxiliary definition for `String.Legacy.foldl`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.foldlAux`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), specialize] def Legacy.foldlAux {α : Type u} (f : α → Char → α) (s : String) (stopPos : Pos.Raw) (i : Pos.Raw) (a : α) : α := if h : i < stopPos then have := Nat.sub_lt_sub_left h (Pos.Raw.lt_next s i) foldlAux f s stopPos (i.next s) (f a (i.get s)) else a termination_by stopPos.1 - i.1 /-- Folds a function over a string from the left, accumulating a value starting with `init`. The accumulated value is combined with each character in order, using `f`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.foldl`. Examples: * `"coffee tea water".foldl (fun n c => if c.isWhitespace then n + 1 else n) 0 = 2` * `"coffee tea and water".foldl (fun n c => if c.isWhitespace then n + 1 else n) 0 = 3` * `"coffee tea water".foldl (·.push ·) "" = "coffee tea water"` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.foldl {α : Type u} (f : α → Char → α) (init : α) (s : String) : α := foldlAux f s s.rawEndPos 0 init /-- Returns the first character in `s`. If `s = ""`, returns `(default : Char)`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.front`. Examples: * `"abc".front = 'a'` * `"".front = (default : Char)` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline, expose] def Legacy.front (s : String) : Char := Pos.Raw.get s 0 /-- Returns the last character in `s`. If `s = ""`, returns `(default : Char)`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `String.back`. Examples: * `"abc".back = 'c'` * `"".back = (default : Char)` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline, expose] def Legacy.back (s : String) : Char := (s.rawEndPos.prev s).get s /-- Auxuliary definition for `String.Legacy.posOf`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26")] def Legacy.posOfAux (s : String) (c : Char) (stopPos : Pos.Raw) (pos : Pos.Raw) : Pos.Raw := if h : pos < stopPos then if pos.get s == c then pos else have := Nat.sub_lt_sub_left h (Pos.Raw.lt_next s pos) posOfAux s c stopPos (pos.next s) else pos termination_by stopPos.1 - pos.1 /-- Returns the position of the first occurrence of a character, `c`, in a string `s`. If `s` does not contain `c`, returns `s.rawEndPos`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"abcba".posOf 'a' = ⟨0⟩` * `"abcba".posOf 'z' = ⟨5⟩` * `"L∃∀N".posOf '∀' = ⟨4⟩` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.posOf (s : String) (c : Char) : Pos.Raw := posOfAux s c s.rawEndPos 0 /-- Auxuliary definition for `String.Legacy.revPosOf`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26")] def Legacy.revPosOfAux (s : String) (c : Char) (pos : Pos.Raw) : Option Pos.Raw := if h : pos = 0 then none else have := Pos.Raw.prev_lt_of_pos s pos h let pos := pos.prev s if pos.get s == c then some pos else revPosOfAux s c pos termination_by pos.1 /-- Returns the position of the last occurrence of a character, `c`, in a string `s`. If `s` does not contain `c`, returns `none`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"abcabc".revPosOf 'a' = some ⟨3⟩` * `"abcabc".revPosOf 'z' = none` * `"L∃∀N".revPosOf '∀' = some ⟨4⟩` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.revPosOf (s : String) (c : Char) : Option Pos.Raw := revPosOfAux s c s.rawEndPos /-- Auxuliary definition for `String.Legacy.find`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26")] def Legacy.findAux (s : String) (p : Char → Bool) (stopPos : Pos.Raw) (pos : Pos.Raw) : Pos.Raw := if h : pos < stopPos then if p (pos.get s) then pos else have := Nat.sub_lt_sub_left h (Pos.Raw.lt_next s pos) findAux s p stopPos (pos.next s) else pos termination_by stopPos.1 - pos.1 /-- Finds the position of the first character in a string for which the Boolean predicate `p` returns `true`. If there is no such character in the string, then the end position of the string is returned. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"coffee tea water".find (·.isWhitespace) = ⟨6⟩` * `"tea".find (· == 'X') = ⟨3⟩` * `"".find (· == 'X') = ⟨0⟩` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.find (s : String) (p : Char → Bool) : Pos.Raw := findAux s p s.rawEndPos 0 /-- Auxuliary definition for `String.Legacy.revFind`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26")] def Legacy.revFindAux (s : String) (p : Char → Bool) (pos : Pos.Raw) : Option Pos.Raw := if h : pos = 0 then none else have := Pos.Raw.prev_lt_of_pos s pos h let pos := pos.prev s if p (pos.get s) then some pos else revFindAux s p pos termination_by pos.1 /-- Finds the position of the last character in a string for which the Boolean predicate `p` returns `true`. If there is no such character in the string, then `none` is returned. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"coffee tea water".revFind (·.isWhitespace) = some ⟨10⟩` * `"tea".revFind (· == 'X') = none` * `"".revFind (· == 'X') = none` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.revFind (s : String) (p : Char → Bool) : Option Pos.Raw := revFindAux s p s.rawEndPos /-- Auxuliary definition for `String.Legacy.foldr`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), specialize] def Legacy.foldrAux {α : Type u} (f : Char → α → α) (a : α) (s : String) (i begPos : Pos.Raw) : α := if h : begPos < i then have := Pos.Raw.prev_lt_of_pos s i <| mt (congrArg String.Pos.Raw.byteIdx) <| Ne.symm <| Nat.ne_of_lt <| Nat.lt_of_le_of_lt (Nat.zero_le _) h let i := i.prev s let a := f (i.get s) a foldrAux f a s i begPos else a termination_by i.1 /-- Folds a function over a string from the right, accumulating a value starting with `init`. The accumulated value is combined with each character in reverse order, using `f`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"coffee tea water".foldr (fun c n => if c.isWhitespace then n + 1 else n) 0 = 2` * `"coffee tea and water".foldr (fun c n => if c.isWhitespace then n + 1 else n) 0 = 3` * `"coffee tea water".foldr (fun c s => c.push s) "" = "retaw dna aet eeffoc"` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.foldr {α : Type u} (f : Char → α → α) (init : α) (s : String) : α := foldrAux f init s s.rawEndPos 0 /-- Auxuliary definition for `String.Legacy.any`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), specialize] def Legacy.anyAux (s : String) (stopPos : Pos.Raw) (p : Char → Bool) (i : Pos.Raw) : Bool := if h : i < stopPos then if p (i.get s) then true else have := Nat.sub_lt_sub_left h (Pos.Raw.lt_next s i) anyAux s stopPos p (i.next s) else false termination_by stopPos.1 - i.1 /-- Checks whether there is a character in a string for which the Boolean predicate `p` returns `true`. Short-circuits at the first character for which `p` returns `true`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"brown".any (·.isLetter) = true` * `"brown".any (·.isWhitespace) = false` * `"brown and orange".any (·.isLetter) = true` * `"".any (fun _ => false) = false` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.any (s : String) (p : Char → Bool) : Bool := anyAux s s.rawEndPos p 0 /-- Checks whether the Boolean predicate `p` returns `true` for every character in a string. Short-circuits at the first character for which `p` returns `false`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"brown".all (·.isLetter) = true` * `"brown and orange".all (·.isLetter) = false` * `"".all (fun _ => false) = true` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.all (s : String) (p : Char → Bool) : Bool := !Legacy.any s (fun c => !p c) /-- Checks whether a string contains the specified character. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Examples: * `"green".contains 'e' = true` * `"green".contains 'x' = false` * `"".contains 'x' = false` -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.contains (s : String) (c : Char) : Bool := Legacy.any s (fun a => a == c) end String namespace Substring.Raw /-- Folds a function over a substring from the left, accumulating a value starting with `init`. The accumulated value is combined with each character in order, using `f`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. Its runtime behavior is equivalent to that of `Substring.Raw.foldl`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.foldl {α : Type u} (f : α → Char → α) (init : α) (s : Substring.Raw) : α := match s with | ⟨s, b, e⟩ => String.Legacy.foldlAux f s e b init /-- Folds a function over a substring from the right, accumulating a value starting with `init`. The accumulated value is combined with each character in reverse order, using `f`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.foldr {α : Type u} (f : Char → α → α) (init : α) (s : Substring.Raw) : α := match s with | ⟨s, b, e⟩ => String.Legacy.foldrAux f init s e b /-- Checks whether the Boolean predicate `p` returns `true` for any character in a substring. Short-circuits at the first character for which `p` returns `true`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.any (s : Substring.Raw) (p : Char → Bool) : Bool := match s with | ⟨s, b, e⟩ => String.Legacy.anyAux s e p b /-- Checks whether the Boolean predicate `p` returns `true` for every character in a substring. Short-circuits at the first character for which `p` returns `false`. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.all (s : Substring.Raw) (p : Char → Bool) : Bool := !Legacy.any s (fun c => !p c) /-- Checks whether a substring contains the specified character. This is an old implementation, preserved here for users of the lemmas in `Batteries.Data.String.Lemmas`. -/ @[deprecated "Use the new `String` API." (since := "2026-03-26"), inline] def Legacy.contains (s : Substring.Raw) (c : Char) : Bool := Legacy.any s (fun a => a == c) end Substring.Raw ================================================ FILE: Batteries/Data/String/Lemmas.lean ================================================ /- Copyright (c) 2023 Bulhwi Cha. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Bulhwi Cha, Mario Carneiro -/ module public import Batteries.Data.String.Basic public import Batteries.Tactic.Lint.Misc public import Batteries.Tactic.SeqFocus public import Batteries.Classes.Order public import Batteries.Data.List.Basic public import Batteries.Data.String.Legacy import all Init.Data.String.Defs -- for unfolding `isEmpty` import all Init.Data.String.Substring -- for unfolding `Substring` functions import all Init.Data.String.Iterator -- for unfolding `Iterator` functions import all Init.Data.String.Extra -- for unfolding `Substring.toIterator` import all Init.Data.String.TakeDrop -- for unfolding `drop` import all Init.Data.String.Modify -- for unfolding `String.mapAux` import all Batteries.Data.String.Legacy -- for unfolding `String.Legacy.map` import all Init.Data.String.Legacy -- for unfolding `String.splitOnAux` @[expose] public section set_option linter.deprecated false namespace String -- TODO(kmill): add `@[ext]` attribute to `String.ext` in core. attribute [ext (iff := false)] ext theorem lt_antisymm {s₁ s₂ : String} (h₁ : ¬s₁ < s₂) (h₂ : ¬s₂ < s₁) : s₁ = s₂ := by simp at h₁ h₂ exact String.le_antisymm h₂ h₁ instance : Std.LawfulLTOrd String := .compareOfLessAndEq_of_irrefl_of_trans_of_antisymm String.lt_irrefl String.lt_trans String.lt_antisymm @[deprecated length_ofList (since := "2025-10-31")] theorem mk_length (s : List Char) : (String.ofList s).length = s.length := length_ofList theorem Pos.Raw.offsetBy_eq {p q : Pos.Raw} : p.offsetBy q = ⟨q.byteIdx + p.byteIdx⟩ := by ext simp private theorem add_utf8Size_pos : 0 < i + Char.utf8Size c := Nat.add_pos_right _ (Char.utf8Size_pos c) private theorem ne_add_utf8Size_add_self : i ≠ n + Char.utf8Size c + i := Nat.ne_of_lt (Nat.lt_add_of_pos_left add_utf8Size_pos) private theorem ne_self_add_add_utf8Size : i ≠ i + (n + Char.utf8Size c) := Nat.ne_of_lt (Nat.lt_add_of_pos_right add_utf8Size_pos) /-- The UTF-8 byte length of a list of characters. (This is intended for specification purposes.) -/ @[inline] def utf8Len : List Char → Nat | [] => 0 | c::cs => utf8Len cs + c.utf8Size theorem utf8ByteSize_ofList (cs) : utf8ByteSize (String.ofList cs) = utf8Len cs := by induction cs with | nil => simp [utf8Len] | cons c cs ih => rw [utf8Len, ← ih, ← List.singleton_append, String.ofList_append, utf8ByteSize_append, Nat.add_comm] congr rw [← size_toByteArray, String.toByteArray_ofList, List.utf8Encode_singleton, List.size_toByteArray, length_utf8EncodeChar] @[deprecated utf8ByteSize_ofList (since := "2025-10-31")] theorem utf8ByteSize_mk (cs) : utf8ByteSize (ofList cs) = utf8Len cs := utf8ByteSize_ofList cs @[simp] theorem utf8Len_nil : utf8Len [] = 0 := rfl @[simp] theorem utf8Len_cons (c cs) : utf8Len (c :: cs) = utf8Len cs + c.utf8Size := rfl @[simp] theorem utf8Len_append (cs₁ cs₂) : utf8Len (cs₁ ++ cs₂) = utf8Len cs₁ + utf8Len cs₂ := by induction cs₁ <;> simp [*, Nat.add_right_comm] theorem utf8Len_reverseAux (cs₁ cs₂) : utf8Len (cs₁.reverseAux cs₂) = utf8Len cs₁ + utf8Len cs₂ := by induction cs₁ generalizing cs₂ <;> simp_all [← Nat.add_assoc, Nat.add_right_comm] @[simp] theorem utf8Len_reverse (cs) : utf8Len cs.reverse = utf8Len cs := utf8Len_reverseAux .. @[simp] theorem utf8Len_eq_zero : utf8Len l = 0 ↔ l = [] := by cases l <;> simp [Nat.ne_zero_iff_zero_lt.mpr (Char.utf8Size_pos _)] section open List theorem utf8Len_le_of_sublist : ∀ {cs₁ cs₂}, cs₁ <+ cs₂ → utf8Len cs₁ ≤ utf8Len cs₂ | _, _, .slnil => Nat.le_refl _ | _, _, .cons _ h => Nat.le_trans (utf8Len_le_of_sublist h) (Nat.le_add_right ..) | _, _, .cons_cons _ h => Nat.add_le_add_right (utf8Len_le_of_sublist h) _ theorem utf8Len_le_of_infix (h : cs₁ <:+: cs₂) : utf8Len cs₁ ≤ utf8Len cs₂ := utf8Len_le_of_sublist h.sublist theorem utf8Len_le_of_suffix (h : cs₁ <:+ cs₂) : utf8Len cs₁ ≤ utf8Len cs₂ := utf8Len_le_of_sublist h.sublist theorem utf8Len_le_of_prefix (h : cs₁ <+: cs₂) : utf8Len cs₁ ≤ utf8Len cs₂ := utf8Len_le_of_sublist h.sublist end @[simp] theorem rawEndPos_ofList (cs : List Char) : rawEndPos (ofList cs ) = ⟨utf8Len cs⟩ := by apply Pos.Raw.ext simp [String.rawEndPos, utf8ByteSize_ofList] @[deprecated rawEndPos_ofList (since := "2025-10-31")] theorem rawEndPos_asString (cs : List Char) : rawEndPos (ofList cs) = ⟨utf8Len cs⟩ := rawEndPos_ofList cs @[deprecated rawEndPos_ofList (since := "2025-10-21")] theorem endPos_asString (cs : List Char) : rawEndPos (ofList cs) = ⟨utf8Len cs⟩ := rawEndPos_ofList cs @[deprecated rawEndPos_ofList (since := "2025-10-21")] theorem rawEndPos_mk (cs : List Char) : rawEndPos (ofList cs) = ⟨utf8Len cs⟩ := rawEndPos_ofList cs @[deprecated rawEndPos_ofList (since := "2025-10-21")] theorem endPos_mk (cs : List Char) : rawEndPos (ofList cs) = ⟨utf8Len cs⟩ := rawEndPos_ofList cs @[simp] theorem utf8Len_toList (s : String) : utf8Len s.toList = s.utf8ByteSize := by rw [← utf8ByteSize_ofList, ofList_toList] @[deprecated utf8Len_toList (since := "2025-10-21")] theorem utf8Len_data (s : String) : utf8Len s.toList = s.utf8ByteSize := utf8Len_toList s namespace Pos.Raw -- TODO(kmill): add `@[ext]` attribute to `String.Pos.ext` in core. attribute [ext (iff := false)] ext theorem lt_addChar (p : Pos.Raw) (c : Char) : p < p + c := Nat.lt_add_of_pos_right (Char.utf8Size_pos _) private theorem zero_ne_addChar {i : Pos.Raw} {c : Char} : 0 ≠ i + c := ne_of_lt add_utf8Size_pos /-- A string position is valid if it is equal to the UTF-8 length of an initial substring of `s`. -/ inductive Valid : String → Pos.Raw → Prop where /-- A string position is valid if it is equal to the UTF-8 length of an initial substring of `s`. -/ | mk (cs cs' : List Char) {p} (hp : p.1 = utf8Len cs) : Valid (String.ofList (cs ++ cs')) p theorem Valid.intro {s : String} {p : Pos.Raw} (h : ∃ cs cs', cs ++ cs' = s.toList ∧ p.1 = utf8Len cs) : Valid s p := by obtain ⟨cs, cs', h₁, h₂⟩ := h rw [← String.ofList_toList (s := s), ← h₁] exact .mk cs cs' h₂ theorem Valid.exists : {s : String} → {p : Pos.Raw} → Valid s p → ∃ cs cs', String.ofList (cs ++ cs') = s ∧ p = ⟨utf8Len cs⟩ | _, _, .mk cs cs' rfl => ⟨cs, cs', rfl, rfl⟩ @[simp] theorem valid_zero : Valid s 0 := .intro ⟨[], s.toList, rfl, rfl⟩ @[simp] theorem valid_rawEndPos : Valid s (rawEndPos s) := .intro ⟨s.toList, [], by simp, by simp⟩ @[deprecated valid_rawEndPos (since := "2025-10-21")] theorem valid_endPos : Valid s (rawEndPos s) := valid_rawEndPos theorem Valid.le_rawEndPos : ∀ {s p}, Valid s p → p ≤ rawEndPos s | _, ⟨_⟩, .mk cs cs' rfl => by simp [rawEndPos, le_iff, utf8ByteSize_ofList] @[deprecated le_rawEndPos (since := "2025-10-21")] theorem Valid.le_endPos : ∀ {s p}, Valid s p → p ≤ rawEndPos s := le_rawEndPos end Pos.Raw @[deprecated rawEndPos_eq_zero_iff (since := "2025-10-21")] theorem endPos_eq_zero (s : String) : rawEndPos s = 0 ↔ s = "" := rawEndPos_eq_zero_iff /-- Induction along the valid positions in a list of characters. (This definition is intended only for specification purposes.) -/ def utf8InductionOn {motive : List Char → Pos.Raw → Sort u} (s : List Char) (i p : Pos.Raw) (nil : ∀ i, motive [] i) (eq : ∀ c cs, motive (c :: cs) p) (ind : ∀ (c : Char) cs i, i ≠ p → motive cs (i + c) → motive (c :: cs) i) : motive s i := match s with | [] => nil i | c::cs => if h : i = p then h ▸ eq c cs else ind c cs i h (utf8InductionOn cs (i + c) p nil eq ind) theorem utf8GetAux_add_right_cancel (s : List Char) (i p n : Nat) : Pos.Raw.utf8GetAux s ⟨i + n⟩ ⟨p + n⟩ = Pos.Raw.utf8GetAux s ⟨i⟩ ⟨p⟩ := by apply utf8InductionOn s ⟨i⟩ ⟨p⟩ (motive := fun s i => Pos.Raw.utf8GetAux s ⟨i.byteIdx + n⟩ ⟨p + n⟩ = Pos.Raw.utf8GetAux s i ⟨p⟩) <;> simp only [Pos.Raw.utf8GetAux, Char.reduceDefault, implies_true, ↓reduceIte, ne_eq, Pos.Raw.byteIdx_add_char] intro c cs ⟨i⟩ h ih simp only [Pos.Raw.ext_iff, Pos.Raw.add_char_eq] at h ⊢ simp only [Nat.add_right_cancel_iff, h, ↓reduceIte] rw [Nat.add_right_comm] exact ih theorem utf8GetAux_addChar_right_cancel (s : List Char) (i p : Pos.Raw) (c : Char) : Pos.Raw.utf8GetAux s (i + c) (p + c) = Pos.Raw.utf8GetAux s i p := utf8GetAux_add_right_cancel .. theorem utf8GetAux_of_valid (cs cs' : List Char) {i p : Nat} (hp : i + utf8Len cs = p) : Pos.Raw.utf8GetAux (cs ++ cs') ⟨i⟩ ⟨p⟩ = cs'.headD default := by match cs, cs' with | [], [] => rfl | [], c::cs' => simp [← hp, Pos.Raw.utf8GetAux] | c::cs, cs' => simp only [List.cons_append, Pos.Raw.utf8GetAux, Char.reduceDefault] rw [if_neg] case hnc => simp only [← hp, utf8Len_cons, Pos.Raw.ext_iff]; exact ne_self_add_add_utf8Size refine utf8GetAux_of_valid cs cs' ?_ simpa [Nat.add_assoc, Nat.add_comm] using hp theorem get_of_valid (cs cs' : List Char) : Pos.Raw.get (ofList (cs ++ cs')) ⟨utf8Len cs⟩ = cs'.headD default := by rw [Pos.Raw.get, String.toList_ofList] exact utf8GetAux_of_valid _ _ (Nat.zero_add _) theorem get_cons_addChar (c : Char) (cs : List Char) (i : Pos.Raw) : (i + c).get (ofList (c :: cs)) = i.get (ofList cs) := by simp [Pos.Raw.get, Pos.Raw.utf8GetAux, Pos.Raw.zero_ne_addChar, utf8GetAux_addChar_right_cancel] theorem utf8GetAux?_of_valid (cs cs' : List Char) {i p : Nat} (hp : i + utf8Len cs = p) : Pos.Raw.utf8GetAux? (cs ++ cs') ⟨i⟩ ⟨p⟩ = cs'.head? := by match cs, cs' with | [], [] => rfl | [], c::cs' => simp [← hp, Pos.Raw.utf8GetAux?] | c::cs, cs' => simp only [List.cons_append, Pos.Raw.utf8GetAux?] rw [if_neg] case hnc => simp only [← hp, Pos.Raw.ext_iff]; exact ne_self_add_add_utf8Size refine utf8GetAux?_of_valid cs cs' ?_ simpa [Nat.add_assoc, Nat.add_comm] using hp theorem get?_of_valid (cs cs' : List Char) : Pos.Raw.get? (ofList (cs ++ cs')) ⟨utf8Len cs⟩ = cs'.head? := by rw [Pos.Raw.get?, String.toList_ofList] exact utf8GetAux?_of_valid _ _ (Nat.zero_add _) theorem utf8SetAux_of_valid (c' : Char) (cs cs' : List Char) {i p : Nat} (hp : i + utf8Len cs = p) : Pos.Raw.utf8SetAux c' (cs ++ cs') ⟨i⟩ ⟨p⟩ = cs ++ cs'.modifyHead fun _ => c' := by match cs, cs' with | [], [] => rfl | [], c::cs' => simp [← hp, Pos.Raw.utf8SetAux] | c::cs, cs' => simp only [Pos.Raw.utf8SetAux, List.cons_append] rw [if_neg] case hnc => simp only [← hp, Pos.Raw.ext_iff]; exact ne_self_add_add_utf8Size refine congrArg (c::·) (utf8SetAux_of_valid c' cs cs' ?_) simpa [Nat.add_assoc, Nat.add_comm] using hp theorem set_of_valid (cs cs' : List Char) (c' : Char) : Pos.Raw.set (ofList (cs ++ cs')) ⟨utf8Len cs⟩ c' = ofList (cs ++ cs'.modifyHead fun _ => c') := by ext rw [Pos.Raw.set, String.toList_ofList, String.toList_ofList, String.toList_ofList, utf8SetAux_of_valid _ _ _] exact Nat.zero_add _ theorem modify_of_valid (cs cs' : List Char) : Pos.Raw.modify (ofList (cs ++ cs')) ⟨utf8Len cs⟩ f = ofList (cs ++ cs'.modifyHead f) := by rw [Pos.Raw.modify, set_of_valid, get_of_valid]; cases cs' <;> rfl theorem next_of_valid' (cs cs' : List Char) : Pos.Raw.next (ofList (cs ++ cs')) ⟨utf8Len cs⟩ = ⟨utf8Len cs + (cs'.headD default).utf8Size⟩ := by simp only [Pos.Raw.next, get_of_valid]; rfl theorem next_of_valid (cs : List Char) (c : Char) (cs' : List Char) : Pos.Raw.next (ofList (cs ++ c :: cs')) ⟨utf8Len cs⟩ = ⟨utf8Len cs + c.utf8Size⟩ := next_of_valid' .. @[simp] theorem atEnd_iff (s : String) (p : Pos.Raw) : p.atEnd s ↔ s.rawEndPos ≤ p := decide_eq_true_iff theorem valid_next {p : Pos.Raw} (h : p.Valid s) (h₂ : p < s.rawEndPos) : (Pos.Raw.next s p).Valid s := by match s, p, h with | _, ⟨_⟩, .mk cs [] rfl => simp at h₂ | _, ⟨_⟩, .mk cs (c::cs') rfl => rw [next_of_valid] simpa using Pos.Raw.Valid.mk (cs ++ [c]) cs' rfl theorem utf8PrevAux_of_valid {cs cs' : List Char} {c : Char} {i p : Nat} (hp : i + (utf8Len cs + c.utf8Size) = p) : Pos.Raw.utf8PrevAux (cs ++ c :: cs') ⟨i⟩ ⟨p⟩ = ⟨i + utf8Len cs⟩ := by match cs with | [] => simp [Pos.Raw.utf8PrevAux, ← hp, Pos.Raw.add_char_eq] | c'::cs => simp only [Pos.Raw.utf8PrevAux, List.cons_append, utf8Len_cons, ← hp] rw [if_neg] case hnc => simp only [Pos.Raw.le_iff, Pos.Raw.byteIdx_add_char] grind [!Char.utf8Size_pos] refine (utf8PrevAux_of_valid (by simp [Nat.add_assoc, Nat.add_left_comm])).trans ?_ simp [Nat.add_assoc, Nat.add_comm] theorem prev_of_valid (cs : List Char) (c : Char) (cs' : List Char) : Pos.Raw.prev (ofList (cs ++ c :: cs')) ⟨utf8Len cs + c.utf8Size⟩ = ⟨utf8Len cs⟩ := by simp only [Pos.Raw.prev, String.toList_ofList] rw [utf8PrevAux_of_valid] <;> simp theorem prev_of_valid' (cs cs' : List Char) : Pos.Raw.prev (ofList (cs ++ cs')) ⟨utf8Len cs⟩ = ⟨utf8Len cs.dropLast⟩ := by match cs, cs.eq_nil_or_concat with | _, .inl rfl => apply Pos.Raw.prev_zero | _, .inr ⟨cs, c, rfl⟩ => simp [prev_of_valid, -ofList_append] theorem back_eq_get_prev_rawEndPos {s : String} : Legacy.back s = (s.rawEndPos.prev s).get s := rfl theorem atEnd_of_valid (cs : List Char) (cs' : List Char) : String.Pos.Raw.atEnd (ofList (cs ++ cs')) ⟨utf8Len cs⟩ ↔ cs' = [] := by rw [atEnd_iff] cases cs' <;> simp [rawEndPos, utf8ByteSize_ofList] exact Nat.add_pos_left (Char.utf8Size_pos _) _ unseal Legacy.posOfAux Legacy.findAux in theorem posOfAux_eq (s c) : Legacy.posOfAux s c = Legacy.findAux s (· == c) := (rfl) unseal Legacy.posOfAux Legacy.findAux in theorem posOf_eq (s c) : Legacy.posOf s c = Legacy.find s (· == c) := (rfl) unseal Legacy.revPosOfAux Legacy.revFindAux in theorem revPosOfAux_eq (s c) : Legacy.revPosOfAux s c = Legacy.revFindAux s (· == c) := (rfl) unseal Legacy.revPosOfAux Legacy.revFindAux in theorem revPosOf_eq (s c) : Legacy.revPosOf s c = Legacy.revFind s (· == c) := (rfl) @[nolint unusedHavesSuffices] -- false positive from unfolding String.findAux theorem findAux_of_valid (p) : ∀ l m r, Legacy.findAux (ofList (l ++ m ++ r)) p ⟨utf8Len l + utf8Len m⟩ ⟨utf8Len l⟩ = ⟨utf8Len l + utf8Len (m.takeWhile (!p ·))⟩ | l, [], r => by unfold Legacy.findAux List.takeWhile; simp | l, c::m, r => by unfold Legacy.findAux List.takeWhile rw [dif_pos (by exact Nat.lt_add_of_pos_right add_utf8Size_pos)] have h1 := get_of_valid l (c::m++r); have h2 := next_of_valid l c (m++r) simp only [List.cons_append, Char.reduceDefault, List.headD_cons] at h1 h2 simp only [List.append_assoc, List.cons_append, h1, utf8Len_cons, h2] cases p c · simp only [Bool.false_eq_true, ↓reduceIte, Bool.not_false, utf8Len_cons] have foo := findAux_of_valid p (l++[c]) m r simp only [List.append_assoc, List.cons_append, utf8Len_append, utf8Len_cons, utf8Len_nil, Nat.zero_add, List.nil_append] at foo rw [Nat.add_right_comm, Nat.add_assoc] at foo rw [foo, Nat.add_right_comm, Nat.add_assoc] · simp theorem find_of_valid (p s) : Legacy.find s p = ⟨utf8Len (s.toList.takeWhile (!p ·))⟩ := by simpa using findAux_of_valid p [] s.toList [] @[nolint unusedHavesSuffices] -- false positive from unfolding String.revFindAux theorem revFindAux_of_valid (p) : ∀ l r, Legacy.revFindAux (ofList (l.reverse ++ r)) p ⟨utf8Len l⟩ = (l.dropWhile (!p ·)).tail?.map (⟨utf8Len ·⟩) | [], r => by unfold Legacy.revFindAux List.dropWhile; simp | c::l, r => by unfold Legacy.revFindAux List.dropWhile rw [dif_neg (by exact Pos.Raw.ne_of_gt add_utf8Size_pos)] have h1 := get_of_valid l.reverse (c::r); have h2 := prev_of_valid l.reverse c r simp only [utf8Len_reverse, Char.reduceDefault, List.headD_cons] at h1 h2 simp only [List.reverse_cons, List.append_assoc, List.singleton_append, utf8Len_cons, h2, h1] cases p c <;> simp only [Bool.false_eq_true, ↓reduceIte, Bool.not_false, Bool.not_true, List.tail?_cons, Option.map_some] exact revFindAux_of_valid p l (c::r) theorem revFind_of_valid (p s) : Legacy.revFind s p = (s.toList.reverse.dropWhile (!p ·)).tail?.map (⟨utf8Len ·⟩) := by simpa using revFindAux_of_valid p s.toList.reverse [] theorem firstDiffPos_loop_eq (l₁ l₂ r₁ r₂ stop p) (hl₁ : p = utf8Len l₁) (hl₂ : p = utf8Len l₂) (hstop : stop = min (utf8Len l₁ + utf8Len r₁) (utf8Len l₂ + utf8Len r₂)) : firstDiffPos.loop (ofList (l₁ ++ r₁)) (ofList (l₂ ++ r₂)) ⟨stop⟩ ⟨p⟩ = ⟨p + utf8Len (List.takeWhile₂ (· = ·) r₁ r₂).1⟩ := by unfold List.takeWhile₂; split <;> unfold firstDiffPos.loop · next a r₁ b r₂ => rw [ dif_pos <| by rw [hstop, ← hl₁, ← hl₂] refine Nat.lt_min.2 ⟨?_, ?_⟩ <;> exact Nat.lt_add_of_pos_right add_utf8Size_pos, show Pos.Raw.get (ofList (l₁ ++ a :: r₁)) ⟨p⟩ = a by simp [hl₁, get_of_valid, -ofList_append], show Pos.Raw.get (ofList (l₂ ++ b :: r₂)) ⟨p⟩ = b by simp [hl₂, get_of_valid, -ofList_append]] simp only [bne_iff_ne, ne_eq, ite_not, decide_eq_true_eq] split · simp only [utf8Len_cons] subst b rw [show Pos.Raw.next (ofList (l₁ ++ a :: r₁)) ⟨p⟩ = ⟨utf8Len l₁ + a.utf8Size⟩ by simp [hl₁, -ofList_append, next_of_valid]] simpa [← hl₁, ← Nat.add_assoc, Nat.add_right_comm] using firstDiffPos_loop_eq (l₁ ++ [a]) (l₂ ++ [a]) r₁ r₂ stop (p + a.utf8Size) (by simp [hl₁]) (by simp [hl₂]) (by simp [hstop, ← Nat.add_assoc, Nat.add_right_comm]) · simp · next h => rw [dif_neg] <;> simp [hstop, ← hl₁, ← hl₂, -Nat.not_lt, Nat.lt_min] intro h₁ h₂ have : ∀ {cs}, 0 < utf8Len cs → cs ≠ [] := by rintro _ h rfl; simp at h obtain ⟨a, as, e₁⟩ := List.exists_cons_of_ne_nil (this h₁) obtain ⟨b, bs, e₂⟩ := List.exists_cons_of_ne_nil (this h₂) exact h _ _ _ _ e₁ e₂ theorem firstDiffPos_eq (a b : String) : firstDiffPos a b = ⟨utf8Len (List.takeWhile₂ (· = ·) a.toList b.toList).1⟩ := by simpa [firstDiffPos] using firstDiffPos_loop_eq [] [] a.toList b.toList ((utf8Len a.toList).min (utf8Len b.toList)) 0 rfl rfl (by simp) theorem Pos.Raw.extract.go₂_add_right_cancel (s : List Char) (i e n : Nat) : go₂ s ⟨i + n⟩ ⟨e + n⟩ = go₂ s ⟨i⟩ ⟨e⟩ := by apply utf8InductionOn s ⟨i⟩ ⟨e⟩ (motive := fun s i => go₂ s ⟨i.byteIdx + n⟩ ⟨e + n⟩ = go₂ s i ⟨e⟩) <;> simp only [ne_eq, go₂, Pos.Raw.byteIdx_add_char, implies_true, ↓reduceIte] intro c cs ⟨i⟩ h ih simp only [Pos.Raw.ext_iff, Pos.Raw.add_char_eq] at h ⊢ simp only [Nat.add_right_cancel_iff, h, ↓reduceIte, List.cons.injEq, true_and] rw [Nat.add_right_comm] exact ih theorem Pos.Raw.extract.go₂_append_left : ∀ (s t : List Char) (i e : Nat), e = utf8Len s + i → go₂ (s ++ t) ⟨i⟩ ⟨e⟩ = s | [], t, i, _, rfl => by cases t <;> simp [go₂] | c :: cs, t, i, _, rfl => by simp only [List.cons_append, utf8Len_cons, go₂, Pos.Raw.ext_iff, ne_add_utf8Size_add_self, ↓reduceIte, Pos.Raw.add_char_eq, List.cons.injEq, true_and] apply go₂_append_left; rw [Nat.add_right_comm, Nat.add_assoc] theorem Pos.Raw.extract.go₁_add_right_cancel (s : List Char) (i b e n : Nat) : go₁ s ⟨i + n⟩ ⟨b + n⟩ ⟨e + n⟩ = go₁ s ⟨i⟩ ⟨b⟩ ⟨e⟩ := by apply utf8InductionOn s ⟨i⟩ ⟨b⟩ (motive := fun s i => go₁ s ⟨i.byteIdx + n⟩ ⟨b + n⟩ ⟨e + n⟩ = go₁ s i ⟨b⟩ ⟨e⟩) <;> simp only [ne_eq, go₁, Pos.Raw.byteIdx_add_char, implies_true, ↓reduceIte] · intro c cs apply go₂_add_right_cancel · intro c cs ⟨i⟩ h ih simp only [Pos.Raw.ext_iff, Pos.Raw.add_char_eq] at h ih ⊢ simp only [Nat.add_right_cancel_iff, h, ↓reduceIte] rw [Nat.add_right_comm] exact ih theorem Pos.Raw.extract.go₁_cons_addChar (c : Char) (cs : List Char) (b e : Pos.Raw) : go₁ (c :: cs) 0 (b + c) (e + c) = go₁ cs 0 b e := by simp only [go₁, Pos.Raw.ext_iff, Pos.Raw.byteIdx_zero, byteIdx_add_char, Nat.ne_of_lt add_utf8Size_pos, ↓reduceIte] apply go₁_add_right_cancel theorem Pos.Raw.extract.go₁_append_right : ∀ (s t : List Char) (i b : Nat) (e : Pos.Raw), b = utf8Len s + i → go₁ (s ++ t) ⟨i⟩ ⟨b⟩ e = go₂ t ⟨b⟩ e | [], t, i, _, e, rfl => by cases t <;> simp [go₁, go₂] | c :: cs, t, i, _, e, rfl => by simp only [go₁, utf8Len_cons, Pos.Raw.ext_iff, ne_add_utf8Size_add_self, ↓reduceIte, List.cons_append, Pos.Raw.add_char_eq] apply go₁_append_right; rw [Nat.add_right_comm, Nat.add_assoc] theorem Pos.Raw.extract.go₁_zero_utf8Len (s : List Char) : go₁ s 0 0 ⟨utf8Len s⟩ = s := (go₁_append_right [] s 0 0 ⟨utf8Len s⟩ rfl).trans <| by simpa using go₂_append_left s [] 0 (utf8Len s) rfl theorem extract_cons_addChar (c : Char) (cs : List Char) (b e : Pos.Raw) : Pos.Raw.extract (ofList (c :: cs)) (b + c) (e + c) = Pos.Raw.extract (ofList cs) b e := by simp only [Pos.Raw.extract, Pos.Raw.byteIdx_add_char, ge_iff_le, Nat.add_le_add_iff_right] split <;> [rfl; simp [Pos.Raw.extract.go₁_cons_addChar]] theorem extract_zero_rawEndPos (s : String) : Pos.Raw.extract s 0 (rawEndPos s) = s := by obtain ⟨l, rfl⟩ := s.exists_eq_ofList match l with | [] => rfl | c :: cs => simp only [Pos.Raw.extract, Pos.Raw.byteIdx_zero, rawEndPos_ofList, utf8Len_cons, ge_iff_le, Nat.le_zero_eq, Nat.ne_of_gt add_utf8Size_pos, ↓reduceIte, String.toList_ofList] congr apply Pos.Raw.extract.go₁_zero_utf8Len @[deprecated extract_zero_rawEndPos (since := "2025-10-21")] theorem extract_zero_endPos (s : String) : Pos.Raw.extract s 0 (rawEndPos s) = s := extract_zero_rawEndPos s theorem extract_of_valid (l m r : List Char) : Pos.Raw.extract (ofList (l ++ m ++ r)) ⟨utf8Len l⟩ ⟨utf8Len l + utf8Len m⟩ = ofList m := by simp only [Pos.Raw.extract] split · next h => rw [utf8Len_eq_zero.1 <| Nat.le_zero.1 <| Nat.add_le_add_iff_left.1 h, ofList_nil] · congr rw [List.append_assoc, String.toList_ofList, Pos.Raw.extract.go₁_append_right _ _ _ _ _ (by rfl)] apply Pos.Raw.extract.go₂_append_left; apply Nat.add_comm theorem splitAux_of_valid (p l m r acc) : splitAux (ofList (l ++ m ++ r)) p ⟨utf8Len l⟩ ⟨utf8Len l + utf8Len m⟩ acc = acc.reverse ++ (List.splitOnPPrepend p r m.reverse).map ofList := by unfold splitAux simp only [List.append_assoc, atEnd_iff, rawEndPos_ofList, utf8Len_append, Pos.Raw.mk_le_mk, Nat.add_le_add_iff_left, (by omega : utf8Len m + utf8Len r ≤ utf8Len m ↔ utf8Len r = 0), utf8Len_eq_zero, List.reverse_cons, dite_eq_ite] split · subst r simpa using extract_of_valid l m [] · obtain ⟨c, r, rfl⟩ := r.exists_cons_of_ne_nil ‹_› simp only [by simpa [-ofList_append] using (⟨get_of_valid (l ++ m) (c :: r), next_of_valid (l ++ m) c r, extract_of_valid l m (c :: r)⟩ : _ ∧ _ ∧ _)] split <;> rename_i h · simpa [Nat.add_assoc, List.splitOnPPrepend_cons_eq_if, h] using splitAux_of_valid p (l++m++[c]) [] r ((ofList m)::acc) · simpa [List.splitOnPPrepend_cons_eq_if, h, Nat.add_assoc] using splitAux_of_valid p l (m++[c]) r acc theorem splitToList_of_valid (s p) : splitToList s p = (List.splitOnP p s.toList).map ofList := by simpa [splitToList] using splitAux_of_valid p [] [] s.toList [] @[deprecated splitToList_of_valid (since := "2025-10-18")] theorem split_of_valid (s p) : splitToList s p = (List.splitOnP p s.toList).map ofList := splitToList_of_valid s p -- TODO: splitOn @[simp] theorem toString_toSubstring (s : String) : s.toRawSubstring.toString = s := extract_zero_rawEndPos _ attribute [simp] toSubstring' theorem join_eq (ss : List String) : join ss = ofList (ss.map toList).flatten := by suffices ∀ (ss : List String) t, ss.foldl (· ++ ·) t = ofList (t.toList ++ (ss.map toList).flatten) by simpa [join] using this ss "" intro ss t induction ss generalizing t with | nil => simp | cons s ss ih => simp [ih] @[deprecated toList_join (since := "2025-10-31")] theorem data_join (ss : List String) : (join ss).toList = (ss.map toList).flatten := toList_join namespace Legacy.Iterator @[simp] theorem forward_eq_nextn : forward = nextn := by funext it n; induction n generalizing it <;> simp [forward, nextn, *] theorem hasNext_cons_addChar (c : Char) (cs : List Char) (i : Pos.Raw) : hasNext ⟨String.ofList (c :: cs), i + c⟩ = hasNext ⟨String.ofList cs, i⟩ := by simp [hasNext, utf8ByteSize_ofList]; lia /-- Validity for a string iterator. -/ def Valid (it : Iterator) : Prop := it.pos.Valid it.s /-- `it.ValidFor l r` means that `it` is a string iterator whose underlying string is `l.reverse ++ r`, and where the cursor is pointing at the end of `l.reverse`. -/ inductive ValidFor (l r : List Char) : Iterator → Prop /-- The canonical constructor for `ValidFor`. -/ | mk : ValidFor l r ⟨String.ofList (l.reverseAux r), ⟨utf8Len l⟩⟩ attribute [simp] toString pos namespace ValidFor theorem valid : ∀ {it}, ValidFor l r it → Valid it | _, ⟨⟩ => by simpa [List.reverseAux_eq] using Pos.Raw.Valid.mk l.reverse r rfl theorem out : ∀ {it}, ValidFor l r it → it = ⟨String.ofList (l.reverseAux r), ⟨utf8Len l⟩⟩ | _, ⟨⟩ => rfl theorem out' : ∀ {it}, ValidFor l r it → it = ⟨String.ofList (l.reverse ++ r), ⟨utf8Len l.reverse⟩⟩ | _, ⟨⟩ => by simp [List.reverseAux_eq] theorem mk' : ValidFor l r ⟨String.ofList (l.reverse ++ r), ⟨utf8Len l.reverse⟩⟩ := by simpa [List.reverseAux_eq] using mk theorem of_eq : ∀ it, it.1.toList = l.reverseAux r → it.2.1 = utf8Len l → ValidFor l r it | ⟨s, ⟨_⟩⟩, h, rfl => by rw [← s.ofList_toList, h] exact ⟨⟩ theorem _root_.String.validFor_mkIterator (s) : (mkIterator s).ValidFor [] s.toList := .of_eq _ (by simp [mkIterator]) (by simp [mkIterator]) theorem remainingBytes : ∀ {it}, ValidFor l r it → it.remainingBytes = utf8Len r | _, ⟨⟩ => by simp [Iterator.remainingBytes, Nat.add_sub_cancel_left, rawEndPos_ofList, -ofList_append] theorem toString : ∀ {it}, ValidFor l r it → it.1 = String.ofList (l.reverseAux r) | _, ⟨⟩ => rfl theorem pos : ∀ {it}, ValidFor l r it → it.2 = ⟨utf8Len l⟩ | _, ⟨⟩ => rfl theorem pos_eq_zero {l r it} (h : ValidFor l r it) : it.2 = 0 ↔ l = [] := by simp [h.pos, Pos.Raw.ext_iff] theorem pos_eq_rawEndPos {l r it} (h : ValidFor l r it) : it.2 = it.1.rawEndPos ↔ r = [] := by simp only [h.pos, h.toString, rawEndPos_ofList, utf8Len_reverseAux, Pos.Raw.ext_iff] exact (Nat.add_left_cancel_iff (m := 0)).trans <| eq_comm.trans utf8Len_eq_zero @[deprecated pos_eq_rawEndPos (since := "2025-10-21")] theorem pos_eq_endPos {l r it} (h : ValidFor l r it) : it.2 = it.1.rawEndPos ↔ r = [] := pos_eq_rawEndPos h theorem curr : ∀ {it}, ValidFor l r it → it.curr = r.headD default | it, h => by cases h.out'; apply get_of_valid theorem next : ∀ {it}, ValidFor l (c :: r) it → ValidFor (c :: l) r it.next | it, h => by cases h.out' simp only [Iterator.next, next_of_valid l.reverse c r] rw [← List.reverseAux_eq, utf8Len_reverse]; constructor theorem prev : ∀ {it}, ValidFor (c :: l) r it → ValidFor l (c :: r) it.prev | it, h => by cases h.out' have := prev_of_valid l.reverse c r simp only [utf8Len_reverse] at this simp only [Iterator.prev, List.reverse_cons, List.append_assoc, List.singleton_append, utf8Len_append, utf8Len_reverse, utf8Len_cons, utf8Len_nil, Nat.zero_add, this] exact .of_eq _ (by simp [List.reverseAux_eq]) (by simp) theorem prev_nil : ∀ {it}, ValidFor [] r it → ValidFor [] r it.prev | it, h => by simp only [Iterator.prev, h.toString, List.reverseAux_nil, h.pos, utf8Len_nil, Pos.Raw.mk_zero, Pos.Raw.prev_zero] constructor theorem atEnd : ∀ {it}, ValidFor l r it → (it.atEnd ↔ r = []) | it, h => by simp only [Iterator.atEnd, h.pos, h.toString, rawEndPos_ofList, utf8Len_reverseAux, ge_iff_le, decide_eq_true_eq] exact Nat.add_le_add_iff_left.trans <| Nat.le_zero.trans utf8Len_eq_zero theorem hasNext : ∀ {it}, ValidFor l r it → (it.hasNext ↔ r ≠ []) | it, h => by simp [Iterator.hasNext, ← h.atEnd, Iterator.atEnd] theorem hasPrev : ∀ {it}, ValidFor l r it → (it.hasPrev ↔ l ≠ []) | it, h => by simp [Iterator.hasPrev, h.pos, Nat.pos_iff_ne_zero] theorem setCurr' : ∀ {it}, ValidFor l r it → ValidFor l (r.modifyHead fun _ => c) (it.setCurr c) | it, h => by cases h.out' simp only [setCurr, utf8Len_reverse] refine .of_eq _ ?_ (by simp) have := set_of_valid l.reverse r c simp only [utf8Len_reverse] at this; simp [-ofList_append, List.reverseAux_eq, this] theorem setCurr (h : ValidFor l (c :: r) it) : ValidFor l (c :: r) (it.setCurr c) := h.setCurr' theorem toEnd (h : ValidFor l r it) : ValidFor (r.reverse ++ l) [] it.toEnd := by simp only [Iterator.toEnd, h.toString, rawEndPos_ofList, utf8Len_reverseAux] exact .of_eq _ (by simp [List.reverseAux_eq]) (by simp [Nat.add_comm]) theorem toEnd' (it : Iterator) : ValidFor it.s.toList.reverse [] it.toEnd := by simp only [Iterator.toEnd] exact .of_eq _ (by simp [List.reverseAux_eq]) (by simp [-size_toByteArray, rawEndPos, utf8ByteSize]) theorem extract (h₁ : ValidFor l (m ++ r) it₁) (h₂ : ValidFor (m.reverse ++ l) r it₂) : it₁.extract it₂ = String.ofList m := by cases h₁.out; cases h₂.out simp only [Iterator.extract, List.reverseAux_eq, List.reverse_append, List.reverse_reverse, List.append_assoc, ne_eq, not_true_eq_false, decide_false, utf8Len_append, utf8Len_reverse, gt_iff_lt, Pos.Raw.lt_iff, Nat.not_lt.2 (Nat.le_add_left ..), Bool.or_self, Bool.false_eq_true, ↓reduceIte] simpa [Nat.add_comm] using extract_of_valid l.reverse m r theorem remainingToString {it} (h : ValidFor l r it) : it.remainingToString = String.ofList r := by cases h.out simpa [rawEndPos_ofList, -ofList_append, Iterator.remainingToString, List.reverseAux_eq] using extract_of_valid l.reverse r [] theorem nextn : ∀ {it}, ValidFor l r it → ∀ n, n ≤ r.length → ValidFor ((r.take n).reverse ++ l) (r.drop n) (it.nextn n) | it, h, 0, _ => by simp [h, Iterator.nextn] | it, h, n+1, hn => by simp only [Iterator.nextn] have a::r := r simpa using h.next.nextn _ (Nat.le_of_succ_le_succ hn) theorem prevn : ∀ {it}, ValidFor l r it → ∀ n, n ≤ l.length → ValidFor (l.drop n) ((l.take n).reverse ++ r) (it.prevn n) | it, h, 0, _ => by simp [h, Iterator.prevn] | it, h, n+1, hn => by simp only [Iterator.prevn] have a::l := l simpa using h.prev.prevn _ (Nat.le_of_succ_le_succ hn) end ValidFor namespace Valid theorem validFor : ∀ {it}, Valid it → ∃ l r, ValidFor l r it | ⟨_, ⟨_⟩⟩, .mk l r rfl => ⟨l.reverse, r, by simpa [List.reverseAux_eq] using @ValidFor.mk l.reverse r⟩ theorem _root_.String.valid_mkIterator (s) : (mkIterator s).Valid := s.validFor_mkIterator.valid theorem remainingBytes_le : ∀ {it}, Valid it → it.remainingBytes ≤ utf8ByteSize it.s | _, h => let ⟨l, r, h⟩ := h.validFor by simp [utf8ByteSize_ofList, h.remainingBytes, h.toString, Nat.le_add_left] theorem next : ∀ {it}, Valid it → it.hasNext → Valid it.next | _, h, hn => by let ⟨l, r, h⟩ := h.validFor obtain ⟨c, r, rfl⟩ := List.exists_cons_of_ne_nil (h.hasNext.1 hn) exact h.next.valid theorem prev : ∀ {it}, Valid it → Valid it.prev | _, h => match h.validFor with | ⟨[], _, h⟩ => h.prev_nil.valid | ⟨_::_, _, h⟩ => h.prev.valid theorem setCurr : ∀ {it}, Valid it → Valid (it.setCurr c) | it, h => by let ⟨l, r, h⟩ := h.validFor exact h.setCurr'.valid theorem toEnd (it : String.Legacy.Iterator) : Valid it.toEnd := (ValidFor.toEnd' _).valid theorem remainingToString {it} (h : ValidFor l r it) : it.remainingToString = String.ofList r := by cases h.out simpa [-ofList_append, rawEndPos_ofList, Iterator.remainingToString, List.reverseAux_eq] using extract_of_valid l.reverse r [] theorem prevn (h : Valid it) : ∀ n, Valid (it.prevn n) | 0 => h | n+1 => h.prev.prevn n end Valid end Legacy.Iterator @[nolint unusedHavesSuffices] -- false positive from unfolding String.offsetOfPosAux theorem offsetOfPosAux_of_valid : ∀ l m r n, String.Pos.Raw.offsetOfPosAux (ofList (l ++ m ++ r)) ⟨utf8Len l + utf8Len m⟩ ⟨utf8Len l⟩ n = n + m.length | l, [], r, n => by unfold String.Pos.Raw.offsetOfPosAux; simp | l, c::m, r, n => by unfold String.Pos.Raw.offsetOfPosAux rw [if_neg (by exact Nat.not_le.2 (Nat.lt_add_of_pos_right add_utf8Size_pos))] simp only [List.append_assoc, atEnd_of_valid l (c::m++r)] simp only [List.cons_append, utf8Len_cons, next_of_valid l c (m ++ r)] simpa [← Nat.add_assoc, Nat.add_right_comm] using offsetOfPosAux_of_valid (l++[c]) m r (n + 1) theorem offsetOfPos_of_valid (l r) : String.Pos.Raw.offsetOfPos (ofList (l ++ r)) ⟨utf8Len l⟩ = l.length := by simpa using offsetOfPosAux_of_valid [] l r 0 @[nolint unusedHavesSuffices] -- false positive from unfolding String.Legacy.foldlAux theorem foldlAux_of_valid (f : α → Char → α) : ∀ l m r a, Legacy.foldlAux f (ofList (l ++ m ++ r)) ⟨utf8Len l + utf8Len m⟩ ⟨utf8Len l⟩ a = m.foldl f a | l, [], r, a => by unfold Legacy.foldlAux; simp | l, c::m, r, a => by unfold Legacy.foldlAux rw [dif_pos (by exact Nat.lt_add_of_pos_right add_utf8Size_pos)] simp only [List.append_assoc, List.cons_append, utf8Len_cons, next_of_valid l c (m ++ r), get_of_valid l (c :: (m ++ r)), Char.reduceDefault, List.headD_cons, List.foldl_cons] simpa [← Nat.add_assoc, Nat.add_right_comm] using foldlAux_of_valid f (l++[c]) m r (f a c) theorem foldl_eq (f : α → Char → α) (s a) : Legacy.foldl f a s = s.toList.foldl f a := by simpa using foldlAux_of_valid f [] s.toList [] a @[nolint unusedHavesSuffices] -- false positive from unfolding String.foldrAux theorem foldrAux_of_valid (f : Char → α → α) (l m r a) : Legacy.foldrAux f a (ofList (l ++ m ++ r)) ⟨utf8Len l + utf8Len m⟩ ⟨utf8Len l⟩ = m.foldr f a := by rw [← m.reverse_reverse] induction m.reverse generalizing r a with (unfold Legacy.foldrAux; simp) | cons c m IH => rw [if_pos add_utf8Size_pos] simp only [← Nat.add_assoc, by simpa using prev_of_valid (l ++ m.reverse) c r] simp only [by simpa using get_of_valid (l ++ m.reverse) (c :: r)] simpa using IH (c::r) (f c a) theorem foldr_eq (f : Char → α → α) (s a) : Legacy.foldr f a s = s.toList.foldr f a := by simpa using foldrAux_of_valid f [] s.toList [] a @[nolint unusedHavesSuffices] -- false positive from unfolding String.anyAux theorem anyAux_of_valid (p : Char → Bool) : ∀ l m r, Legacy.anyAux (ofList (l ++ m ++ r)) ⟨utf8Len l + utf8Len m⟩ p ⟨utf8Len l⟩ = m.any p | l, [], r => by unfold Legacy.anyAux; simp | l, c::m, r => by unfold Legacy.anyAux rw [dif_pos (by exact Nat.lt_add_of_pos_right add_utf8Size_pos)] simp only [List.append_assoc, List.cons_append, get_of_valid l (c :: (m ++ r)), Char.reduceDefault, List.headD_cons, utf8Len_cons, next_of_valid l c (m ++ r), Bool.if_true_left, Bool.decide_eq_true, List.any_cons] cases p c <;> simp simpa [← Nat.add_assoc, Nat.add_right_comm] using anyAux_of_valid p (l++[c]) m r theorem any_eq (s : String) (p : Char → Bool) : Legacy.any s p = s.toList.any p := by simpa using anyAux_of_valid p [] s.toList [] theorem any_iff (s : String) (p : Char → Bool) : Legacy.any s p ↔ ∃ c ∈ s.toList, p c := by simp [any_eq] theorem all_eq (s : String) (p : Char → Bool) : Legacy.all s p = s.toList.all p := by rw [Legacy.all, any_eq, List.all_eq_not_any_not] theorem all_iff (s : String) (p : Char → Bool) : Legacy.all s p ↔ ∀ c ∈ s.toList, p c := by simp [all_eq] theorem contains_iff (s : String) (c : Char) : Legacy.contains s c ↔ c ∈ s.toList := by simp [Legacy.contains, any_iff] @[nolint unusedHavesSuffices] -- false positive from unfolding String.mapAux theorem mapAux_of_valid (f : Char → Char) : ∀ l r, Legacy.mapAux f ⟨utf8Len l⟩ (ofList (l ++ r)) = ofList (l ++ r.map f) | l, [] => by unfold Legacy.mapAux; simp | l, c::r => by unfold Legacy.mapAux rw [dif_neg (by rw [atEnd_of_valid]; simp)] simp only [get_of_valid l (c :: r), Char.reduceDefault, List.headD_cons, set_of_valid l (c :: r), List.modifyHead_cons, next_of_valid l (f c) r, List.map_cons] simpa using mapAux_of_valid f (l++[f c]) r theorem map_eq (f : Char → Char) (s) : Legacy.map f s = ofList (s.toList.map f) := by simpa using mapAux_of_valid f [] s.toList -- TODO: substrEq -- TODO: isPrefixOf -- TODO: replace @[nolint unusedHavesSuffices] -- false positive from unfolding String.takeWhileAux theorem takeWhileAux_of_valid (p : Char → Bool) : ∀ l m r, Substring.Raw.takeWhileAux (ofList (l ++ m ++ r)) ⟨utf8Len l + utf8Len m⟩ p ⟨utf8Len l⟩ = ⟨utf8Len l + utf8Len (m.takeWhile p)⟩ | l, [], r => by unfold Substring.Raw.takeWhileAux List.takeWhile; simp | l, c::m, r => by unfold Substring.Raw.takeWhileAux List.takeWhile rw [dif_pos (by exact Nat.lt_add_of_pos_right add_utf8Size_pos)] simp only [List.append_assoc, List.cons_append, get_of_valid l (c :: (m ++ r)), Char.reduceDefault, List.headD_cons, utf8Len_cons, next_of_valid l c (m ++ r)] cases p c <;> simp simpa [← Nat.add_assoc, Nat.add_right_comm] using takeWhileAux_of_valid p (l++[c]) m r @[simp] theorem map_eq_empty_iff (s : String) (f : Char → Char) : (Legacy.map f s) = "" ↔ s = "" := by simp only [map_eq, ← toList_eq_nil_iff, toList_ofList, List.map_eq_nil_iff] @[simp] theorem map_isEmpty_eq_isEmpty (s : String) (f : Char → Char) : (Legacy.map f s).isEmpty = s.isEmpty := by rw [Bool.eq_iff_iff]; simp [isEmpty_iff, map_eq_empty_iff] @[simp] theorem Legacy.length_map (s : String) (f : Char → Char) : (Legacy.map f s).length = s.length := by simp only [← length_toList, map_eq, String.toList_ofList, List.length_map] theorem Legacy.length_eq_of_map_eq {a b : String} {f g : Char → Char} : Legacy.map f a = Legacy.map g b → a.length = b.length := by intro h; rw [← length_map a f, ← length_map b g, h] theorem length_eq_of_map_eq {a b : String} {f g : Char → Char} : map f a = map g b → a.length = b.length := by intro h; rw [← @length_map f a, ← @length_map g b, h] end String open String namespace Substring.Raw /-- Validity for a substring. -/ structure Valid (s : Substring.Raw) : Prop where /-- The start position of a valid substring is valid. -/ startValid : s.startPos.Valid s.str /-- The stop position of a valid substring is valid. -/ stopValid : s.stopPos.Valid s.str /-- The stop position of a substring is at least the start. -/ le : s.startPos ≤ s.stopPos theorem Valid_default : Valid default := ⟨Pos.Raw.valid_zero, Pos.Raw.valid_zero, Nat.le_refl _⟩ /-- A substring is represented by three lists `l m r`, where `m` is the middle section (the actual substring) and `l ++ m ++ r` is the underlying string. -/ inductive ValidFor (l m r : List Char) : Substring.Raw → Prop /-- The constructor for `ValidFor`. -/ | mk : ValidFor l m r ⟨String.ofList (l ++ m ++ r), ⟨utf8Len l⟩, ⟨utf8Len l + utf8Len m⟩⟩ namespace ValidFor theorem valid : ∀ {s}, ValidFor l m r s → Valid s | _, ⟨⟩ => ⟨.intro ⟨l, m ++ r, by simp⟩, .intro ⟨l ++ m, r, by simp⟩, Nat.le_add_right ..⟩ theorem of_eq : ∀ s, s.str.toList = l ++ m ++ r → s.startPos.1 = utf8Len l → s.stopPos.1 = utf8Len l + utf8Len m → ValidFor l m r s | ⟨s, ⟨_⟩, ⟨_⟩⟩, h, rfl, rfl => by rw [← s.ofList_toList, h] exact ⟨⟩ theorem _root_.String.validFor_toSubstring (s : String) : ValidFor [] s.toList [] s := .of_eq _ (by simp [toRawSubstring]) rfl (by simp [toRawSubstring, rawEndPos]) theorem str : ∀ {s}, ValidFor l m r s → s.str = String.ofList (l ++ m ++ r) | _, ⟨⟩ => rfl theorem startPos : ∀ {s}, ValidFor l m r s → s.startPos = ⟨utf8Len l⟩ | _, ⟨⟩ => rfl theorem stopPos : ∀ {s}, ValidFor l m r s → s.stopPos = ⟨utf8Len l + utf8Len m⟩ | _, ⟨⟩ => rfl theorem bsize : ∀ {s}, ValidFor l m r s → s.bsize = utf8Len m | _, ⟨⟩ => by simp [Substring.Raw.bsize, Nat.add_sub_cancel_left] theorem isEmpty : ∀ {s}, ValidFor l m r s → (s.isEmpty ↔ m = []) | _, h => by simp [Substring.Raw.isEmpty, h.bsize] theorem toString : ∀ {s}, ValidFor l m r s → s.toString = String.ofList m | _, ⟨⟩ => extract_of_valid l m r theorem toIterator : ∀ {s}, ValidFor l m r s → s.toLegacyIterator.ValidFor l.reverse (m ++ r) | _, h => by simp only [Substring.Raw.toLegacyIterator] exact .of_eq _ (by simp [h.str, List.reverseAux_eq]) (by simp [h.startPos]) theorem get : ∀ {s}, ValidFor l (m₁ ++ c :: m₂) r s → s.get ⟨utf8Len m₁⟩ = c | _, ⟨⟩ => by simpa using get_of_valid (l ++ m₁) (c :: m₂ ++ r) theorem next : ∀ {s}, ValidFor l (m₁ ++ c :: m₂) r s → s.next ⟨utf8Len m₁⟩ = ⟨utf8Len m₁ + c.utf8Size⟩ | _, ⟨⟩ => by simp only [Substring.Raw.next, utf8Len_append, utf8Len_cons, List.append_assoc, List.cons_append] rw [if_neg (mt Pos.Raw.ext_iff.1 ?a)] case a => simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using @ne_add_utf8Size_add_self (utf8Len l + utf8Len m₁) (utf8Len m₂) c have := next_of_valid (l ++ m₁) c (m₂ ++ r) simp only [List.append_assoc, utf8Len_append, Pos.Raw.offsetBy_eq] at this ⊢; rw [this] simp [Nat.add_assoc, Nat.add_sub_cancel_left] theorem next_stop : ∀ {s}, ValidFor l m r s → s.next ⟨utf8Len m⟩ = ⟨utf8Len m⟩ | _, ⟨⟩ => by simp [Substring.Raw.next, Pos.Raw.offsetBy_eq] theorem prev : ∀ {s}, ValidFor l (m₁ ++ c :: m₂) r s → s.prev ⟨utf8Len m₁ + c.utf8Size⟩ = ⟨utf8Len m₁⟩ | _, ⟨⟩ => by simp only [Substring.Raw.prev, List.append_assoc, List.cons_append] rw [if_neg (mt Pos.Raw.ext_iff.1 <| Ne.symm ?a)] case a => simpa [Nat.add_comm] using @ne_add_utf8Size_add_self (utf8Len l) (utf8Len m₁) c have := prev_of_valid (l ++ m₁) c (m₂ ++ r) simp only [List.append_assoc, utf8Len_append, Nat.add_assoc, Pos.Raw.offsetBy_eq] at this ⊢; rw [this] simp [Nat.add_sub_cancel_left] theorem nextn_stop : ∀ {s}, ValidFor l m r s → ∀ n, s.nextn n ⟨utf8Len m⟩ = ⟨utf8Len m⟩ | _, _, 0 => rfl | _, h, n+1 => by simp [Substring.Raw.nextn, h.next_stop, h.nextn_stop n] theorem nextn : ∀ {s}, ValidFor l (m₁ ++ m₂) r s → ∀ n, s.nextn n ⟨utf8Len m₁⟩ = ⟨utf8Len m₁ + utf8Len (m₂.take n)⟩ | _, _, 0 => by simp [Substring.Raw.nextn] | s, h, n+1 => by simp only [Substring.Raw.nextn] match m₂ with | [] => simp at h; simp [h.next_stop, h.nextn_stop] | c::m₂ => rw [h.next] have := @nextn l (m₁ ++ [c]) m₂ r s (by simp [h]) n simp at this; rw [this]; simp [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] theorem prevn : ∀ {s}, ValidFor l (m₁.reverse ++ m₂) r s → ∀ n, s.prevn n ⟨utf8Len m₁⟩ = ⟨utf8Len (m₁.drop n)⟩ | _, _, 0 => by simp [Substring.Raw.prevn] | s, h, n+1 => by simp only [Substring.Raw.prevn] match m₁ with | [] => simp | c::m₁ => rw [List.reverse_cons, List.append_assoc] at h have := h.prev; simp at this; simp [this, h.prevn n] theorem front : ∀ {s}, ValidFor l (c :: m) r s → s.front = c | _, h => h.get (m₁ := []) theorem drop : ∀ {s}, ValidFor l m r s → ∀ n, ValidFor (l ++ m.take n) (m.drop n) r (s.drop n) | s, h, n => by have : Substring.Raw.nextn {..} .. = _ := h.nextn (m₁ := []) n simp only [utf8Len_nil, Pos.Raw.mk_zero, Nat.zero_add] at this simp only [Substring.Raw.drop, this] simp only [h.str, List.append_assoc, h.startPos, h.stopPos] rw [← List.take_append_drop n m] at h refine .of_eq _ (by simp) (by simp) ?_ conv => lhs; rw [← List.take_append_drop n m] simp [-List.take_append_drop, Nat.add_assoc] theorem take : ∀ {s}, ValidFor l m r s → ∀ n, ValidFor l (m.take n) (m.drop n ++ r) (s.take n) | s, h, n => by have : Substring.Raw.nextn {..} .. = _ := h.nextn (m₁ := []) n simp at this simp only [Substring.Raw.take, this] simp only [h.str, List.append_assoc, h.startPos] rw [← List.take_append_drop n m] at h refine .of_eq _ ?_ (by simp) (by simp) conv => lhs; rw [← List.take_append_drop n m] simp [-List.take_append_drop] -- TODO: takeRight, dropRight theorem atEnd : ∀ {s}, ValidFor l m r s → (s.atEnd ⟨p⟩ ↔ p = utf8Len m) | _, ⟨⟩ => by simp [Substring.Raw.atEnd, Pos.Raw.ext_iff, Nat.add_left_cancel_iff] theorem extract' : ∀ {s}, ValidFor l (ml ++ mm ++ mr) r s → ValidFor ml mm mr ⟨String.ofList (ml ++ mm ++ mr), b, e⟩ → ∃ l' r', ValidFor l' mm r' (s.extract b e) | _, ⟨⟩, ⟨⟩ => by simp only [Substring.Raw.extract, ge_iff_le, Pos.Raw.mk_le_mk, List.append_assoc, utf8Len_append] split · next h => rw [utf8Len_eq_zero.1 <| Nat.le_zero.1 <| Nat.add_le_add_iff_left.1 h] exact ⟨[], [], ⟨⟩⟩ · next h => refine ⟨l ++ ml, mr ++ r, .of_eq _ (by simp) ?_ ?_⟩ <;> simp only [Pos.Raw.byteIdx_offsetBy, Nat.min_eq_min, utf8Len_append] <;> rw [Nat.min_eq_right] <;> try simp [Nat.add_le_add_iff_left, Nat.le_add_right] rw [Nat.add_assoc] theorem extract : ∀ {s}, ValidFor l m r s → ValidFor ml mm mr ⟨String.ofList m, b, e⟩ → ∃ l' r', ValidFor l' mm r' (s.extract b e) := by intro s h₁ h₂ obtain rfl : m = ml ++ mm ++ mr := by simpa using congrArg String.toList h₂.str exact extract' h₁ h₂ -- TODO: splitOn theorem foldl (f) (init : α) : ∀ {s}, ValidFor l m r s → Legacy.foldl f init s = m.foldl f init | _, ⟨⟩ => by simp [-ofList_append, -List.append_assoc, Substring.Raw.Legacy.foldl, foldlAux_of_valid] theorem foldr (f) (init : α) : ∀ {s}, ValidFor l m r s → Legacy.foldr f init s = m.foldr f init | _, ⟨⟩ => by simp [-ofList_append, -List.append_assoc, Substring.Raw.Legacy.foldr, foldrAux_of_valid] theorem any (f) : ∀ {s}, ValidFor l m r s → Legacy.any s f = m.any f | _, ⟨⟩ => by simp [-ofList_append, -List.append_assoc, Legacy.any, anyAux_of_valid] theorem all (f) : ∀ {s}, ValidFor l m r s → Legacy.all s f = m.all f | _, h => by simp [Legacy.all, h.any, List.all_eq_not_any_not] theorem contains (c) : ∀ {s}, ValidFor l m r s → (Legacy.contains s c ↔ c ∈ m) | _, h => by simp [Legacy.contains, h.any] theorem takeWhile (p : Char → Bool) : ∀ {s}, ValidFor l m r s → ValidFor l (m.takeWhile p) (m.dropWhile p ++ r) (s.takeWhile p) | _, ⟨⟩ => by simp only [Substring.Raw.takeWhile, takeWhileAux_of_valid] apply ValidFor.of_eq <;> simp rw [← List.append_assoc, List.takeWhile_append_dropWhile] theorem dropWhile (p : Char → Bool) : ∀ {s}, ValidFor l m r s → ValidFor (l ++ m.takeWhile p) (m.dropWhile p) r (s.dropWhile p) | _, ⟨⟩ => by simp only [Substring.Raw.dropWhile, takeWhileAux_of_valid] apply ValidFor.of_eq <;> simp rw [Nat.add_assoc, ← utf8Len_append (m.takeWhile p), List.takeWhile_append_dropWhile] -- TODO: takeRightWhile end ValidFor namespace Valid theorem validFor : ∀ {s}, Valid s → ∃ l m r, ValidFor l m r s | ⟨_, ⟨_⟩, ⟨_⟩⟩, ⟨.mk l mr rfl, t, h⟩ => by obtain ⟨lm, r, h₁, h₂⟩ := t.exists have e : lm ++ r = l ++ mr := by simpa [← String.ofList_inj, ← String.toByteArray_inj] using h₁ obtain rfl := Pos.Raw.ext_iff.1 h₂ simp only [Pos.Raw.mk_le_mk] at * have := (or_iff_right_iff_imp.2 fun h => ?x).1 (List.append_eq_append_iff.1 e) case x => match l, r, h with | _, _, ⟨m, rfl, rfl⟩ => ?_ simp only [utf8Len_append] at h cases utf8Len_eq_zero.1 <| Nat.le_zero.1 (Nat.le_of_add_le_add_left (c := 0) h) exact ⟨[], by simp⟩ match lm, mr, this with | _, _, ⟨m, rfl, rfl⟩ => exact ⟨l, m, r, by simpa using ValidFor.mk⟩ theorem valid : ∀ {s}, ValidFor l m r s → Valid s | _, ⟨⟩ => ⟨.intro ⟨l, m ++ r, by simp, by simp⟩, .intro ⟨l ++ m, r, by simp, by simp⟩, Nat.le_add_right ..⟩ theorem _root_.String.valid_toSubstring (s : String) : Valid s := s.validFor_toSubstring.valid theorem bsize : ∀ {s}, Valid s → s.bsize = utf8Len s.toString.toList | _, h => let ⟨l, m, r, h⟩ := h.validFor; by simp [h.bsize, h.toString] theorem isEmpty : ∀ {s}, Valid s → (s.isEmpty ↔ s.toString = "") | _, h => let ⟨l, m, r, h⟩ := h.validFor; by simp [h.isEmpty, h.toString, String.ext_iff] theorem get : ∀ {s}, Valid s → s.toString.toList = m₁ ++ c :: m₂ → s.get ⟨utf8Len m₁⟩ = c | _, h, e => by let ⟨l, m, r, h⟩ := h.validFor simp only [h.toString, String.toList_ofList] at e; subst e; simp [h.get] theorem next : ∀ {s}, Valid s → s.toString.toList = m₁ ++ c :: m₂ → s.next ⟨utf8Len m₁⟩ = ⟨utf8Len m₁ + c.utf8Size⟩ | _, h, e => by let ⟨l, m, r, h⟩ := h.validFor simp only [h.toString, String.toList_ofList] at e; subst e; simp [h.next] theorem next_stop : ∀ {s}, Valid s → s.next ⟨s.bsize⟩ = ⟨s.bsize⟩ | _, h => let ⟨l, m, r, h⟩ := h.validFor; by simp [h.bsize, h.next_stop] theorem prev : ∀ {s}, Valid s → s.toString.toList = m₁ ++ c :: m₂ → s.prev ⟨utf8Len m₁ + c.utf8Size⟩ = ⟨utf8Len m₁⟩ | _, h, e => by let ⟨l, m, r, h⟩ := h.validFor simp only [h.toString, String.toList_ofList] at e; subst e; simp [h.prev] theorem nextn_stop : ∀ {s}, Valid s → ∀ n, s.nextn n ⟨s.bsize⟩ = ⟨s.bsize⟩ | _, h, n => let ⟨l, m, r, h⟩ := h.validFor; by simp [h.bsize, h.nextn_stop] theorem nextn : ∀ {s}, Valid s → s.toString.toList = m₁ ++ m₂ → ∀ n, s.nextn n ⟨utf8Len m₁⟩ = ⟨utf8Len m₁ + utf8Len (m₂.take n)⟩ | _, h, e => by let ⟨l, m, r, h⟩ := h.validFor simp only [h.toString, String.toList_ofList] at e; subst e; simp [h.nextn] theorem prevn : ∀ {s}, Valid s → s.toString.toList = m₁.reverse ++ m₂ → ∀ n, s.prevn n ⟨utf8Len m₁⟩ = ⟨utf8Len (m₁.drop n)⟩ | _, h, e => by let ⟨l, m, r, h⟩ := h.validFor simp only [h.toString, String.toList_ofList] at e; subst e; simp [h.prevn] theorem front : ∀ {s}, Valid s → s.toString.toList = c :: m → s.front = c | _, h => h.get (m₁ := []) theorem drop : ∀ {s}, Valid s → ∀ n, Valid (s.drop n) | _, h, _ => let ⟨_, _, _, h⟩ := h.validFor; (h.drop _).valid theorem data_drop : ∀ {s}, Valid s → ∀ n, (s.drop n).toString.toList = s.toString.toList.drop n | _, h, _ => let ⟨_, _, _, h⟩ := h.validFor; by simp [(h.drop _).toString, h.toString] theorem take : ∀ {s}, Valid s → ∀ n, Valid (s.take n) | _, h, _ => let ⟨_, _, _, h⟩ := h.validFor; (h.take _).valid theorem data_take : ∀ {s}, Valid s → ∀ n, (s.take n).toString.toList = s.toString.toList.take n | _, h, _ => let ⟨_, _, _, h⟩ := h.validFor; by simp [(h.take _).toString, h.toString] -- TODO: takeRight, dropRight theorem atEnd : ∀ {s}, Valid s → (s.atEnd ⟨p⟩ ↔ p = utf8ByteSize s.toString) | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [utf8ByteSize_ofList, h.atEnd, h.toString] theorem extract : ∀ {s}, Valid s → Valid ⟨s.toString, b, e⟩ → Valid (s.extract b e) | _, h₁, h₂ => by let ⟨l, m, r, h₁⟩ := h₁.validFor rw [h₁.toString] at h₂ let ⟨ml, mm, mr, h₂⟩ := h₂.validFor have ⟨l', r', h₃⟩ := h₁.extract h₂ exact h₃.valid theorem toString_extract : ∀ {s}, Valid s → Valid ⟨s.toString, b, e⟩ → (s.extract b e).toString = String.Pos.Raw.extract s.toString b e | _, h₁, h₂ => by let ⟨l, m, r, h₁⟩ := h₁.validFor rw [h₁.toString] at h₂ let ⟨ml, mm, mr, h₂⟩ := h₂.validFor have ⟨l', r', h₃⟩ := h₁.extract h₂ rw [h₃.toString, h₁.toString, ← h₂.toString, toString] theorem foldl (f) (init : α) : ∀ {s}, Valid s → Legacy.foldl f init s = s.toString.toList.foldl f init | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [h.foldl, h.toString] theorem foldr (f) (init : α) : ∀ {s}, Valid s → Legacy.foldr f init s = s.toString.toList.foldr f init | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [h.foldr, h.toString] theorem any (f) : ∀ {s}, Valid s → Legacy.any s f = s.toString.toList.any f | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [h.any, h.toString] theorem all (f) : ∀ {s}, Valid s → Legacy.all s f = s.toString.toList.all f | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [h.all, h.toString] theorem contains (c) : ∀ {s}, Valid s → (Legacy.contains s c ↔ c ∈ s.toString.toList) | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [h.contains, h.toString] theorem takeWhile (p : Char → Bool) : ∀ {s}, Valid s → Valid (s.takeWhile p) | _, h => let ⟨_, _, _, h⟩ := h.validFor; (h.takeWhile _).valid theorem data_takeWhile (p) : ∀ {s}, Valid s → (s.takeWhile p).toString.toList = s.toString.toList.takeWhile p | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [(h.takeWhile _).toString, h.toString] theorem dropWhile (p : Char → Bool) : ∀ {s}, Valid s → Valid (s.dropWhile p) | _, h => let ⟨_, _, _, h⟩ := h.validFor; (h.dropWhile _).valid theorem data_dropWhile (p) : ∀ {s}, Valid s → (s.dropWhile p).toString.toList = s.toString.toList.dropWhile p | _, h => let ⟨_, _, _, h⟩ := h.validFor; by simp [(h.dropWhile _).toString, h.toString] -- TODO: takeRightWhile end Valid end Substring.Raw namespace String theorem drop_eq (s : String) (n : Nat) : Legacy.drop s n = ofList (s.toList.drop n) := (s.validFor_toSubstring.drop n).toString @[simp] theorem toList_drop (s : String) (n : Nat) : (Legacy.drop s n).toList = s.toList.drop n := by simp [drop_eq] @[simp] theorem drop_empty {n : Nat} : Legacy.drop "" n = "" := by simp [drop_eq, List.drop_nil] theorem take_eq (s : String) (n : Nat) : Legacy.take s n = ofList (s.toList.take n) := (s.validFor_toSubstring.take n).toString @[simp] theorem toList_take (s : String) (n : Nat) : (Legacy.take s n).toList = s.toList.take n := by simp [take_eq] theorem takeWhile_eq (p : Char → Bool) (s : String) : Legacy.takeWhile s p = ofList (s.toList.takeWhile p) := (s.validFor_toSubstring.takeWhile p).toString @[simp] theorem toList_takeWhile (p : Char → Bool) (s : String) : (Legacy.takeWhile s p).toList = s.toList.takeWhile p := by simp [takeWhile_eq] theorem dropWhile_eq (p : Char → Bool) (s : String) : Legacy.dropWhile s p = ofList (s.toList.dropWhile p) := (s.validFor_toSubstring.dropWhile p).toString @[simp] theorem toList_dropWhile (p : Char → Bool) (s : String) : (Legacy.dropWhile s p).toList = s.toList.dropWhile p := by simp [dropWhile_eq] end String ================================================ FILE: Batteries/Data/String/Matcher.lean ================================================ /- Copyright (c) 2023 F. G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: F. G. Dorais -/ module public import Batteries.Data.Array.Match public import Batteries.Data.String.Basic @[expose] public section namespace String /-- Knuth-Morris-Pratt matcher type This type is used to keep data for running the Knuth-Morris-Pratt (KMP) string matching algorithm. KMP is a linear time algorithm to locate all substrings of a string that match a given pattern. Generating the algorithm data is also linear in the length of the pattern but the data can be re-used to match the same pattern over different strings. The KMP data for a pattern string can be generated using `Matcher.ofString`. Then `Matcher.find?` and `Matcher.findAll` can be used to run the algorithm on an input string. ``` def m := Matcher.ofString "abba" #eval Option.isSome <| m.find? "AbbabbA" -- false #eval Option.isSome <| m.find? "aabbaa" -- true #eval Array.size <| m.findAll "abbabba" -- 2 #eval Array.size <| m.findAll "abbabbabba" -- 3 ``` -/ structure Matcher extends Array.Matcher Char where /-- The pattern for the matcher -/ pattern : Substring.Raw /-- Make KMP matcher from pattern substring -/ @[inline] def Matcher.ofSubstring (pattern : Substring.Raw) : Matcher where toMatcher := Array.Matcher.ofStream pattern pattern := pattern /-- Make KMP matcher from pattern string -/ @[inline] def Matcher.ofString (pattern : String) : Matcher := Matcher.ofSubstring pattern /-- The byte size of the string pattern for the matcher -/ abbrev Matcher.patternSize (m : Matcher) : Nat := m.pattern.bsize /-- Find all substrings of `s` matching `m.pattern`. -/ partial def Matcher.findAll (m : Matcher) (s : Substring.Raw) : Array Substring.Raw := loop s m.toMatcher #[] where /-- Accumulator loop for `String.Matcher.findAll` -/ loop (s : Substring.Raw) (am : Array.Matcher Char) (occs : Array Substring.Raw) : Array Substring.Raw := match am.next? s with | none => occs | some (s, am) => loop s am <| occs.push { s with startPos := ⟨s.startPos.byteIdx - m.patternSize⟩ stopPos := s.startPos } /-- Find the first substring of `s` matching `m.pattern`, or `none` if no such substring exists. -/ def Matcher.find? (m : Matcher) (s : Substring.Raw) : Option Substring.Raw := match m.next? s with | none => none | some (s, _) => some { s with startPos := ⟨s.startPos.byteIdx - m.patternSize⟩ stopPos := s.startPos } end String namespace Substring.Raw /-- Returns all the substrings of `s` that match `pattern`. -/ @[inline] def findAllSubstr (s pattern : Substring.Raw) : Array Substring.Raw := (String.Matcher.ofSubstring pattern).findAll s /-- Returns the first substring of `s` that matches `pattern`, or `none` if there is no such substring. -/ @[inline] def findSubstr? (s pattern : Substring.Raw) : Option Substring.Raw := (String.Matcher.ofSubstring pattern).find? s /-- Returns true iff `pattern` occurs as a substring of `s`. -/ @[inline] def containsSubstr (s pattern : Substring.Raw) : Bool := s.findSubstr? pattern |>.isSome end Substring.Raw section Deprecations @[deprecated Substring.Raw.findAllSubstr (since := "2025-11-16"), inherit_doc Substring.Raw.findAllSubstr] abbrev Substring.findAllSubstr := Substring.Raw.findAllSubstr @[deprecated Substring.Raw.findSubstr? (since := "2025-11-16"), inherit_doc Substring.Raw.findSubstr?] abbrev Substring.findSubstr? := Substring.Raw.findSubstr? @[deprecated Substring.Raw.containsSubstr (since := "2025-11-16"), inherit_doc Substring.Raw.containsSubstr] abbrev Substring.containsSubstr := Substring.Raw.containsSubstr end Deprecations namespace String @[inherit_doc Substring.Raw.findAllSubstr] abbrev findAllSubstr (s : String) (pattern : Substring.Raw) : Array Substring.Raw := (String.Matcher.ofSubstring pattern).findAll s @[inherit_doc Substring.Raw.findSubstr?] abbrev findSubstr? (s : String) (pattern : Substring.Raw) : Option Substring.Raw := s.toRawSubstring.findSubstr? pattern @[deprecated String.contains (since := "2026-02-25"), inherit_doc Substring.Raw.containsSubstr] abbrev containsSubstr (s : String) (pattern : Substring.Raw) : Bool := s.toRawSubstring.containsSubstr pattern end String ================================================ FILE: Batteries/Data/String.lean ================================================ module public import Batteries.Data.String.AsciiCasing public import Batteries.Data.String.Basic public import Batteries.Data.String.Legacy public import Batteries.Data.String.Lemmas public import Batteries.Data.String.Matcher ================================================ FILE: Batteries/Data/UInt.lean ================================================ /- Copyright (c) 2023 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais, Mario Carneiro -/ module public import Batteries.Classes.Order @[expose] public section /-! ### UInt8 -/ @[ext] theorem UInt8.ext : {x y : UInt8} → x.toNat = y.toNat → x = y | ⟨⟨_,_⟩⟩, ⟨⟨_,_⟩⟩, rfl => rfl @[simp] theorem UInt8.toUInt16_toNat (x : UInt8) : x.toUInt16.toNat = x.toNat := rfl @[simp] theorem UInt8.toUInt32_toNat (x : UInt8) : x.toUInt32.toNat = x.toNat := rfl @[simp] theorem UInt8.toUInt64_toNat (x : UInt8) : x.toUInt64.toNat = x.toNat := rfl instance : Std.LawfulOrd UInt8 := Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt UInt8.le_antisymm theorem UInt8.le_iff_toNat_le_toNat {x y : UInt8} : x ≤ y ↔ x.toNat ≤ y.toNat := .rfl theorem UInt8.lt_iff_toNat_lt_toNat {x y : UInt8} : x < y ↔ x.toNat < y.toNat := .rfl theorem UInt8.compare_eq_toNat_compare_toNat (x y : UInt8) : compare x y = compare x.toNat y.toNat := by simp only [compare, compareOfLessAndEq, lt_iff_toNat_lt_toNat, UInt8.ext_iff] theorem UInt8.max_def (x y : UInt8) : max x y = if x ≤ y then y else x := rfl theorem UInt8.min_def (x y : UInt8) : min x y = if x ≤ y then x else y := rfl theorem UInt8.toNat_max (x y : UInt8) : (max x y).toNat = max x.toNat y.toNat := by rw [max_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_right h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_left (Nat.le_of_not_ge h)] theorem UInt8.toNat_min (x y : UInt8) : (min x y).toNat = min x.toNat y.toNat := by rw [min_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_left h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_right (Nat.le_of_not_ge h)] /-! ### UInt16 -/ @[ext] theorem UInt16.ext : {x y : UInt16} → x.toNat = y.toNat → x = y | ⟨⟨_,_⟩⟩, ⟨⟨_,_⟩⟩, rfl => rfl @[simp] theorem UInt16.toUInt8_toNat (x : UInt16) : x.toUInt8.toNat = x.toNat % 2 ^ 8 := rfl @[simp] theorem UInt16.toUInt32_toNat (x : UInt16) : x.toUInt32.toNat = x.toNat := rfl @[simp] theorem UInt16.toUInt64_toNat (x : UInt16) : x.toUInt64.toNat = x.toNat := rfl instance : Std.LawfulOrd UInt16 := Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt UInt16.le_antisymm theorem UInt16.le_iff_toNat_le_toNat {x y : UInt16} : x ≤ y ↔ x.toNat ≤ y.toNat := .rfl theorem UInt16.lt_iff_toNat_lt_toNat {x y : UInt16} : x < y ↔ x.toNat < y.toNat := .rfl theorem UInt16.compare_eq_toNat_compare_toNat (x y : UInt16) : compare x y = compare x.toNat y.toNat := by simp only [compare, compareOfLessAndEq, lt_iff_toNat_lt_toNat, UInt16.ext_iff] theorem UInt16.max_def (x y : UInt16) : max x y = if x ≤ y then y else x := rfl theorem UInt16.min_def (x y : UInt16) : min x y = if x ≤ y then x else y := rfl theorem UInt16.toNat_max (x y : UInt16) : (max x y).toNat = max x.toNat y.toNat := by rw [max_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_right h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_left (Nat.le_of_not_ge h)] theorem UInt16.toNat_min (x y : UInt16) : (min x y).toNat = min x.toNat y.toNat := by rw [min_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_left h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_right (Nat.le_of_not_ge h)] /-! ### UInt32 -/ @[ext] theorem UInt32.ext : {x y : UInt32} → x.toNat = y.toNat → x = y | ⟨⟨_,_⟩⟩, ⟨⟨_,_⟩⟩, rfl => rfl @[simp] theorem UInt32.toUInt8_toNat (x : UInt32) : x.toUInt8.toNat = x.toNat % 2 ^ 8 := rfl @[simp] theorem UInt32.toUInt16_toNat (x : UInt32) : x.toUInt16.toNat = x.toNat % 2 ^ 16 := rfl @[simp] theorem UInt32.toUInt64_toNat (x : UInt32) : x.toUInt64.toNat = x.toNat := rfl instance : Std.LawfulOrd UInt32 := Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt UInt32.le_antisymm theorem UInt32.le_iff_toNat_le_toNat {x y : UInt32} : x ≤ y ↔ x.toNat ≤ y.toNat := .rfl theorem UInt32.lt_iff_toNat_lt_toNat {x y : UInt32} : x < y ↔ x.toNat < y.toNat := .rfl theorem UInt32.compare_eq_toNat_compare_toNat (x y : UInt32) : compare x y = compare x.toNat y.toNat := by simp only [compare, compareOfLessAndEq, lt_iff_toNat_lt_toNat, UInt32.ext_iff] theorem UInt32.max_def (x y : UInt32) : max x y = if x ≤ y then y else x := rfl theorem UInt32.min_def (x y : UInt32) : min x y = if x ≤ y then x else y := rfl theorem UInt32.toNat_max (x y : UInt32) : (max x y).toNat = max x.toNat y.toNat := by rw [max_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_right h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_left (Nat.le_of_not_ge h)] theorem UInt32.toNat_min (x y : UInt32) : (min x y).toNat = min x.toNat y.toNat := by rw [min_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_left h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_right (Nat.le_of_not_ge h)] /-! ### UInt64 -/ @[ext] theorem UInt64.ext : {x y : UInt64} → x.toNat = y.toNat → x = y | ⟨⟨_,_⟩⟩, ⟨⟨_,_⟩⟩, rfl => rfl @[simp] theorem UInt64.toUInt8_toNat (x : UInt64) : x.toUInt8.toNat = x.toNat % 2 ^ 8 := rfl @[simp] theorem UInt64.toUInt16_toNat (x : UInt64) : x.toUInt16.toNat = x.toNat % 2 ^ 16 := rfl @[simp] theorem UInt64.toUInt32_toNat (x : UInt64) : x.toUInt32.toNat = x.toNat % 2 ^ 32 := rfl instance : Std.LawfulOrd UInt64 := Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt UInt64.le_antisymm theorem UInt64.le_iff_toNat_le_toNat {x y : UInt64} : x ≤ y ↔ x.toNat ≤ y.toNat := .rfl theorem UInt64.lt_iff_toNat_lt_toNat {x y : UInt64} : x < y ↔ x.toNat < y.toNat := .rfl theorem UInt64.compare_eq_toNat_compare_toNat (x y : UInt64) : compare x y = compare x.toNat y.toNat := by simp only [compare, compareOfLessAndEq, lt_iff_toNat_lt_toNat, UInt64.ext_iff] theorem UInt64.max_def (x y : UInt64) : max x y = if x ≤ y then y else x := rfl theorem UInt64.min_def (x y : UInt64) : min x y = if x ≤ y then x else y := rfl theorem UInt64.toNat_max (x y : UInt64) : (max x y).toNat = max x.toNat y.toNat := by rw [max_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_right h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.max_eq_left (Nat.le_of_not_ge h)] theorem UInt64.toNat_min (x y : UInt64) : (min x y).toNat = min x.toNat y.toNat := by rw [min_def] split · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_left h] · next h => rw [le_iff_toNat_le_toNat] at h rw [Nat.min_eq_right (Nat.le_of_not_ge h)] /-! ### USize -/ @[ext] theorem USize.ext : {x y : USize} → x.toNat = y.toNat → x = y | ⟨⟨_,_⟩⟩, ⟨⟨_,_⟩⟩, rfl => rfl theorem USize.toUInt64_toNat (x : USize) : x.toUInt64.toNat = x.toNat := by simp theorem UInt32.toUSize_toNat (x : UInt32) : x.toUSize.toNat = x.toNat := by simp instance : Std.LawfulOrd USize := Std.LawfulCmp.compareOfLessAndEq_of_irrefl_of_trans_of_not_lt_of_antisymm (fun _ => Nat.lt_irrefl _) Nat.lt_trans Nat.not_lt USize.le_antisymm theorem USize.toNat_ofNat_of_le_of_lt (h : n < USize.size) (hn : i ≤ n) : (USize.ofNat i).toNat = i := USize.toNat_ofNat_of_lt' (Nat.lt_of_le_of_lt ‹_› ‹_›) theorem USize.pred_toNat {i : USize} (h_gt : 0 < i) : (i - 1).toNat = i.toNat - 1 := by have h_gt_nat := USize.lt_iff_toNat_lt.mp h_gt have h_bound := i.toNat_lt_size cases System.Platform.numBits_eq all_goals simp_all only [USize.size, USize.toNat_sub, USize.reduceToNat] omega ================================================ FILE: Batteries/Data/UnionFind/Basic.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Tactic.Lint.Misc public import Batteries.Tactic.SeqFocus public import Batteries.Util.Panic @[expose] public section namespace Batteries /-- Union-find node type -/ structure UFNode where /-- Parent of node -/ parent : Nat /-- Rank of node -/ rank : Nat namespace UnionFind /-- Parent of a union-find node, defaults to self when the node is a root -/ def parentD (arr : Array UFNode) (i : Nat) : Nat := if h : i < arr.size then arr[i].parent else i /-- Rank of a union-find node, defaults to 0 when the node is a root -/ def rankD (arr : Array UFNode) (i : Nat) : Nat := if h : i < arr.size then arr[i].rank else 0 theorem parentD_eq {arr : Array UFNode} {i} (h) : parentD arr i = arr[i].parent := dif_pos _ theorem rankD_eq {arr : Array UFNode} {i} (h) : rankD arr i = arr[i].rank := dif_pos _ theorem parentD_of_not_lt : ¬i < arr.size → parentD arr i = i := (dif_neg ·) theorem lt_of_parentD : parentD arr i ≠ i → i < arr.size := Decidable.not_imp_comm.1 parentD_of_not_lt theorem parentD_set {arr : Array UFNode} {x v i h} : parentD (arr.set x v h) i = if x = i then v.parent else parentD arr i := by rw [parentD]; simp only [Array.size_set, parentD] split · split <;> simp_all · split <;> [(subst i; cases ‹¬_› h); rfl] theorem rankD_set {arr : Array UFNode} {x v i h} : rankD (arr.set x v h) i = if x = i then v.rank else rankD arr i := by rw [rankD]; simp only [Array.size_set, rankD] split · split <;> simp_all · split <;> [(subst i; cases ‹¬_› h); rfl] end UnionFind open UnionFind /-- ### Union-find data structure The `UnionFind` structure is an implementation of disjoint-set data structure that uses path compression to make the primary operations run in amortized nearly linear time. The nodes of a `UnionFind` structure `s` are natural numbers smaller than `s.size`. The structure associates with a canonical representative from its equivalence class. The structure can be extended using the `push` operation and equivalence classes can be updated using the `union` operation. The main operations for `UnionFind` are: * `empty`/`mkEmpty` are used to create a new empty structure. * `size` returns the size of the data structure. * `push` adds a new node to a structure, unlinked to any other node. * `union` links two nodes of the data structure, joining their equivalence classes, and performs path compression. * `find` returns the canonical representative of a node and updates the data structure using path compression. * `root` returns the canonical representative of a node without altering the data structure. * `checkEquiv` checks whether two nodes have the same canonical representative and updates the structure using path compression. Most use cases should prefer `find` over `root` to benefit from the speedup from path-compression. The main operations use `Fin s.size` to represent nodes of the union-find structure. Some alternatives are provided: * `unionN`, `findN`, `rootN`, `checkEquivN` use `Fin n` with a proof that `n = s.size`. * `union!`, `find!`, `root!`, `checkEquiv!` use `Nat` and panic when the indices are out of bounds. * `findD`, `rootD`, `checkEquivD` use `Nat` and treat out of bound indices as isolated nodes. The noncomputable relation `UnionFind.Equiv` is provided to use the equivalence relation from a `UnionFind` structure in the context of proofs. -/ structure UnionFind where /-- Array of union-find nodes -/ arr : Array UFNode /-- Validity for parent nodes -/ parentD_lt : ∀ {i}, i < arr.size → parentD arr i < arr.size /-- Validity for rank -/ rankD_lt : ∀ {i}, parentD arr i ≠ i → rankD arr i < rankD arr (parentD arr i) namespace UnionFind /-- Size of union-find structure. -/ @[inline] abbrev size (self : UnionFind) := self.arr.size /-- Create an empty union-find structure with specific capacity -/ def mkEmpty (c : Nat) : UnionFind where arr := Array.mkEmpty c parentD_lt := nofun rankD_lt := nofun /-- Empty union-find structure -/ def empty := mkEmpty 0 instance : EmptyCollection UnionFind := ⟨.empty⟩ /-- Parent of union-find node -/ abbrev parent (self : UnionFind) (i : Nat) : Nat := parentD self.arr i theorem parent'_lt (self : UnionFind) (i : Nat) (h) : self.arr[i].parent < self.size := by simp [← parentD_eq, parentD_lt, h] theorem parent_lt (self : UnionFind) (i : Nat) : self.parent i < self.size ↔ i < self.size := by simp only [parentD]; split <;> simp only [*, parent'_lt] /-- Rank of union-find node -/ abbrev rank (self : UnionFind) (i : Nat) : Nat := rankD self.arr i theorem rank_lt {self : UnionFind} {i : Nat} : self.parent i ≠ i → self.rank i < self.rank (self.parent i) := by simpa only [rank] using self.rankD_lt theorem rank'_lt (self : UnionFind) (i h) : self.arr[i].parent ≠ i → self.rank i < self.rank (self.arr[i]).parent := by simpa only [← parentD_eq] using self.rankD_lt /-- Maximum rank of nodes in a union-find structure -/ noncomputable def rankMax (self : UnionFind) := self.arr.foldr (max ·.rank) 0 + 1 theorem rank'_lt_rankMax (self : UnionFind) (i : Nat) (h) : (self.arr[i]).rank < self.rankMax := by let rec go : ∀ {l} {x : UFNode}, x ∈ l → x.rank ≤ List.foldr (max ·.rank) 0 l | a::l, _, List.Mem.head _ => by dsimp; apply Nat.le_max_left | a::l, _, .tail _ h => by dsimp; exact Nat.le_trans (go h) (Nat.le_max_right ..) simp only [rankMax, ← Array.foldr_toList] exact Nat.lt_succ_iff.2 <| go (self.arr.toList.getElem_mem _) theorem rankD_lt_rankMax (self : UnionFind) (i : Nat) : rankD self.arr i < self.rankMax := by simp [rankD]; split <;> [apply rank'_lt_rankMax; apply Nat.succ_pos] theorem lt_rankMax (self : UnionFind) (i : Nat) : self.rank i < self.rankMax := rankD_lt_rankMax .. theorem push_rankD (arr : Array UFNode) : rankD (arr.push ⟨arr.size, 0⟩) i = rankD arr i := by simp only [rankD, Array.size_push, Array.getElem_push, dite_eq_ite] split <;> split <;> first | simp | cases ‹¬_› (Nat.lt_succ_of_lt ‹_›) theorem push_parentD (arr : Array UFNode) : parentD (arr.push ⟨arr.size, 0⟩) i = parentD arr i := by simp only [parentD, Array.size_push, Array.getElem_push, dite_eq_ite] split <;> split <;> try simp · exact Nat.le_antisymm (Nat.ge_of_not_lt ‹_›) (Nat.le_of_lt_succ ‹_›) · cases ‹¬_› (Nat.lt_succ_of_lt ‹_›) /-- Add a new node to a union-find structure, unlinked with any other nodes -/ def push (self : UnionFind) : UnionFind where arr := self.arr.push ⟨self.arr.size, 0⟩ parentD_lt {i} := by simp only [Array.size_push, push_parentD]; simp only [parentD] split <;> [exact fun _ => Nat.lt_succ_of_lt (self.parent'_lt ..); exact id] rankD_lt := by simp only [push_parentD, ne_eq, push_rankD]; exact self.rank_lt /-- Root of a union-find node. -/ def root (self : UnionFind) (x : Fin self.size) : Fin self.size := let y := self.arr[x.1].parent if h : y = x then x else have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ h) self.root ⟨y, self.parent'_lt x _⟩ termination_by self.rankMax - self.rank x @[inherit_doc root] def rootN (self : UnionFind) (x : Fin n) (h : n = self.size) : Fin n := match n, h with | _, rfl => self.root x /-- Root of a union-find node. Panics if index is out of bounds. -/ def root! (self : UnionFind) (x : Nat) : Nat := if h : x < self.size then self.root ⟨x, h⟩ else panicWith x "index out of bounds" /-- Root of a union-find node. Returns input if index is out of bounds. -/ def rootD (self : UnionFind) (x : Nat) : Nat := if h : x < self.size then self.root ⟨x, h⟩ else x set_option backward.proofsInPublic true in -- for `rw [root]` @[nolint unusedHavesSuffices] theorem parent_root (self : UnionFind) (x : Fin self.size) : (self.arr[(self.root x).1]).parent = self.root x := by rw [root]; split <;> [assumption; skip] have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) apply parent_root termination_by self.rankMax - self.rank x theorem parent_rootD (self : UnionFind) (x : Nat) : self.parent (self.rootD x) = self.rootD x := by rw [rootD] split · simp [parentD, parent_root] · simp [parentD_of_not_lt, *] @[nolint unusedHavesSuffices] theorem rootD_parent (self : UnionFind) (x : Nat) : self.rootD (self.parent x) = self.rootD x := by simp only [rootD, parent_lt] split · simp only [parentD, ↓reduceDIte, *] (conv => rhs; rw [root]); split · rw [root, dif_pos] <;> simp_all · simp · simp only [not_false_eq_true, parentD_of_not_lt, *] theorem rootD_lt {self : UnionFind} {x : Nat} : self.rootD x < self.size ↔ x < self.size := by simp only [rootD]; split <;> simp [*] @[nolint unusedHavesSuffices] theorem rootD_eq_self {self : UnionFind} {x : Nat} : self.rootD x = x ↔ self.parent x = x := by refine ⟨fun h => by rw [← h, parent_rootD], fun h => ?_⟩ rw [rootD]; split <;> [rw [root, dif_pos (by rwa [parent, parentD_eq ‹_›] at h)]; rfl] theorem rootD_rootD {self : UnionFind} {x : Nat} : self.rootD (self.rootD x) = self.rootD x := rootD_eq_self.2 (parent_rootD ..) theorem rootD_ext {m1 m2 : UnionFind} (H : ∀ x, m1.parent x = m2.parent x) {x} : m1.rootD x = m2.rootD x := by if h : m2.parent x = x then rw [rootD_eq_self.2 h, rootD_eq_self.2 ((H _).trans h)] else have := Nat.sub_lt_sub_left (m2.lt_rankMax x) (m2.rank_lt h) rw [← rootD_parent, H, rootD_ext H, rootD_parent] termination_by m2.rankMax - m2.rank x theorem le_rank_root {self : UnionFind} {x : Nat} : self.rank x ≤ self.rank (self.rootD x) := by if h : self.parent x = x then rw [rootD_eq_self.2 h]; exact Nat.le_refl .. else have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank_lt h) rw [← rootD_parent] exact Nat.le_trans (Nat.le_of_lt (self.rank_lt h)) le_rank_root termination_by self.rankMax - self.rank x theorem lt_rank_root {self : UnionFind} {x : Nat} : self.rank x < self.rank (self.rootD x) ↔ self.parent x ≠ x := by refine ⟨fun h h' => Nat.ne_of_lt h (by rw [rootD_eq_self.2 h']), fun h => ?_⟩ rw [← rootD_parent] exact Nat.lt_of_lt_of_le (self.rank_lt h) le_rank_root /-- Auxiliary data structure for find operation -/ structure FindAux (n : Nat) where /-- Array of nodes -/ s : Array UFNode /-- Index of root node -/ root : Fin n /-- Size requirement -/ size_eq : s.size = n /-- Auxiliary function for find operation -/ def findAux (self : UnionFind) (x : Fin self.size) : FindAux self.size := let y := self.arr[x.1].parent if h : y = x then ⟨self.arr, x, rfl⟩ else have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ h) let ⟨arr₁, root, H⟩ := self.findAux ⟨y, self.parent'_lt _ x.2⟩ ⟨arr₁.modify x fun s => { s with parent := root }, root, by simp [H]⟩ termination_by self.rankMax - self.rank x @[nolint unusedHavesSuffices] theorem findAux_root {self : UnionFind} {x : Fin self.size} : (findAux self x).root = self.root x := by rw [findAux, root] simp only [dite_eq_ite] split <;> simp only have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) exact findAux_root termination_by self.rankMax - self.rank x @[nolint unusedHavesSuffices] theorem findAux_s {self : UnionFind} {x : Fin self.size} : (findAux self x).s = if self.arr[x.1].parent = x then self.arr else (self.findAux ⟨_, self.parent'_lt x x.2⟩).s.modify x fun s => { s with parent := self.rootD x } := by rw [show self.rootD _ = (self.findAux ⟨_, self.parent'_lt x x.2⟩).root from _] · rw [findAux]; split <;> rfl · rw [← rootD_parent, parent, parentD_eq (Fin.is_lt _)] simp only [rootD, findAux_root] apply dif_pos theorem rankD_findAux {self : UnionFind} {x : Fin self.size} : rankD (findAux self x).s i = self.rank i := by if h : i < self.size then rw [findAux_s]; split <;> [rfl; skip] have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) have := lt_of_parentD (by rwa [parentD_eq]) rw [rankD_eq (by simp [FindAux.size_eq, h]), Array.getElem_modify] split <;> simp [← rankD_eq, rankD_findAux (x := ⟨_, self.parent'_lt _ x.2⟩)] else simp only [rankD, rank] rw [dif_neg (by rwa [FindAux.size_eq]), dif_neg h] termination_by self.rankMax - self.rank x theorem parentD_findAux {self : UnionFind} {x : Fin self.size} : parentD (findAux self x).s i = if i = x then self.rootD x else parentD (self.findAux ⟨_, self.parent'_lt _ x.2⟩).s i := by rw [findAux_s]; split <;> [split; skip] · subst i; rw [rootD_eq_self.2 _] <;> simp [parentD_eq, *] · rw [findAux_s]; simp [*] · next h => rw [parentD]; split <;> rename_i h' · rw [Array.getElem_modify (by simpa using h')] simp only [@eq_comm _ i] split <;> simp [← parentD_eq] · rw [if_neg (mt (by rintro rfl; simp [FindAux.size_eq]) h')] rw [parentD, dif_neg]; simpa using h' theorem parentD_findAux_rootD {self : UnionFind} {x : Fin self.size} : parentD (findAux self x).s (self.rootD x) = self.rootD x := by rw [parentD_findAux]; split <;> [rfl; rename_i h] rw [rootD_eq_self, parent, parentD_eq x.2] at h have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) rw [← rootD_parent, parent, parentD_eq x.2] exact parentD_findAux_rootD (x := ⟨_, self.parent'_lt _ x.2⟩) termination_by self.rankMax - self.rank x theorem parentD_findAux_lt {self : UnionFind} {x : Fin self.size} (h : i < self.size) : parentD (findAux self x).s i < self.size := by if h' : self.arr[x.1].parent = x then rw [findAux_s, if_pos h']; apply self.parentD_lt h else rw [parentD_findAux] split · simp [rootD_lt] · have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) apply parentD_findAux_lt h termination_by self.rankMax - self.rank x theorem parentD_findAux_or (self : UnionFind) (x : Fin self.size) (i) : parentD (findAux self x).s i = self.rootD i ∧ self.rootD i = self.rootD x ∨ parentD (findAux self x).s i = self.parent i := by if h' : self.arr[x.1].parent = x then rw [findAux_s, if_pos h']; exact .inr rfl else rw [parentD_findAux] split · simp [*] · have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) refine (parentD_findAux_or self ⟨_, self.parent'_lt _ x.2⟩ i) |>.imp_left (.imp_right fun h => ?_) simp only [h, ← parentD_eq, rootD_parent] termination_by self.rankMax - self.rank x theorem lt_rankD_findAux {self : UnionFind} {x : Fin self.size} : parentD (findAux self x).s i ≠ i → self.rank i < self.rank (parentD (findAux self x).s i) := by if h' : self.arr[x.1].parent = x then rw [findAux_s, if_pos h']; apply self.rank_lt else rw [parentD_findAux]; split <;> rename_i h <;> intro h' · subst i; rwa [lt_rank_root, Ne, ← rootD_eq_self] · have := Nat.sub_lt_sub_left (self.lt_rankMax x) (self.rank'_lt _ _ ‹_›) apply lt_rankD_findAux h' termination_by self.rankMax - self.rank x /-- Find root of a union-find node, updating the structure using path compression. -/ def find (self : UnionFind) (x : Fin self.size) : (s : UnionFind) × {_root : Fin s.size // s.size = self.size} := let r := self.findAux x { 1.arr := r.s 2.1.val := r.root 1.parentD_lt := fun h => by simp only [FindAux.size_eq] at * exact parentD_findAux_lt h 1.rankD_lt := fun h => by rw [rankD_findAux, rankD_findAux]; exact lt_rankD_findAux h 2.1.isLt := show _ < r.s.size by rw [r.size_eq]; exact r.root.2 2.2 := by simp [size, r.size_eq] } @[inherit_doc find] def findN (self : UnionFind) (x : Fin n) (h : n = self.size) : UnionFind × Fin n := match n, h with | _, rfl => match self.find x with | ⟨s, r, h⟩ => (s, Fin.cast h r) /-- Find root of a union-find node, updating the structure using path compression. Panics if index is out of bounds. -/ def find! (self : UnionFind) (x : Nat) : UnionFind × Nat := if h : x < self.size then match self.find ⟨x, h⟩ with | ⟨s, r, _⟩ => (s, r) else panicWith (self, x) "index out of bounds" /-- Find root of a union-find node, updating the structure using path compression. Returns inputs unchanged when index is out of bounds. -/ def findD (self : UnionFind) (x : Nat) : UnionFind × Nat := if h : x < self.size then match self.find ⟨x, h⟩ with | ⟨s, r, _⟩ => (s, r) else (self, x) @[simp] theorem find_size (self : UnionFind) (x : Fin self.size) : (self.find x).1.size = self.size := by simp [find, size, FindAux.size_eq] @[simp] theorem find_root_2 (self : UnionFind) (x : Fin self.size) : (self.find x).2.1.1 = self.rootD x := by simp [find, findAux_root, rootD] @[simp] theorem find_parent_1 (self : UnionFind) (x : Fin self.size) : (self.find x).1.parent x = self.rootD x := by simp only [parent, find] rw [parentD_findAux, if_pos rfl] theorem find_parent_or (self : UnionFind) (x : Fin self.size) (i) : (self.find x).1.parent i = self.rootD i ∧ self.rootD i = self.rootD x ∨ (self.find x).1.parent i = self.parent i := parentD_findAux_or .. @[simp] theorem find_root_1 (self : UnionFind) (x : Fin self.size) (i : Nat) : (self.find x).1.rootD i = self.rootD i := by if h : (self.find x).1.parent i = i then rw [rootD_eq_self.2 h] obtain ⟨h1, _⟩ | h1 := find_parent_or self x i <;> rw [h1] at h · rw [h] · rw [rootD_eq_self.2 h] else have := Nat.sub_lt_sub_left ((self.find x).1.lt_rankMax _) ((self.find x).1.rank_lt h) rw [← rootD_parent, find_root_1 self x ((self.find x).1.parent i)] obtain ⟨h1, _⟩ | h1 := find_parent_or self x i · rw [h1, rootD_rootD] · rw [h1, rootD_parent] termination_by (self.find x).1.rankMax - (self.find x).1.rank i decreasing_by exact this -- why is this needed? It is way slower without it /-- Link two union-find nodes -/ def linkAux (self : Array UFNode) (x y : Fin self.size) : Array UFNode := if x.1 = y then self else let nx := self[x.1] let ny := self[y.1] if ny.rank < nx.rank then self.set y {ny with parent := x} else let arr₁ := self.set x {nx with parent := y} if nx.rank = ny.rank then arr₁.set y {ny with rank := ny.rank + 1} (by simp [arr₁]) else arr₁ theorem setParentBump_rankD_lt {arr : Array UFNode} {x y : Fin arr.size} (hroot : arr[x.1].rank < arr[y.1].rank ∨ arr[y.1].parent = y) (H : arr[x.1].rank ≤ arr[y.1].rank) {i : Nat} (rankD_lt : parentD arr i ≠ i → rankD arr i < rankD arr (parentD arr i)) (hP : parentD arr' i = if x.1 = i then y.1 else parentD arr i) (hR : ∀ {i}, rankD arr' i = if y.1 = i ∧ arr[x.1].rank = arr[y.1].rank then arr[y.1].rank + 1 else rankD arr i) : ¬parentD arr' i = i → rankD arr' i < rankD arr' (parentD arr' i) := by simp only [ne_eq, hP, hR, implies_true] at *; split <;> rename_i h₁ <;> [simp [← h₁]; skip] <;> split <;> rename_i h₂ <;> intro h · simp [h₂] at h · simp only [rankD_eq, x.2, y.2] split <;> rename_i h₃ · rw [← h₃]; apply Nat.lt_succ_self · exact Nat.lt_of_le_of_ne H h₃ · cases h₂.1 simp only [h₂.2, false_or, Nat.lt_irrefl] at hroot simp only [hroot, parentD_eq y.2, not_true_eq_false] at h · have := rankD_lt h split <;> rename_i h₃ · rw [← rankD_eq, h₃.1]; exact Nat.lt_succ_of_lt this · exact this theorem setParent_rankD_lt {arr : Array UFNode} {x y : Fin arr.size} (h : arr[x.1].rank < arr[y.1].rank) {i : Nat} (rankD_lt : parentD arr i ≠ i → rankD arr i < rankD arr (parentD arr i)) : let arr' := arr.set x ⟨y, arr[x].rank⟩ parentD arr' i ≠ i → rankD arr' i < rankD arr' (parentD arr' i) := setParentBump_rankD_lt (.inl h) (Nat.le_of_lt h) rankD_lt parentD_set (by simp [rankD_set, Nat.ne_of_lt h, rankD_eq]) @[simp] theorem linkAux_size : (linkAux self x y).size = self.size := by simp only [linkAux] split <;> [rfl; split] <;> [skip; split] <;> simp /-- Link a union-find node to a root node. -/ def link (self : UnionFind) (x y : Fin self.size) (yroot : self.parent y = y) : UnionFind where arr := linkAux self.arr x y parentD_lt h := by simp only [linkAux_size] at * simp only [linkAux] split <;> [skip; split <;> [skip; split]] · exact self.parentD_lt h · rw [parentD_set]; split <;> [exact x.2; exact self.parentD_lt h] · rw [parentD_set]; split · exact self.parent'_lt .. · rw [parentD_set]; split <;> [exact y.2; exact self.parentD_lt h] · rw [parentD_set]; split <;> [exact y.2; exact self.parentD_lt h] rankD_lt := by rw [parent, parentD_eq (Fin.is_lt _)] at yroot simp only [linkAux, ne_eq] split <;> [skip; split <;> [skip; split]] · exact self.rankD_lt · exact setParent_rankD_lt ‹_› self.rankD_lt · refine setParentBump_rankD_lt (.inr yroot) (Nat.le_of_eq ‹_›) self.rankD_lt (by simp only [parentD_set, ite_eq_right_iff] rintro rfl simp [*, parentD_eq]) fun {i} => ?_ simp only [rankD_set] split · simp_all · simp_all only [Nat.lt_irrefl, not_false_eq_true, and_true, ite_false, ite_eq_right_iff] rintro rfl simp [rankD_eq, *] · exact setParent_rankD_lt (Nat.lt_of_le_of_ne (Nat.not_lt.1 ‹_›) ‹_›) self.rankD_lt @[inherit_doc link] def linkN (self : UnionFind) (x y : Fin n) (yroot : self.parent y = y) (h : n = self.size) : UnionFind := match n, h with | _, rfl => self.link x y yroot /-- Link a union-find node to a root node. Panics if either index is out of bounds. -/ def link! (self : UnionFind) (x y : Nat) (yroot : self.parent y = y) : UnionFind := if h : x < self.size ∧ y < self.size then self.link ⟨x, h.1⟩ ⟨y, h.2⟩ yroot else panicWith self "index out of bounds" /-- Link two union-find nodes, uniting their respective classes. -/ def union (self : UnionFind) (x y : Fin self.size) : UnionFind := let ⟨self₁, rx, ex⟩ := self.find x have hy := by rw [ex]; exact y.2 match eq : self₁.find ⟨y, hy⟩ with | ⟨self₂, ry, ey⟩ => self₂.link ⟨rx, by rw [ey]; exact rx.2⟩ ry <| by have := find_root_1 self₁ ⟨y, hy⟩ (⟨y, hy⟩ : Fin _) rw [← find_root_2, eq] at this; simp at this rw [← this, parent_rootD] @[inherit_doc union] def unionN (self : UnionFind) (x y : Fin n) (h : n = self.size) : UnionFind := match n, h with | _, rfl => self.union x y /-- Link two union-find nodes, uniting their respective classes. Panics if either index is out of bounds. -/ def union! (self : UnionFind) (x y : Nat) : UnionFind := if h : x < self.size ∧ y < self.size then self.union ⟨x, h.1⟩ ⟨y, h.2⟩ else panicWith self "index out of bounds" /-- Check whether two union-find nodes are equivalent, updating structure using path compression. -/ def checkEquiv (self : UnionFind) (x y : Fin self.size) : UnionFind × Bool := let ⟨s, ⟨r₁, _⟩, h⟩ := self.find x let ⟨s, ⟨r₂, _⟩, _⟩ := s.find (h ▸ y) (s, r₁ == r₂) @[inherit_doc checkEquiv] def checkEquivN (self : UnionFind) (x y : Fin n) (h : n = self.size) : UnionFind × Bool := match n, h with | _, rfl => self.checkEquiv x y /-- Check whether two union-find nodes are equivalent, updating structure using path compression. Panics if either index is out of bounds. -/ def checkEquiv! (self : UnionFind) (x y : Nat) : UnionFind × Bool := if h : x < self.size ∧ y < self.size then self.checkEquiv ⟨x, h.1⟩ ⟨y, h.2⟩ else panicWith (self, false) "index out of bounds" /-- Check whether two union-find nodes are equivalent with path compression, returns `x == y` if either index is out of bounds -/ def checkEquivD (self : UnionFind) (x y : Nat) : UnionFind × Bool := let (s, x) := self.findD x let (s, y) := s.findD y (s, x == y) /-- Equivalence relation from a `UnionFind` structure -/ def Equiv (self : UnionFind) (a b : Nat) : Prop := self.rootD a = self.rootD b ================================================ FILE: Batteries/Data/UnionFind/Lemmas.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Data.UnionFind.Basic @[expose] public section namespace Batteries.UnionFind @[simp] theorem arr_empty : empty.arr = #[] := rfl @[simp] theorem parent_empty : empty.parent a = a := rfl @[simp] theorem rank_empty : empty.rank a = 0 := rfl @[simp] theorem rootD_empty : empty.rootD a = a := rfl @[simp] theorem arr_push {m : UnionFind} : m.push.arr = m.arr.push ⟨m.arr.size, 0⟩ := rfl @[simp] theorem parentD_push {arr : Array UFNode} : parentD (arr.push ⟨arr.size, 0⟩) a = parentD arr a := by simp [parentD]; split <;> split <;> try simp [Array.getElem_push, *] · next h1 h2 => simp [Nat.lt_succ_iff] at h1 h2 exact Nat.le_antisymm h2 h1 · next h1 h2 => cases h1 (Nat.lt_succ_of_lt h2) @[simp] theorem parent_push {m : UnionFind} : m.push.parent a = m.parent a := by simp [parent] @[simp] theorem rankD_push {arr : Array UFNode} : rankD (arr.push ⟨arr.size, 0⟩) a = rankD arr a := by simp [rankD]; split <;> split <;> try simp [Array.getElem_push, *] next h1 h2 => cases h1 (Nat.lt_succ_of_lt h2) @[simp] theorem rank_push {m : UnionFind} : m.push.rank a = m.rank a := by simp [rank] @[simp] theorem rankMax_push {m : UnionFind} : m.push.rankMax = m.rankMax := by simp [rankMax] @[simp] theorem root_push {self : UnionFind} : self.push.rootD x = self.rootD x := rootD_ext fun _ => parent_push @[simp] theorem arr_link : (link self x y yroot).arr = linkAux self.arr x y := rfl theorem parentD_linkAux {self} {x y : Fin self.size} : parentD (linkAux self x y) i = if x.1 = y then parentD self i else if self[y.1].rank < self[x.1].rank then if y = i then x else parentD self i else if x = i then y else parentD self i := by dsimp only [linkAux]; split <;> [rfl; split] <;> [rw [parentD_set]; split] <;> rw [parentD_set] split <;> [(subst i; rwa [if_neg, parentD_eq]); rw [parentD_set]] theorem parent_link {self} {x y : Fin self.size} (yroot) {i} : (link self x y yroot).parent i = if x.1 = y then self.parent i else if self.rank y < self.rank x then if y = i then x else self.parent i else if x = i then y else self.parent i := by simp [rankD_eq]; exact parentD_linkAux theorem root_link {self : UnionFind} {x y : Fin self.size} (xroot : self.parent x = x) (yroot : self.parent y = y) : ∃ r, (r = x ∨ r = y) ∧ ∀ i, (link self x y yroot).rootD i = if self.rootD i = x ∨ self.rootD i = y then r.1 else self.rootD i := by if h : x.1 = y then refine ⟨x, .inl rfl, fun i => ?_⟩ rw [rootD_ext (m2 := self) (fun _ => by rw [parent_link, if_pos h])] split <;> [obtain _ | _ := ‹_› <;> simp [*]; rfl] else have {x y : Fin self.size} (xroot : self.parent x = x) (yroot : self.parent y = y) {m : UnionFind} (hm : ∀ i, m.parent i = if y = i then x.1 else self.parent i) : ∃ r, (r = x ∨ r = y) ∧ ∀ i, m.rootD i = if self.rootD i = x ∨ self.rootD i = y then r.1 else self.rootD i := by let rec go (i) : m.rootD i = if self.rootD i = x ∨ self.rootD i = y then x.1 else self.rootD i := by if h : m.parent i = i then rw [rootD_eq_self.2 h]; rw [hm i] at h; split at h · rw [if_pos, h]; simp [← h, rootD_eq_self, xroot] · rw [rootD_eq_self.2 ‹_›]; split <;> [skip; rfl] next h' => exact h'.resolve_right (Ne.symm ‹_›) else have _ := Nat.sub_lt_sub_left (m.lt_rankMax i) (m.rank_lt h) rw [← rootD_parent, go (m.parent i)] rw [hm i]; split <;> [subst i; rw [rootD_parent]] simp [rootD_eq_self.2 xroot, rootD_eq_self.2 yroot] termination_by m.rankMax - m.rank i exact ⟨x, .inl rfl, go⟩ if hr : self.rank y < self.rank x then exact this xroot yroot fun i => by simp [parent_link, h, hr] else simpa (config := {singlePass := true}) [or_comm] using this yroot xroot fun i => by simp [parent_link, h, hr] nonrec theorem Equiv.rfl : Equiv self a a := rfl nonrec theorem Equiv.symm : Equiv self a b → Equiv self b a := .symm nonrec theorem Equiv.trans : Equiv self a b → Equiv self b c → Equiv self a c := .trans @[simp] theorem equiv_empty : Equiv empty a b ↔ a = b := by simp [Equiv] @[simp] theorem equiv_push : Equiv self.push a b ↔ Equiv self a b := by simp [Equiv] @[simp] theorem equiv_rootD : Equiv self (self.rootD a) a := by simp [Equiv, rootD_rootD] @[simp] theorem equiv_rootD_l : Equiv self (self.rootD a) b ↔ Equiv self a b := by simp [Equiv, rootD_rootD] @[simp] theorem equiv_rootD_r : Equiv self a (self.rootD b) ↔ Equiv self a b := by simp [Equiv, rootD_rootD] theorem equiv_find : Equiv (self.find x).1 a b ↔ Equiv self a b := by simp [Equiv, find_root_1] theorem equiv_link {self : UnionFind} {x y : Fin self.size} (xroot : self.parent x = x) (yroot : self.parent y = y) : Equiv (link self x y yroot) a b ↔ Equiv self a b ∨ Equiv self a x ∧ Equiv self y b ∨ Equiv self a y ∧ Equiv self x b := by have {m : UnionFind} {x y : Fin self.size} (xroot : self.rootD x = x) (yroot : self.rootD y = y) (hm : ∀ i, m.rootD i = if self.rootD i = x ∨ self.rootD i = y then x.1 else self.rootD i) : Equiv m a b ↔ Equiv self a b ∨ Equiv self a x ∧ Equiv self y b ∨ Equiv self a y ∧ Equiv self x b := by simp [Equiv, hm, xroot, yroot] by_cases h1 : rootD self a = x <;> by_cases h2 : rootD self b = x <;> simp [h1, h2, imp_false, Decidable.not_not, -left_eq_ite_iff] · simp [Ne.symm h2, -left_eq_ite_iff]; split <;> simp [@eq_comm _ _ (rootD self b), *] · by_cases h1 : rootD self a = y <;> by_cases h2 : rootD self b = y <;> simp [@eq_comm _ _ (rootD self b), *] obtain ⟨r, ha, hr⟩ := root_link xroot yroot; revert hr rw [← rootD_eq_self] at xroot yroot obtain rfl | rfl := ha · exact this xroot yroot · simpa [or_comm, and_comm] using this yroot xroot theorem equiv_union {self : UnionFind} {x y : Fin self.size} : Equiv (union self x y) a b ↔ Equiv self a b ∨ Equiv self a x ∧ Equiv self y b ∨ Equiv self a y ∧ Equiv self x b := by simp [union]; rw [equiv_link (by simp [← rootD_eq_self, rootD_rootD])]; simp [equiv_find] ================================================ FILE: Batteries/Data/UnionFind.lean ================================================ module public import Batteries.Data.UnionFind.Basic public import Batteries.Data.UnionFind.Lemmas ================================================ FILE: Batteries/Data/Vector/Basic.lean ================================================ /- Copyright (c) 2024 Shreyas Srinivas. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Shreyas Srinivas, François G. Dorais -/ module @[expose] public section /-! # Vectors `Vector α n` is a thin wrapper around `Array α` for arrays of fixed size `n`. -/ namespace Vector /-- Returns `true` when all elements of the vector are pairwise distinct using `==` for comparison. -/ @[inline] def allDiff [BEq α] (as : Vector α n) : Bool := as.toArray.allDiff ================================================ FILE: Batteries/Data/Vector/Lemmas.lean ================================================ /- Copyright (c) 2024 Shreyas Srinivas. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Shreyas Srinivas, François G. Dorais, Eric Wieser -/ module @[expose] public section namespace Vector theorem toArray_injective : ∀ {v w : Vector α n}, v.toArray = w.toArray → v = w | {..}, {..}, rfl => rfl /-! ### mk lemmas -/ @[simp] theorem get_mk (a : Array α) (h : a.size = n) (i) : (Vector.mk a h).get i = a[i] := rfl @[simp] theorem getD_mk (a : Array α) (h : a.size = n) (i x) : (Vector.mk a h).getD i x = a.getD i x := rfl @[simp] theorem uget_mk (a : Array α) (h : a.size = n) (i) (hi : i.toNat < n) : (Vector.mk a h).uget i hi = a.uget i (by simp [h, hi]) := rfl /-! ### tail lemmas -/ theorem tail_eq_of_zero {v : Vector α 0} : v.tail = #v[] := Vector.eq_empty theorem tail_eq_of_ne_zero [NeZero n] {v : Vector α n} : v.tail = v.eraseIdx 0 n.pos_of_neZero := by simp only [tail_eq_cast_extract] ext simp only [getElem_cast, getElem_extract, getElem_eraseIdx, Nat.not_lt_zero, ↓reduceDIte] congr 1 omega -- This is not a `@[simp]` lemma because the LHS simplifies to `Vector.extract`. theorem toList_tail {v : Vector α n} : v.tail.toList = v.toList.tail := match n with | 0 => by simp [Vector.eq_empty] | _ + 1 => by apply List.ext_getElem · simp · intro i h₁ h₂ simp only [Nat.add_one_sub_one, tail_eq_cast_extract, getElem_toList, getElem_cast, getElem_extract, List.getElem_tail] congr 1 omega /-! ### getElem lemmas -/ theorem getElem_tail {v : Vector α n} {i : Nat} (hi : i < n - 1) : v.tail[i] = v[i + 1] := match n with | _ + 1 => getElem_congr_coll tail_eq_of_ne_zero |>.trans <| getElem_eraseIdx (Nat.zero_lt_succ _) hi /-! ### get lemmas -/ theorem get_eq_getElem (v : Vector α n) (i : Fin n) : v.get i = v[(i : Nat)] := rfl @[simp] theorem get_push_last (v : Vector α n) (a : α) : (v.push a).get (Fin.last n) = a := getElem_push_last @[simp] theorem get_push_castSucc (v : Vector α n) (a : α) (i : Fin n) : (v.push a).get (Fin.castSucc i) = v.get i := getElem_push_lt _ @[simp] theorem get_map (v : Vector α n) (f : α → β) (i : Fin n) : (v.map f).get i = f (v.get i) := getElem_map _ _ @[simp] theorem get_reverse (v : Vector α n) (i : Fin n) : v.reverse.get i = v.get (i.rev) := getElem_reverse _ |>.trans <| congrArg v.get <| Fin.ext <| by simp; omega @[simp] theorem get_replicate (n : Nat) (a : α) (i : Fin n) : (replicate n a).get i = a := getElem_replicate _ @[simp] theorem get_range (n : Nat) (i : Fin n) : (range n).get i = i := getElem_range _ @[simp] theorem get_ofFn (f : Fin n → α) (i : Fin n) : (ofFn f).get i = f i := getElem_ofFn _ @[simp] theorem get_cast (v : Vector α m) (h : m = n) (i : Fin n) : (v.cast h).get i = v.get (i.cast h.symm) := getElem_cast _ -- This is not a `@[simp]` lemma because the LHS simplifies to `Vector.extract`. theorem get_tail (v : Vector α (n + 1)) (i : Fin n) : v.tail.get i = v.get i.succ := getElem_tail _ /-! ### finIdxOf? lemmas -/ @[simp] theorem finIdxOf?_empty [BEq α] (v : Vector α 0) : v.finIdxOf? a = none := by simp [v.eq_empty] @[simp] theorem finIdxOf?_eq_none_iff [BEq α] [LawfulBEq α] {v : Vector α n} {a : α} : v.finIdxOf? a = none ↔ a ∉ v := by obtain ⟨xs, rfl⟩ := v simp @[simp] theorem finIdxOf?_eq_some_iff [BEq α] [LawfulBEq α] {v : Vector α n} {a : α} {i : Fin n} : v.finIdxOf? a = some i ↔ v.get i = a ∧ ∀ j < i, ¬v.get j = a := by obtain ⟨xs, rfl⟩ := v simp @[simp] theorem isSome_finIdxOf? [BEq α] [PartialEquivBEq α] {v : Vector α n} {a : α} : (v.finIdxOf? a).isSome = v.contains a := by obtain ⟨v, rfl⟩ := v simp @[simp] theorem isNone_finIdxOf? [BEq α] [PartialEquivBEq α] {v : Vector α n} {a : α} : (v.finIdxOf? a).isNone = !v.contains a := by obtain ⟨v, rfl⟩ := v simp ================================================ FILE: Batteries/Data/Vector/Monadic.lean ================================================ /- Copyright (c) 2025 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Classes.SatisfiesM public import Batteries.Data.Array.Monadic @[expose] public section namespace Vector theorem mapM_mk [Monad m] [LawfulMonad m] [MonadSatisfying m] (a : Array α) (h : a.size = n) (f : α → m β) : (Vector.mk a h).mapM f = (fun ⟨a, h'⟩ => Vector.mk a (h'.trans h)) <$> satisfying (Array.size_mapM f a) := by rw [← _root_.map_inj_right Vector.toArray_inj.mp] simp only [Functor.map_map, MonadSatisfying.val_eq, toArray_mapM] theorem mapIdxM_mk [Monad m] [LawfulMonad m] [MonadSatisfying m] (a : Array α) (h : a.size = n) (f : Nat → α → m β) : (Vector.mk a h).mapIdxM f = (fun ⟨a, h'⟩ => Vector.mk a (h'.trans h)) <$> satisfying (Array.size_mapIdxM a f) := by rw [← _root_.map_inj_right Vector.toArray_inj.mp] simp only [Functor.map_map, MonadSatisfying.val_eq, toArray_mapIdxM] theorem mapFinIdxM_mk [Monad m] [LawfulMonad m] [MonadSatisfying m] (a : Array α) (h : a.size = n) (f : (i : Nat) → α → (h : i < n) → m β) : (Vector.mk a h).mapFinIdxM f = (fun ⟨a, h'⟩ => Vector.mk a (h'.trans h)) <$> satisfying (Array.size_mapFinIdxM a (fun i a h' => f i a (h ▸ h'))) := by rw [← _root_.map_inj_right Vector.toArray_inj.mp] simp only [Functor.map_map, MonadSatisfying.val_eq, toArray_mapFinIdxM] ================================================ FILE: Batteries/Data/Vector.lean ================================================ module public import Batteries.Data.Vector.Basic public import Batteries.Data.Vector.Lemmas public import Batteries.Data.Vector.Monadic ================================================ FILE: Batteries/Lean/AttributeExtra.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Batteries.Lean.TagAttribute public import Std.Data.HashMap.Basic @[expose] public section open Lean namespace Lean open Std /-- `TagAttributeExtra` works around a limitation of `TagAttribute`, which is that definitions must be tagged in the same file that declares the definition. This works well for definitions in lean core, but for attributes declared outside the core this is problematic because we may want to tag declarations created before the attribute was defined. To resolve this, we allow a one-time exception to the rule that attributes must be applied in the same file as the declaration: During the declaration of the attribute itself, we can tag arbitrary other definitions, but once the attribute is declared we must tag things in the same file as normal. -/ structure TagAttributeExtra where /-- The environment extension for the attribute. -/ ext : PersistentEnvExtension Name Name NameSet /-- A list of "base" declarations which have been pre-tagged. -/ base : NameHashSet deriving Inhabited /-- Registers a new tag attribute. The `extra` field is a list of definitions from other modules which will be "pre-tagged" and are not subject to the usual restriction on tagging in the same file as the declaration. Note: The `extra` fields bypass the `validate` function - we assume the builtins are also pre-validated. -/ def registerTagAttributeExtra (name : Name) (descr : String) (extra : List Name) (validate : Name → AttrM Unit := fun _ => pure ()) (ref : Name := by exact decl_name%) : IO TagAttributeExtra := do let { ext, .. } ← registerTagAttribute name descr validate ref pure { ext, base := extra.foldl (·.insert ·) {} } namespace TagAttributeExtra /-- Does declaration `decl` have the tag `attr`? -/ def hasTag (attr : TagAttributeExtra) (env : Environment) (decl : Name) : Bool := match env.getModuleIdxFor? decl with | some modIdx => (attr.ext.getModuleEntries env modIdx).binSearchContains decl Name.quickLt | none => (attr.ext.getState env).contains decl || attr.base.contains decl /-- Get the list of declarations tagged with the tag attribute `attr`. -/ def getDecls (attr : TagAttributeExtra) (env : Environment) : Array Name := Id.run do let decls := TagAttribute.getDecls.core <| attr.ext.toEnvExtension.getState env attr.base.fold (·.push ·) decls end TagAttributeExtra /-- `ParametricAttributeExtra` works around a limitation of `ParametricAttribute`, which is that definitions must be tagged in the same file that declares the definition. This works well for definitions in lean core, but for attributes declared outside the core this is problematic because we may want to tag declarations created before the attribute was defined. To resolve this, we allow a one-time exception to the rule that attributes must be applied in the same file as the declaration: During the declaration of the attribute itself, we can tag arbitrary other definitions, but once the attribute is declared we must tag things in the same file as normal. -/ structure ParametricAttributeExtra (α : Type) where /-- The underlying `ParametricAttribute`. -/ attr : ParametricAttribute α /-- A list of pre-tagged declarations with their values. -/ base : Std.HashMap Name α deriving Inhabited /-- Registers a new parametric attribute. The `extra` field is a list of definitions from other modules which will be "pre-tagged" and are not subject to the usual restriction on tagging in the same file as the declaration. -/ def registerParametricAttributeExtra (impl : ParametricAttributeImpl α) (extra : List (Name × α)) : IO (ParametricAttributeExtra α) := do let attr ← registerParametricAttribute impl pure { attr, base := extra.foldl (fun s (a, b) => s.insert a b) {} } namespace ParametricAttributeExtra /-- Gets the parameter of attribute `attr` associated to declaration `decl`, or `none` if `decl` is not tagged. -/ def getParam? [Inhabited α] (attr : ParametricAttributeExtra α) (env : Environment) (decl : Name) : Option α := attr.attr.getParam? env decl <|> attr.base[decl]? /-- Applies attribute `attr` to declaration `decl`, given a value for the parameter. -/ def setParam (attr : ParametricAttributeExtra α) (env : Environment) (decl : Name) (param : α) : Except String Environment := attr.attr.setParam env decl param end ParametricAttributeExtra ================================================ FILE: Batteries/Lean/EStateM.lean ================================================ /- Copyright (c) 2024 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module import all Init.Control.EState @[expose] public section namespace EStateM open Backtrackable namespace Result /-- Map a function over an `EStateM.Result`, preserving states and errors. -/ def map {ε σ α β} (f : α → β) (x : Result ε σ α) : Result ε σ β := match x with | .ok a s' => .ok (f a) s' | .error e s' => .error e s' @[simp] theorem map_ok {ε σ α β} (f : α → β) (a : α) (s : σ) : (Result.ok a s : Result ε σ α).map f = .ok (f a) s := rfl @[simp] theorem map_error {ε σ α β} (f : α → β) (e : ε) (s : σ) : (Result.error e s : Result ε σ α).map f = .error e s := rfl @[simp] theorem map_eq_ok {ε σ α β} {f : α → β} {x : Result ε σ α} {b : β} {s : σ} : x.map f = .ok b s ↔ ∃ a, x = .ok a s ∧ b = f a := by cases x <;> simp [and_assoc, and_comm, eq_comm] @[simp] theorem map_eq_error {ε σ α β} (f : α → β) {x : Result ε σ α} {e : ε} {s : σ} : x.map f = .error e s ↔ x = .error e s := by cases x <;> simp [eq_comm] end Result @[simp] theorem dummySave_apply (s : σ) : EStateM.dummySave s = PUnit.unit := rfl @[simp] theorem dummyRestore_apply (s : σ) : EStateM.dummyRestore s = Function.const _ s := rfl @[simp] theorem run'_pure (x : α) (s : σ) : (pure x : EStateM ε σ α).run' s = some x := rfl @[simp] theorem run'_bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) (s : σ) : (x >>= f).run' s = match x.run s with | .ok a s => (f a).run' s | .error _ _ => none := by rw [run', run_bind] cases x.run s <;> rfl @[simp] theorem run_map (f : α → β) (x : EStateM ε σ α) (s : σ) : (f <$> x).run s = (x.run s).map f := rfl @[simp] theorem run'_map (f : α → β) (x : EStateM ε σ α) (s : σ) : (f <$> x).run' s = Option.map f (x.run' s) := by rw [run', run', run_map] cases x.run s <;> rfl theorem run_seq (f : EStateM ε σ (α → β)) (x : EStateM ε σ α) (s : σ) : (f <*> x).run s = match f.run s with | .ok g s => Result.map g (x.run s) | .error e s => .error e s := by simp only [seq_eq_bind_map, run_bind, run_map] cases f.run s <;> rfl theorem run'_seq (f : EStateM ε σ (α → β)) (x : EStateM ε σ α) (s : σ) : (f <*> x).run' s = match f.run s with | .ok g s => Option.map g (x.run' s) | .error _ _ => none := by simp only [seq_eq_bind_map, run'_bind, run'_map] cases f.run s <;> rfl @[simp] theorem run_seqLeft (x : EStateM ε σ α) (y : EStateM ε σ β) (s : σ) : (x <* y).run s = match x.run s with | .ok v s => Result.map (fun _ => v) (y.run s) | .error e s => .error e s := by simp [seqLeft_eq_bind] rfl @[simp] theorem run'_seqLeft (x : EStateM ε σ α) (y : EStateM ε σ β) (s : σ) : (x <* y).run' s = match x.run s with | .ok v s => Option.map (fun _ => v) (y.run' s) | .error _ _ => none := by simp [seqLeft_eq_bind] @[simp] theorem run_seqRight (x : EStateM ε σ α) (y : EStateM ε σ β) (s : σ) : (x *> y).run s = match x.run s with | .ok _ s => y.run s | .error e s => .error e s := rfl @[simp] theorem run'_seqRight (x : EStateM ε σ α) (y : EStateM ε σ β) (s : σ) : (x *> y).run' s = match x.run s with | .ok _ s => y.run' s | .error _ _ => none := by rw [run', run_seqRight] cases x.run s <;> rfl @[simp] theorem run'_get (s : σ) : (get : EStateM ε σ σ).run' s = some s := rfl @[simp] theorem run'_set (v s : σ) : (set v : EStateM ε σ PUnit).run' s = some PUnit.unit := rfl @[simp] theorem run'_modify (f : σ → σ) (s : σ) : (modify f : EStateM ε σ PUnit).run' s = some PUnit.unit := rfl @[simp] theorem run'_modifyGet (f : σ → α × σ) (s : σ) : (modifyGet f : EStateM ε σ α).run' s = some (f s).1 := rfl @[simp] theorem run_getModify (f : σ → σ) : (getModify f : EStateM ε σ σ).run s = Result.ok s (f s) := rfl @[simp] theorem run'_getModify (f : σ → σ) (s : σ) : (getModify f : EStateM ε σ σ).run' s = some s := rfl @[simp] theorem run'_throw (e : ε) (s : σ) : (throw e : EStateM ε σ α).run' s = none := rfl @[simp] theorem run_orElse {δ} [h : Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) (s : σ) : (x₁ <|> x₂).run s = match x₁.run s with | .ok x s => .ok x s | .error _ s' => x₂.run (restore s' (save s)) := by show (EStateM.orElse _ _).run _ = _ unfold EStateM.orElse simp only [EStateM.run] match x₁ s with | .ok _ _ => rfl | .error _ _ => simp @[simp] theorem run'_orElse {δ} [h : Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) (s : σ) : (x₁ <|> x₂).run' s = match x₁.run s with | .ok x _ => some x | .error _ s' => x₂.run' (restore s' (save s)) := by rw [run', run_orElse] cases x₁.run s <;> rfl @[simp] theorem run_tryCatch {δ} [h : Backtrackable δ σ] (body : EStateM ε σ α) (handler : ε → EStateM ε σ α) (s : σ) : (tryCatch body handler).run s = match body.run s with | .ok x s => .ok x s | .error e s' => (handler e).run (restore s' (save s)) := by show (EStateM.tryCatch _ _).run _ = _ unfold EStateM.tryCatch simp only [EStateM.run] cases body s <;> rfl @[simp] theorem run'_tryCatch {δ} [h : Backtrackable δ σ] (body : EStateM ε σ α) (handler : ε → EStateM ε σ α) (s : σ) : (tryCatch body handler).run' s = match body.run s with | .ok x _ => some x | .error e s' => (handler e).run' (restore s' (save s)) := by rw [run', run_tryCatch] cases body.run s <;> rfl @[simp] theorem run'_adaptExcept (f : ε → ε) (x : EStateM ε σ α) (s : σ) : (adaptExcept f x).run' s = x.run' s := by rw [run', run', run_adaptExcept] cases x.run s <;> rfl @[simp] theorem run_tryFinally' (x : EStateM ε σ α) (h : Option α → EStateM ε σ β) (s : σ) : (tryFinally' x h).run s = match x.run s with | .ok a s => match (h (some a)).run s with | .ok b s => Result.ok (a, b) s | .error e s => Result.error e s | .error e₁ s => match (h none).run s with | .ok _ s => Result.error e₁ s | .error e₂ s => Result.error e₂ s := rfl @[simp] theorem run'_tryFinally' (x : EStateM ε σ α) (h : Option α → EStateM ε σ β) (s : σ) : (tryFinally' x h).run' s = match x.run s with | .ok a s => Option.map (a, ·) ((h (some a)).run' s) | .error _ _ => none := by simp [run', run_tryFinally'] match x.run s with | .ok a s => simp only; cases (h (some a)).run s <;> rfl | .error e s => simp only; cases (h none).run s <;> rfl @[simp] theorem run_fromStateM (x : StateM σ α) (s : σ) : (fromStateM x : EStateM ε σ α).run s = Result.ok (x.run s).1 (x.run s).2 := (rfl) @[simp] theorem run'_fromStateM (x : StateM σ α) (s : σ) : (fromStateM x : EStateM ε σ α).run' s = some (x.run' s) := (rfl) @[ext] theorem ext {ε σ α} {x y : EStateM ε σ α} (h : ∀ s, x.run s = y.run s) : x = y := by funext s exact h s end EStateM ================================================ FILE: Batteries/Lean/Except.lean ================================================ /- Copyright (c) 2023 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Lean.Util.Trace @[expose] public section open Lean deriving instance DecidableEq for Except namespace Except /-- Visualize an `Except` using a checkmark or a cross. -/ def emoji : Except ε α → String | .error _ => crossEmoji | .ok _ => checkEmoji @[simp] theorem map_error {ε : Type u} (f : α → β) (e : ε) : f <$> (.error e : Except ε α) = .error e := rfl @[simp] theorem map_ok {ε : Type u} (f : α → β) (x : α) : f <$> (.ok x : Except ε α) = .ok (f x) := rfl /-- Map a function over an `Except` value, using a proof that the value is `.ok`. -/ def pmap {ε : Type u} {α β : Type v} (x : Except ε α) (f : (a : α) → x = .ok a → β) : Except ε β := match x with | .error e => .error e | .ok a => .ok (f a rfl) @[simp] theorem pmap_error {ε : Type u} {α β : Type v} (e : ε) (f : (a : α) → Except.error e = Except.ok a → β) : Except.pmap (.error e) f = .error e := rfl @[simp] theorem pmap_ok {ε : Type u} {α β : Type v} (a : α) (f : (a' : α) → (.ok a : Except ε α) = .ok a' → β) : Except.pmap (.ok a) f = .ok (f a rfl) := rfl @[simp] theorem pmap_id {ε : Type u} {α : Type v} (x : Except ε α) : x.pmap (fun a _ => a) = x := by cases x <;> simp @[simp] theorem map_pmap (g : β → γ) (x : Except ε α) (f : (a : α) → x = .ok a → β) : g <$> x.pmap f = x.pmap fun a h => g (f a h) := by cases x <;> simp end Except namespace ExceptT -- This will be redundant after nightly-2024-11-08. attribute [ext] ExceptT.ext @[simp] theorem mk_run (x : ExceptT ε m α) : ExceptT.mk (ExceptT.run x) = x := rfl @[simp] theorem map_mk [Monad m] [LawfulMonad m] (f : α → β) (x : m (Except ε α)) : f <$> ExceptT.mk x = ExceptT.mk ((f <$> · ) <$> x) := by simp only [Functor.map, Except.map, ExceptT.map, map_eq_pure_bind] congr funext a split <;> simp end ExceptT ================================================ FILE: Batteries/Lean/Expr.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Lean.Elab.Term public import Lean.Elab.Binders @[expose] public section /-! # Additional operations on Expr and related types This file defines basic operations on the types expr, name, declaration, level, environment. This file is mostly for non-tactics. -/ namespace Lean.Expr open Lean.Elab.Term in /-- Converts an `Expr` into a `Syntax`, by creating a fresh metavariable assigned to the expr and returning a named metavariable syntax `?a`. -/ def toSyntax (e : Expr) : TermElabM Syntax.Term := withFreshMacroScope do let stx ← `(?a) let mvar ← elabTermEnsuringType stx (← Meta.inferType e) mvar.mvarId!.assign e pure stx /-- Like `withApp` but ignores metadata. -/ @[inline] def withApp' (e : Expr) (k : Expr → Array Expr → α) : α := let dummy := mkSort .zero let nargs := e.getAppNumArgs' go e (.replicate nargs dummy) (nargs - 1) where /-- Auxiliary definition for `withApp'`. -/ @[specialize] go : Expr → Array Expr → Nat → α | mdata _ b, as, i => go b as i | app f a , as, i => go f (as.set! i a) (i-1) | f , as, _ => k f as /-- Like `getAppArgs` but ignores metadata. -/ @[inline] def getAppArgs' (e : Expr) : Array Expr := e.withApp' λ _ as => as /-- Like `traverseApp` but ignores metadata. -/ def traverseApp' {m} [Monad m] (f : Expr → m Expr) (e : Expr) : m Expr := e.withApp' λ fn args => return mkAppN (← f fn) (← args.mapM f) /-- Like `withAppRev` but ignores metadata. -/ @[inline] def withAppRev' (e : Expr) (k : Expr → Array Expr → α) : α := go e (Array.mkEmpty e.getAppNumArgs') where /-- Auxiliary definition for `withAppRev'`. -/ @[specialize] go : Expr → Array Expr → α | mdata _ b, as => go b as | app f a , as => go f (as.push a) | f , as => k f as /-- Like `getAppRevArgs` but ignores metadata. -/ @[inline] def getAppRevArgs' (e : Expr) : Array Expr := e.withAppRev' λ _ as => as /-- Like `getRevArgD` but ignores metadata. -/ def getRevArgD' : Expr → Nat → Expr → Expr | mdata _ b, n , v => getRevArgD' b n v | app _ a , 0 , _ => a | app f _ , i+1, v => getRevArgD' f i v | _ , _ , v => v /-- Like `getArgD` but ignores metadata. -/ @[inline] def getArgD' (e : Expr) (i : Nat) (v₀ : Expr) (n := e.getAppNumArgs') : Expr := getRevArgD' e (n - i - 1) v₀ /-- Like `isAppOf` but ignores metadata. -/ def isAppOf' (e : Expr) (n : Name) : Bool := match e.getAppFn' with | const c .. => c == n | _ => false /-- Turns an expression that is a natural number literal into a natural number. -/ def natLit! : Expr → Nat | lit (Literal.natVal v) => v | _ => panic! "nat literal expected" /-- Turns an expression that is a constructor of `Int` applied to a natural number literal into an integer. -/ def intLit! (e : Expr) : Int := if e.isAppOfArity ``Int.ofNat 1 then e.appArg!.natLit! else if e.isAppOfArity ``Int.negOfNat 1 then .negOfNat e.appArg!.natLit! else panic! "not a raw integer literal" open Lean Elab Term in /-- Annotates a `binderIdent` with the binder information from an `fvar`. -/ def addLocalVarInfoForBinderIdent (fvar : Expr) (tk : TSyntax ``binderIdent) : MetaM Unit := -- the only TermElabM thing we do in `addLocalVarInfo` is check inPattern, -- which we assume is always false for this function discard <| TermElabM.run do match tk with | `(binderIdent| $n:ident) => Elab.Term.addLocalVarInfo n fvar | tk => Elab.Term.addLocalVarInfo (Unhygienic.run `(_%$tk)) fvar ================================================ FILE: Batteries/Lean/Float.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module @[expose] public section namespace Float /-- The floating point value "positive infinity", also used to represent numerical computations which produce finite values outside of the representable range of `Float`. -/ def inf : Float := 1/0 /-- The floating point value "not a number", used to represent erroneous numerical computations such as `0 / 0`. Using `nan` in any float operation will return `nan`, and all comparisons involving `nan` return `false`, including in particular `nan == nan`. -/ def nan : Float := 0/0 /-- Returns `v, exp` integers such that `f = v * 2^exp`. (`e` is not minimal, but `v.abs` will be at most `2^53 - 1`.) Returns `none` when `f` is not finite (i.e. `inf`, `-inf` or a `nan`). -/ def toRatParts (f : Float) : Option (Int × Int) := if f.isFinite then let (f', exp) := f.frExp let x := (2^53:Nat).toFloat * f' let v := if x < 0 then (-(-x).floor.toUInt64.toNat : Int) else (x.floor.toUInt64.toNat : Int) some (v, exp - 53) else none /-- Returns `v, exp` integers such that `f = v * 2^exp`. Like `toRatParts`, but `e` is guaranteed to be minimal (`n` is always odd), unless `n = 0`. `n.abs` will be at most `2^53 - 1` because `Float` has 53 bits of precision. Returns `none` when `f` is not finite (i.e. `inf`, `-inf` or a `nan`). -/ partial def toRatParts' (f : Float) : Option (Int × Int) := f.toRatParts.map fun (n, e) => if n == 0 then (0, 0) else let neg : Bool := n < 0 let v := n.natAbs.toUInt64 let c := trailingZeros v 0 let v := (v >>> c.toUInt64).toNat (if neg then -v else v, e + c.toNat) where /-- Calculates the number of trailing bits in a `UInt64`. Requires `v ≠ 0`. -/ -- Note: it's a bit dumb to be using a loop here, but it is hopefully written -- such that LLVM can tell we are computing trailing bits and do good things to it -- TODO: prove termination under suitable assumptions (only relevant if `Float` is not opaque) trailingZeros (v : UInt64) (c : UInt8) := if v &&& 1 == 0 then trailingZeros (v >>> 1) (c + 1) else c /-- Converts `f` to a string, including all decimal digits. -/ def toStringFull (f : Float) : String := if let some (v, exp) := toRatParts f then let v' := v.natAbs let s := if exp ≥ 0 then Nat.repr (v' * (2^exp.toNat:Nat)) else let e := (-exp).toNat let intPart := v' / 2^e let rem := v' % 2^e if rem == 0 then Nat.repr intPart else let rem := Nat.repr ((2^e + v' % 2^e) * 5^e) let rem := rem.dropEndWhile (· == '0') s!"{intPart}.{rem.drop 1}" if v < 0 then s!"-{s}" else s else f.toString -- inf, -inf, nan end Float /-- Divide two natural numbers, to produce a correctly rounded (nearest-ties-to-even) `Float` result. -/ protected def Nat.divFloat (a b : Nat) : Float := if b = 0 then if a = 0 then Float.nan else Float.inf else let ea := a.log2 let eb := b.log2 if eb + 1024 < ea then Float.inf else let eb' := if b <<< ea ≤ a <<< eb then eb else eb + 1 let mantissa : UInt64 := (a <<< (eb' + 53) / b <<< ea).toUInt64 let rounded := if mantissa &&& 3 == 1 && a <<< (eb' + 53) == mantissa.toNat * (b <<< ea) then mantissa >>> 1 else (mantissa + 1) >>> 1 rounded.toFloat.scaleB (ea - (eb' + 52)) /-- Divide two integers, to produce a correctly rounded (nearest-ties-to-even) `Float` result. -/ protected def Int.divFloat (a b : Int) : Float := if (a ≥ 0) == (b ≥ 0) then a.natAbs.divFloat b.natAbs else -a.natAbs.divFloat b.natAbs ================================================ FILE: Batteries/Lean/HashMap.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Std.Data.HashMap.Basic @[expose] public section namespace Std.HashMap variable [BEq α] [Hashable α] /-- `O(|other|)` amortized. Merge two `HashMap`s. The values of keys which appear in both maps are combined using the monadic function `f`. -/ @[specialize] def mergeWithM {m α β} [BEq α] [Hashable α] [Monad m] (f : α → β → β → m β) (self other : HashMap α β) : m (HashMap α β) := other.foldM (init := self) fun map k v₂ => match map[k]? with | none => return map.insert k v₂ | some v₁ => return map.insert k (← f k v₁ v₂) /-- `O(|other|)` amortized. Merge two `HashMap`s. The values of keys which appear in both maps are combined using `f`. -/ @[inline] def mergeWith (f : α → β → β → β) (self other : HashMap α β) : HashMap α β := -- Implementing this function directly, rather than via `mergeWithM`, gives -- us less constrained universes. other.fold (init := self) fun map k v₂ => match map[k]? with | none => map.insert k v₂ | some v₁ => map.insert k <| f k v₁ v₂ ================================================ FILE: Batteries/Lean/HashSet.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Std.Data.HashSet.Basic @[expose] public section namespace Std.HashSet variable [BEq α] [Hashable α] /-- `O(n)`. Returns `true` if `f` returns `true` for any element of the set. -/ @[specialize] def anyM [Monad m] (s : HashSet α) (f : α → m Bool) : m Bool := do for a in s do if ← f a then return true return false /-- `O(n)`. Returns `true` if `f` returns `true` for all elements of the set. -/ @[specialize] def allM [Monad m] (s : HashSet α) (f : α → m Bool) : m Bool := do for a in s do if !(← f a) then return false return true instance : BEq (HashSet α) where beq s t := s.all (t.contains ·) && t.all (s.contains ·) ================================================ FILE: Batteries/Lean/IO/Process.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module @[expose] public section /-! # Running external commands. -/ namespace IO.Process open System (FilePath) /-- Pipe `input` into stdin of the spawned process, then return `(exitCode, stdout, stdErr)` upon completion. -/ def runCmdWithInput' (cmd : String) (args : Array String) (input : String := "") (throwFailure := true) : IO Output := do let child ← spawn { cmd := cmd, args := args, stdin := .piped, stdout := .piped, stderr := .piped } let (stdin, child) ← child.takeStdin stdin.putStr input stdin.flush let stdout ← IO.asTask child.stdout.readToEnd Task.Priority.dedicated let err ← child.stderr.readToEnd let exitCode ← child.wait if exitCode != 0 && throwFailure then throw $ IO.userError err else let out ← IO.ofExcept stdout.get return ⟨exitCode, out, err⟩ /-- Pipe `input` into stdin of the spawned process, then return the entire content of stdout as a `String` upon completion. -/ def runCmdWithInput (cmd : String) (args : Array String) (input : String := "") (throwFailure := true) : IO String := do return (← runCmdWithInput' cmd args input throwFailure).stdout ================================================ FILE: Batteries/Lean/Json.lean ================================================ /- Copyright (c) 2022 E.W.Ayers. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: E.W.Ayers, Mario Carneiro -/ module public import Batteries.Lean.Float public import Lean.Data.Json.FromToJson.Basic @[expose] public section open Lean instance : OfScientific JsonNumber where ofScientific mantissa exponentSign decimalExponent := if exponentSign then { mantissa := mantissa, exponent := decimalExponent } else { mantissa := (mantissa * 10 ^ decimalExponent : Nat), exponent := 0 } instance : Neg JsonNumber where neg jn := ⟨-jn.mantissa, jn.exponent⟩ instance : ToJson Float where toJson x := match x.toRatParts' with | none => Json.null | some (n, d) => if d < 0 then Json.num { mantissa := n * (5^d.natAbs : Nat), exponent := d.natAbs } else Json.num { mantissa := n * (2^d.natAbs : Nat), exponent := 0 } ================================================ FILE: Batteries/Lean/LawfulMonad.lean ================================================ /- Copyright (c) 2024 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Lean.Elab.Command import all Init.System.ST @[expose] public section /-! # Construct `LawfulMonad` instances for the Lean monad stack. -/ open Lean Elab Term Tactic Command instance : LawfulMonad (ST σ) := .mk' _ (id_map := fun x => rfl) (pure_bind := fun x f => rfl) (bind_assoc := fun f g x => rfl) instance : LawfulMonad (EST ε σ) := .mk' _ (id_map := fun x => funext fun v => by dsimp [Functor.map, EST.bind]; cases x v <;> rfl) (pure_bind := fun x f => rfl) (bind_assoc := fun f g x => funext fun v => by dsimp [Bind.bind, EST.bind]; cases f v <;> rfl) instance : LawfulMonad (EIO ε) := inferInstanceAs <| LawfulMonad (EST _ _) instance : LawfulMonad BaseIO := inferInstanceAs <| LawfulMonad (ST _) instance : LawfulMonad IO := inferInstanceAs <| LawfulMonad (EIO _) instance : LawfulMonad CoreM := inferInstanceAs <| LawfulMonad (ReaderT _ <| StateRefT' _ _ (EIO Exception)) instance : LawfulMonad MetaM := inferInstanceAs <| LawfulMonad (ReaderT _ <| StateRefT' _ _ CoreM) instance : LawfulMonad TermElabM := inferInstanceAs <| LawfulMonad (ReaderT _ <| StateRefT' _ _ MetaM) instance : LawfulMonad TacticM := inferInstanceAs <| LawfulMonad (ReaderT _ $ StateRefT' _ _ $ TermElabM) instance : LawfulMonad CommandElabM := inferInstanceAs <| LawfulMonad (ReaderT _ $ StateRefT' _ _ $ EIO _) ================================================ FILE: Batteries/Lean/LawfulMonadLift.lean ================================================ /- Copyright (c) 2025 Quang Dao. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Quang Dao -/ module public import Lean.Elab.Command import all Lean.CoreM -- for unfolding `liftIOCore` import all Init.System.IO -- for unfolding `BaseIO.toEIO` import all Init.Control.StateRef -- for unfolding `StateRefT'.lift` import all Init.System.ST @[expose] public section /-! # Lawful instances of `MonadLift` for the Lean monad stack. -/ open Lean Elab Term Tactic Command instance : LawfulMonadLift (ST σ) (EST ε σ) where monadLift_pure _ := rfl monadLift_bind _ _ := rfl instance : LawfulMonadLift BaseIO (EIO ε) := inferInstanceAs <| LawfulMonadLift (ST IO.RealWorld) (EST ε IO.RealWorld) /-! ### `EIO.adapt` simp lemmas -/ @[simp] theorem EIO.adapt_pure (f : ε₁ → ε₂) (a : α) : EIO.adapt f (pure a : EIO ε₁ α) = (pure a : EIO ε₂ α) := by rfl private theorem EIO.bind_eq_EST_bind (ma : EIO ε α) (f : α → EIO ε β) : (ma >>= f) = EST.bind ma f := by rfl private theorem EIO.adapt_EST_bind (f : ε₁ → ε₂) (ma : EIO ε₁ α) (g : α → EIO ε₁ β) : EIO.adapt f (EST.bind ma g) = EST.bind (EIO.adapt f ma) (fun a => EIO.adapt f (g a)) := by funext s; simp only [EIO.adapt, EST.bind]; cases ma s <;> rfl @[simp] theorem EIO.adapt_bind (f : ε₁ → ε₂) (ma : EIO ε₁ α) (g : α → EIO ε₁ β) : EIO.adapt f (ma >>= g) = EIO.adapt f ma >>= fun a => EIO.adapt f (g a) := by simp only [EIO.bind_eq_EST_bind, EIO.adapt_EST_bind] /-! ### `StateRefT'.lift` simp lemmas -/ @[simp] theorem StateRefT'.lift_pure [Monad m] (a : α) : (StateRefT'.lift (pure a) : StateRefT' ω σ m α) = pure a := by rfl @[simp] theorem StateRefT'.lift_bind [Monad m] (ma : m α) (f : α → m β) : (StateRefT'.lift (ma >>= f) : StateRefT' ω σ m β) = StateRefT'.lift ma >>= fun a => StateRefT'.lift (f a) := by rfl /-! ### `LawfulMonadLift IO CoreM` -/ private theorem Core.run_liftIOCore (x : IO α) (r : Core.Context) : ReaderT.run (Core.liftIOCore x) r = (StateRefT'.lift (EIO.adapt (fun err => Exception.error r.ref (MessageData.ofFormat (format (toString err)))) x) : StateRefT' IO.RealWorld Core.State (EIO Exception) α) := by rfl instance : LawfulMonadLift IO CoreM where monadLift_pure a := by ext r simp [MonadLift.monadLift, Core.run_liftIOCore] monadLift_bind ma f := by ext r simp [MonadLift.monadLift, Core.run_liftIOCore] instance : LawfulMonadLiftT (EIO Exception) CommandElabM := inferInstance instance : LawfulMonadLiftT (EIO Exception) CoreM := inferInstance instance : LawfulMonadLiftT CoreM MetaM := inferInstance instance : LawfulMonadLiftT MetaM TermElabM := inferInstance instance : LawfulMonadLiftT TermElabM TacticM := inferInstance ================================================ FILE: Batteries/Lean/Meta/Basic.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Jannis Limperg -/ module public import Lean.Meta.Tactic.Intro public import Batteries.Control.AlternativeMonad import Lean.Meta.SynthInstance public section open Lean Lean.Meta namespace Lean /-- Sort the given `FVarId`s by the order in which they appear in the current local context. If any of the `FVarId`s do not appear in the current local context, the result is unspecified. -/ def Meta.sortFVarsByContextOrder [Monad m] [MonadLCtx m] (hyps : Array FVarId) : m (Array FVarId) := return (← getLCtx).sortFVarsByContextOrder hyps instance : AlternativeMonad Lean.Meta.MetaM where namespace MetavarContext /-- Get the `MetavarDecl` of `mvarId`. If `mvarId` is not a declared metavariable in the given `MetavarContext`, throw an error. -/ def getExprMVarDecl [Monad m] [MonadError m] (mctx : MetavarContext) (mvarId : MVarId) : m MetavarDecl := do if let some mdecl := mctx.decls.find? mvarId then return mdecl else throwError "unknown metavariable '?{mvarId.name}'" /-- Declare a metavariable. You must make sure that the metavariable is not already declared. -/ def declareExprMVar (mctx : MetavarContext) (mvarId : MVarId) (mdecl : MetavarDecl) : MetavarContext := { mctx with decls := mctx.decls.insert mvarId mdecl } /-- Check whether a metavariable is assigned or delayed-assigned. A delayed-assigned metavariable is already 'solved' but the solution cannot be substituted yet because we have to wait for some other metavariables to be assigned first. So in most situations you want to treat a delayed-assigned metavariable as assigned. -/ def isExprMVarAssignedOrDelayedAssigned (mctx : MetavarContext) (mvarId : MVarId) : Bool := mctx.eAssignment.contains mvarId || mctx.dAssignment.contains mvarId /-- Check whether a metavariable is declared in the given `MetavarContext`. -/ def isExprMVarDeclared (mctx : MetavarContext) (mvarId : MVarId) : Bool := mctx.decls.contains mvarId /-- Erase any assignment or delayed assignment of the given metavariable. -/ def eraseExprMVarAssignment (mctx : MetavarContext) (mvarId : MVarId) : MetavarContext := { mctx with eAssignment := mctx.eAssignment.erase mvarId dAssignment := mctx.dAssignment.erase mvarId } /-- Obtain all unassigned metavariables from the given `MetavarContext`. If `includeDelayed` is `true`, delayed-assigned metavariables are considered unassigned. -/ def unassignedExprMVars (mctx : MetavarContext) (includeDelayed := false) : Array MVarId := Id.run do let mut result := #[] for (mvarId, _) in mctx.decls do if ! mctx.eAssignment.contains mvarId && (includeDelayed || ! mctx.dAssignment.contains mvarId) then result := result.push mvarId return result end MetavarContext namespace MVarId /-- Check whether a metavariable is declared. -/ def isDeclared [Monad m] [MonadMCtx m] (mvarId : MVarId) : m Bool := return (← getMCtx).isExprMVarDeclared mvarId /-- Erase any assignment or delayed assignment of the given metavariable. -/ def eraseAssignment [MonadMCtx m] (mvarId : MVarId) : m Unit := modifyMCtx (·.eraseExprMVarAssignment mvarId) /-- Solve a goal by synthesizing an instance. -/ -- FIXME: probably can just be `g.inferInstance` once leanprover/lean4#2054 is fixed def synthInstance (g : MVarId) : MetaM Unit := do g.assign (← Lean.Meta.synthInstance (← g.getType)) /-- Get the type the given metavariable after instantiating metavariables and cleaning up annotations. -/ def getTypeCleanup (mvarId : MVarId) : MetaM Expr := return (← instantiateMVars (← mvarId.getType)).cleanupAnnotations end MVarId namespace Meta /-- Obtain all unassigned metavariables. If `includeDelayed` is `true`, delayed-assigned metavariables are considered unassigned. -/ def getUnassignedExprMVars [Monad m] [MonadMCtx m] (includeDelayed := false) : m (Array MVarId) := return (← getMCtx).unassignedExprMVars (includeDelayed := includeDelayed) /-- Run a computation with hygiene turned off. -/ def unhygienic [MonadWithOptions m] (x : m α) : m α := withOptions (tactic.hygienic.set · false) x /-- A variant of `mkFreshId` which generates names with a particular prefix. The generated names are unique and have the form `.` where `N` is a natural number. They are not suitable as user-facing names. -/ def mkFreshIdWithPrefix [Monad m] [MonadNameGenerator m] («prefix» : Name) : m Name := do let ngen ← getNGen let r := { ngen with namePrefix := «prefix» }.curr setNGen ngen.next pure r /-- `saturate1 goal tac` runs `tac` on `goal`, then on the resulting goals, etc., until `tac` does not apply to any goal any more (i.e. it returns `none`). The order of applications is depth-first, so if `tac` generates goals `[g₁, g₂, ⋯]`, we apply `tac` to `g₁` and recursively to all its subgoals before visiting `g₂`. If `tac` does not apply to `goal`, `saturate1` returns `none`. Otherwise it returns the generated subgoals to which `tac` did not apply. `saturate1` respects the `MonadRecDepth` recursion limit. -/ partial def saturate1 [Monad m] [MonadError m] [MonadRecDepth m] [MonadLiftT (ST IO.RealWorld) m] (goal : MVarId) (tac : MVarId → m (Option (Array MVarId))) : m (Option (Array MVarId)) := do let some goals ← tac goal | return none let acc ← ST.mkRef #[] goals.forM (go acc) return some (← acc.get) where /-- Auxiliary definition for `saturate1`. -/ go (acc : IO.Ref (Array MVarId)) (goal : MVarId) : m Unit := withIncRecDepth do match ← tac goal with | none => acc.modify fun s => s.push goal | some goals => goals.forM (go acc) ================================================ FILE: Batteries/Lean/Meta/DiscrTree.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg, Kim Morrison -/ module public import Lean.Meta.DiscrTree public import Batteries.Data.Array.Merge public import Batteries.Lean.Meta.Expr public import Batteries.Lean.PersistentHashMap @[expose] public section namespace Lean.Meta.DiscrTree namespace Key /-- Compare two `Key`s. The ordering is total but otherwise arbitrary. (It uses `Name.quickCmp` internally.) -/ protected def cmp : Key → Key → Ordering | .lit v₁, .lit v₂ => compare v₁ v₂ | .fvar n₁ a₁, .fvar n₂ a₂ => n₁.name.quickCmp n₂.name |>.then <| compare a₁ a₂ | .const n₁ a₁, .const n₂ a₂ => n₁.quickCmp n₂ |>.then <| compare a₁ a₂ | .proj s₁ i₁ a₁, .proj s₂ i₂ a₂ => s₁.quickCmp s₂ |>.then <| compare i₁ i₂ |>.then <| compare a₁ a₂ | k₁, k₂ => compare k₁.ctorIdx k₂.ctorIdx instance : Ord Key := ⟨Key.cmp⟩ end Key namespace Trie /-- Merge two `Trie`s. Duplicate values are preserved. -/ partial def mergePreservingDuplicates : Trie α → Trie α → Trie α | node vs₁ cs₁, node vs₂ cs₂ => node (vs₁ ++ vs₂) (mergeChildren cs₁ cs₂) where /-- Auxiliary definition for `mergePreservingDuplicates`. -/ mergeChildren (cs₁ cs₂ : Array (Key × Trie α)) : Array (Key × Trie α) := Array.mergeDedupWith (ord := ⟨compareOn (·.fst)⟩) cs₁ cs₂ (fun (k₁, t₁) (_, t₂) => (k₁, mergePreservingDuplicates t₁ t₂)) end Trie /-- Merge two `DiscrTree`s. Duplicate values are preserved. -/ @[inline] def mergePreservingDuplicates (t u : DiscrTree α) : DiscrTree α := ⟨t.root.mergeWith u.root fun _ trie₁ trie₂ => trie₁.mergePreservingDuplicates trie₂⟩ ================================================ FILE: Batteries/Lean/Meta/Expr.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.Expr @[expose] public section namespace Lean.Literal instance : Ord Literal where compare | natVal n₁, natVal n₂ => compare n₁ n₂ | strVal s₁, strVal s₂ => compare s₁ s₂ | natVal _, strVal _ => .lt | strVal _, natVal _ => .gt ================================================ FILE: Batteries/Lean/Meta/Inaccessible.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.Meta.Basic @[expose] public section open Lean Lean.Meta Std /-- Obtain the inaccessible fvars from the given local context. An fvar is inaccessible if (a) its user name is inaccessible or (b) it is shadowed by a later fvar with the same user name. -/ def Lean.LocalContext.inaccessibleFVars (lctx : LocalContext) : Array LocalDecl := let (result, _) := lctx.foldr (β := Array LocalDecl × Std.HashSet Name) (init := (Array.mkEmpty lctx.numIndices, {})) fun ldecl (result, seen) => if ldecl.isImplementationDetail then (result, seen) else let result := if ldecl.userName.hasMacroScopes || seen.contains ldecl.userName then result.push ldecl else result (result, seen.insert ldecl.userName) result.reverse /-- Obtain the inaccessible fvars from the current local context. An fvar is inaccessible if (a) its user name is inaccessible or (b) it is shadowed by a later fvar with the same user name. -/ def Lean.Meta.getInaccessibleFVars [Monad m] [MonadLCtx m] : m (Array LocalDecl) := return (← getLCtx).inaccessibleFVars /-- Rename all inaccessible fvars. An fvar is inaccessible if (a) its user name is inaccessible or (b) it is shadowed by a later fvar with the same user name. This function gives all inaccessible fvars a unique, accessible user name. It returns the new goal and the fvars that were renamed. -/ def Lean.MVarId.renameInaccessibleFVars (mvarId : MVarId) : MetaM (MVarId × Array FVarId) := do let mdecl ← mvarId.getDecl let mut lctx := mdecl.lctx let inaccessibleFVars := lctx.inaccessibleFVars if inaccessibleFVars.isEmpty then return (mvarId, #[]) let mut renamedFVars := Array.mkEmpty lctx.decls.size for ldecl in inaccessibleFVars do let newName := lctx.getUnusedName ldecl.userName lctx := lctx.setUserName ldecl.fvarId newName renamedFVars := renamedFVars.push ldecl.fvarId let newMVar ← mkFreshExprMVarAt lctx mdecl.localInstances mdecl.type mvarId.assign newMVar return (newMVar.mvarId!, renamedFVars) ================================================ FILE: Batteries/Lean/Meta/InstantiateMVars.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Batteries.Lean.Meta.Basic @[expose] public section open Lean Lean.Meta namespace Lean.MVarId /-- Instantiate metavariables in the type of the given metavariable, update the metavariable's declaration and return the new type. -/ def instantiateMVarsInType [Monad m] [MonadMCtx m] [MonadError m] (mvarId : MVarId) : m Expr := do let mdecl ← (← getMCtx).getExprMVarDecl mvarId let type := mdecl.type if type.hasMVar then let type ← instantiateMVars type let mdecl := { mdecl with type } modifyMCtx (·.declareExprMVar mvarId mdecl) return type else return type /-- Instantiate metavariables in the `LocalDecl` of the given fvar, update the `LocalDecl` and return the new `LocalDecl.` -/ def instantiateMVarsInLocalDecl [Monad m] [MonadMCtx m] [MonadError m] (mvarId : MVarId) (fvarId : FVarId) : m LocalDecl := do let mdecl ← (← getMCtx).getExprMVarDecl mvarId let (some ldecl) := mdecl.lctx.find? fvarId | throwError "unknown fvar '{fvarId.name}' (in local context of mvar '?{mvarId.name}')" let ldecl ← Lean.instantiateLocalDeclMVars ldecl let mdecl := { mdecl with lctx := mdecl.lctx.modifyLocalDecl fvarId fun _ => ldecl } modifyMCtx (·.declareExprMVar mvarId mdecl) return ldecl /-- Instantiate metavariables in the local context of the given metavariable, update the metavariable's declaration and return the new local context. -/ def instantiateMVarsInLocalContext [Monad m] [MonadMCtx m] [MonadError m] (mvarId : MVarId) : m LocalContext := do let mdecl ← (← getMCtx).getExprMVarDecl mvarId let lctx ← instantiateLCtxMVars mdecl.lctx modifyMCtx (·.declareExprMVar mvarId { mdecl with lctx }) return lctx /-- Instantiate metavariables in the local context and type of the given metavariable. -/ def instantiateMVars [Monad m] [MonadMCtx m] [MonadError m] (mvarId : MVarId) : m Unit := do discard $ (← getMCtx).getExprMVarDecl mvarId -- The line above throws an error if the `mvarId` is not declared. The line -- below panics. instantiateMVarDeclMVars mvarId end Lean.MVarId ================================================ FILE: Batteries/Lean/Meta/SavedState.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Batteries.Lean.Meta.Basic public import Batteries.Lean.MonadBacktrack @[expose] public section namespace Lean.Meta.SavedState /-- Run the action `x` in state `s`. Returns the result of `x` and the state after `x` was executed. The global state remains unchanged. -/ def runMetaM (s : Meta.SavedState) (x : MetaM α) : MetaM (α × Meta.SavedState) := withoutModifyingState' do restoreState s; x /-- Run the action `x` in state `s`. Returns the result of `x`. The global state remains unchanged. -/ def runMetaM' (s : Meta.SavedState) (x : MetaM α) : MetaM α := withoutModifyingState do restoreState s; x end SavedState /-- Returns the mvars that are not declared in `preState`, but declared and unassigned in `postState`. Delayed-assigned mvars are considered assigned. -/ def getIntroducedExprMVars (preState postState : SavedState) : MetaM (Array MVarId) := do let unassignedPost ← postState.runMetaM' getUnassignedExprMVars preState.runMetaM' do unassignedPost.filterM fun mvarId => return ! (← mvarId.isDeclared) /-- Returns the mvars that are declared but unassigned in `preState`, and assigned in `postState`. Delayed-assigned mvars are considered assigned. -/ def getAssignedExprMVars (preState postState : SavedState) : MetaM (Array MVarId) := do let unassignedPre ← preState.runMetaM' getUnassignedExprMVars postState.runMetaM' do unassignedPre.filterM (·.isAssignedOrDelayedAssigned) end Lean.Meta ================================================ FILE: Batteries/Lean/Meta/Simp.lean ================================================ /- Copyright (c) 2022 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison, Gabriel Ebner, Floris van Doorn -/ module public import Lean.Elab.Tactic.Simp public import Batteries.Tactic.OpenPrivate import all Lean.Elab.Tactic.Simp -- for accessing `mkDischargeWrapper` public section /-! # Helper functions for using the simplifier. [TODO] Reunification of `mkSimpContext'` with core. -/ namespace Lean namespace Meta.Simp open Elab.Tactic /-- Flip the proof in a `Simp.Result`. -/ def mkEqSymm (e : Expr) (r : Simp.Result) : MetaM Simp.Result := ({ expr := e, proof? := · }) <$> match r.proof? with | none => pure none | some p => some <$> Meta.mkEqSymm p /-- Construct the `Expr` `cast h e`, from a `Simp.Result` with proof `h`. -/ def mkCast (r : Simp.Result) (e : Expr) : MetaM Expr := do mkAppM ``cast #[← r.getProof, e] /-- Construct a `Simp.DischargeWrapper` from the `Syntax` for a `simp` discharger. -/ nonrec def mkDischargeWrapper := mkDischargeWrapper -- copied from core /-- If `ctx == false`, the config argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise. If `ctx == false`, the `discharge` option must be none -/ def mkSimpContext' (simpTheorems : SimpTheorems) (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp) (ctx := false) (ignoreStarArg : Bool := false) : TacticM MkSimpContextResult := do if ctx && !stx[2].isNone then if kind == SimpKind.simpAll then throwError "'simp_all' tactic does not support 'discharger' option" if kind == SimpKind.dsimp then throwError "'dsimp' tactic does not support 'discharger' option" let dischargeWrapper ← mkDischargeWrapper stx[2] let simpOnly := !stx[3].isNone let simpTheorems ← if simpOnly then simpOnlyBuiltins.foldlM (·.addConst ·) {} else pure simpTheorems let simprocs ← if simpOnly then pure {} else Simp.getSimprocs let congrTheorems ← Meta.getSimpCongrTheorems let ctx ← Simp.mkContext (← elabSimpConfig stx[1] (kind := kind)) #[simpTheorems] congrTheorems let r ← elabSimpArgs stx[4] (simprocs := #[simprocs]) ctx eraseLocal kind (ignoreStarArg := ignoreStarArg) return { r with dischargeWrapper } end Simp end Lean.Meta ================================================ FILE: Batteries/Lean/Meta/UnusedNames.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.LocalContext public section open Lean Lean.Meta namespace Lean.Name private def parseIndexSuffix (s : String.Slice) : Option Nat := if s.isEmpty then none else if s.front == '_' then s.drop 1 |>.toNat? else none /-- Result type of `Lean.Name.matchUpToIndexSuffix`. See there for details. -/ inductive MatchUpToIndexSuffix /-- Exact match. -/ | exactMatch /-- No match. -/ | noMatch /-- Match up to suffix. -/ | suffixMatch (i : Nat) /-- Succeeds if `n` is equal to `query`, except `n` may have an additional `_i` suffix for some natural number `i`. More specifically: - If `n = query`, the result is `exactMatch`. - If `n = query ++ "_i"` for some natural number `i`, the result is `suffixMatch i`. - Otherwise the result is `noMatch`. -/ def matchUpToIndexSuffix (n : Name) (query : Name) : MatchUpToIndexSuffix := match n, query with | .str pre₁ s₁, .str pre₂ s₂ => if pre₁ != pre₂ then .noMatch else if let some suffix := s₁.dropPrefix? s₂ then if suffix.isEmpty then .exactMatch else if let some i := parseIndexSuffix suffix then .suffixMatch i else .noMatch else .noMatch | n, query => if n == query then .exactMatch else .noMatch end Name namespace LocalContext /-- Obtain the least natural number `i` such that `suggestion ++ "_i"` is an unused name in the given local context. If `suggestion` itself is unused, the result is `none`. -/ def getUnusedUserNameIndex (lctx : LocalContext) (suggestion : Name) : Option Nat := Id.run do let mut minSuffix := none for ldecl in lctx do let hypName := ldecl.userName if hypName.hasMacroScopes then continue match ldecl.userName.matchUpToIndexSuffix suggestion with | .exactMatch => minSuffix := updateMinSuffix minSuffix 1 | .noMatch => continue | .suffixMatch i => minSuffix := updateMinSuffix minSuffix (i + 1) minSuffix where /-- Auxiliary definition for `getUnusedUserNameIndex`. -/ @[inline] updateMinSuffix : Option Nat → Nat → Option Nat | none, j => some j | some i, j => some $ i.max j /-- Obtain a name `n` such that `n` is unused in the given local context and `suggestion` is a prefix of `n`. This is similar to `getUnusedName` but uses a different algorithm which may or may not be faster. -/ def getUnusedUserName (lctx : LocalContext) (suggestion : Name) : Name := let suggestion := suggestion.eraseMacroScopes match lctx.getUnusedUserNameIndex suggestion with | none => suggestion | some i => suggestion.appendIndexAfter i /-- Obtain `n` distinct names such that each name is unused in the given local context and `suggestion` is a prefix of each name. -/ def getUnusedUserNames (lctx : LocalContext) (n : Nat) (suggestion : Name) : Array Name := if n == 0 then #[] else let suggestion := suggestion.eraseMacroScopes let acc := Array.mkEmpty n match lctx.getUnusedUserNameIndex suggestion with | none => loop (acc.push suggestion) (n - 1) 1 | some i => loop acc n i where /-- Auxiliary definition for `getUnusedUserNames`. -/ loop (acc : Array Name) (n i : Nat) : Array Name := match n with | 0 => acc | n + 1 => loop (acc.push $ suggestion.appendIndexAfter i) n (i + 1) end Lean.LocalContext namespace Lean.Meta /-- Obtain a name `n` such that `n` is unused in the current local context and `suggestion` is a prefix of `n`. -/ def getUnusedUserName [Monad m] [MonadLCtx m] (suggestion : Name) : m Name := return (← getLCtx).getUnusedUserName suggestion /-- Obtain `n` distinct names such that each name is unused in the current local context and `suggestion` is a prefix of each name. -/ def getUnusedUserNames [Monad m] [MonadLCtx m] (n : Nat) (suggestion : Name) : m (Array Name) := return (← getLCtx).getUnusedUserNames n suggestion ================================================ FILE: Batteries/Lean/MonadBacktrack.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.Util.MonadBacktrack @[expose] public section namespace Lean /-- Execute the action `x`, then restore the initial state. Returns the state after `x` finished. -/ def withoutModifyingState' [Monad m] [MonadBacktrack s m] [MonadFinally m] (x : m α) : m (α × s) := withoutModifyingState do let result ← x let finalState ← saveState return (result, finalState) end Lean ================================================ FILE: Batteries/Lean/NameMapAttribute.lean ================================================ /- Copyright (c) 2022 E.W.Ayers. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: E.W.Ayers -/ module public import Lean.Attributes @[expose] public section namespace Lean /-- Forward port of lean4#12469 -/ local instance [Inhabited α] : Inhabited (Thunk α) := ⟨.pure default⟩ /-- Environment extension that maps declaration names to `α`. This uses a `Thunk` to avoid computing the name map when it isn't used. -/ def NameMapExtension (α : Type) := SimplePersistentEnvExtension (Name × α) (Thunk (NameMap α)) instance : Inhabited (NameMapExtension α) := inferInstanceAs <| Inhabited (SimplePersistentEnvExtension ..) /-- Look up a value in the given extension in the environment. -/ def NameMapExtension.find? (ext : NameMapExtension α) (env : Environment) : Name → Option α := (SimplePersistentEnvExtension.getState ext env).get.find? /-- Add the given k,v pair to the NameMapExtension. -/ def NameMapExtension.add [Monad M] [MonadEnv M] [MonadError M] (ext : NameMapExtension α) (k : Name) (v : α) : M Unit := do if let some _ := ext.find? (← getEnv) k then throwError "Already exists entry for {ext.name} {k}" else ext.addEntry (← getEnv) (k, v) |> setEnv /-- Registers a new extension with the given name and type. -/ def registerNameMapExtension (α) (name : Name := by exact decl_name%) : IO (NameMapExtension α) := do registerSimplePersistentEnvExtension { name addImportedFn arr := .mk fun _ => arr.foldl (·.insertMany ·) ∅ addEntryFn s n := s.map (·.insert n.1 n.2) } /-- The inputs to `registerNameMapAttribute`. -/ structure NameMapAttributeImpl (α : Type) where /-- The name of the attribute -/ name : Name /-- The declaration which creates the attribute -/ ref : Name := by exact decl_name% /-- The description of the attribute -/ descr : String /-- This function is called when the attribute is applied. It should produce a value of type `α` from the given attribute syntax. -/ add (src : Name) (stx : Syntax) : AttrM α deriving Inhabited /-- Similar to `registerParametricAttribute` except that attributes do not have to be assigned in the same file as the declaration. -/ def registerNameMapAttribute (impl : NameMapAttributeImpl α) : IO (NameMapExtension α) := do let ext ← registerNameMapExtension α impl.ref registerBuiltinAttribute { name := impl.name descr := impl.descr add := fun src stx _kind => do let a : α ← impl.add src stx ext.add src a } return ext ================================================ FILE: Batteries/Lean/PersistentHashMap.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.Data.PersistentHashMap @[expose] public section namespace Lean.PersistentHashMap variable [BEq α] [Hashable α] /-- Builds a `PersistentHashMap` from a list of key-value pairs. Values of duplicated keys are replaced by their respective last occurrences. -/ def ofList (xs : List (α × β)) : PersistentHashMap α β := xs.foldl (init := {}) fun m (k, v) => m.insert k v /-- Variant of `ofList` which accepts a function that combines values of duplicated keys. -/ def ofListWith (xs : List (α × β)) (f : α → β → β → β) : PersistentHashMap α β := xs.foldl (init := {}) fun m (k, v) => match m.find? k with | none => m.insert k v | some v' => m.insert k <| f k v v' /-- Builds a `PersistentHashMap` from an array of key-value pairs. Values of duplicated keys are replaced by their respective last occurrences. -/ def ofArray (xs : Array (α × β)) : PersistentHashMap α β := xs.foldl (init := {}) fun m (k, v) => m.insert k v /-- Variant of `ofArray` which accepts a function that combines values of duplicated keys. -/ def ofArrayWith (xs : Array (α × β)) (f : α → β → β → β) : PersistentHashMap α β := xs.foldl (init := {}) fun m (k, v) => match m.find? k with | none => m.insert k v | some v' => m.insert k <| f k v v' /-- Merge two `PersistentHashMap`s. The values of keys which appear in both maps are combined using the monadic function `f`. -/ @[specialize] def mergeWithM [Monad m] (self other : PersistentHashMap α β) (f : α → β → β → m β) : m (PersistentHashMap α β) := other.foldlM (init := self) fun map k v₂ => match map.find? k with | none => return map.insert k v₂ | some v₁ => return map.insert k (← f k v₁ v₂) /-- Merge two `PersistentHashMap`s. The values of keys which appear in both maps are combined using `f`. -/ @[inline] def mergeWith (self other : PersistentHashMap α β) (f : α → β → β → β) : PersistentHashMap α β := -- Implementing this function directly, rather than via `mergeWithM`, gives -- us less constrained universes. other.foldl (init := self) fun map k v₂ => match map.find? k with | none => map.insert k v₂ | some v₁ => map.insert k <| f k v₁ v₂ ================================================ FILE: Batteries/Lean/PersistentHashSet.lean ================================================ /- Copyright (c) 2022 Jannis Limperg. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jannis Limperg -/ module public import Lean.Data.PersistentHashSet @[expose] public section namespace Lean.PersistentHashSet variable [BEq α] [Hashable α] instance [Monad m] : ForIn m (PersistentHashSet α) α where forIn s init step := do let mut state := init for (k, _) in s.set do match ← step k state with | .done state' => return state' | .yield state' => state := state' return state /-- Returns `true` if `f` returns `true` for any element of the set. -/ @[specialize] def anyM [Monad m] (s : PersistentHashSet α) (f : α → m Bool) : m Bool := do for a in s do if ← f a then return true return false /-- Returns `true` if `f` returns `true` for any element of the set. -/ @[inline] def any (s : PersistentHashSet α) (f : α → Bool) : Bool := Id.run <| s.anyM f /-- Returns `true` if `f` returns `true` for all elements of the set. -/ @[specialize] def allM [Monad m] (s : PersistentHashSet α) (f : α → m Bool) : m Bool := do for a in s do if ! (← f a) then return false return true /-- Returns `true` if `f` returns `true` for all elements of the set. -/ @[inline] def all (s : PersistentHashSet α) (f : α → Bool) : Bool := Id.run <| s.allM f instance : BEq (PersistentHashSet α) where beq s t := s.all (t.contains ·) && t.all (s.contains ·) /-- Insert all elements from a collection into a `PersistentHashSet`. -/ def insertMany [ForIn Id ρ α] (s : PersistentHashSet α) (as : ρ) : PersistentHashSet α := Id.run do let mut s := s for a in as do s := s.insert a return s /-- Obtain a `PersistentHashSet` from an array. -/ @[inline] protected def ofArray [BEq α] [Hashable α] (as : Array α) : PersistentHashSet α := PersistentHashSet.empty.insertMany as /-- Obtain a `PersistentHashSet` from a list. -/ @[inline] protected def ofList [BEq α] [Hashable α] (as : List α) : PersistentHashSet α := PersistentHashSet.empty.insertMany as /-- Merge two `PersistentHashSet`s. -/ @[inline] def merge (s t : PersistentHashSet α) : PersistentHashSet α := s.insertMany t ================================================ FILE: Batteries/Lean/Position.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Thomas R. Murrills -/ module public import Lean.Syntax public import Lean.Data.Lsp.Utf16 public section namespace Lean /-- Return the beginning of the line contatining character `pos`. -/ def findLineStart (s : String) (pos : String.Pos.Raw) : String.Pos.Raw := (s.pos! pos).revFind? '\n' |>.map (·.next!) |>.getD s.startPos |>.offset /-- Return the indentation (number of leading spaces) of the line containing `pos`, and whether `pos` is the first non-whitespace character in the line. -/ def findIndentAndIsStart (s : String) (pos : String.Pos.Raw) : Nat × Bool := let start := findLineStart s pos let body := (s.pos! start).find (· ≠ ' ') |>.offset (start.byteDistance body, body == pos) /-- If `pos` is a `Lean.Position`, then `pos.getDeclsAfter` returns the array of names of declarations whose selection range begins in position at least `pos`. By using the `selectionRange`, which is usually smaller than the `range`, we err on the side of including declarations when possible. By default, this only inspects the local branch of the environment. This is compatible with being used to find declarations from the current command in a linter, where we have already waited for async tasks/parallel branches to complete. Further, since the environment exposed to linters does not include constants added after the elaboration of the current command, it is safe to use this on the command's start position without picking up later declarations. -/ protected def Position.getDeclsAfter (env : Environment) (pos : Position) (asyncMode := EnvExtension.AsyncMode.local) : Array Name := declRangeExt.getState env asyncMode |>.foldl (init := #[]) fun acc name { selectionRange .. } => if selectionRange.pos.lt pos then acc else acc.push name /-- If `pos` is a `String.Pos.Raw`, then `pos.getDeclsAfter` returns the array of names of declarations whose selection range begins in position at least `pos`. By using the `selectionRange`, which is usually smaller than the `range`, we err on the side of including declarations when possible. By default, this is intended for use in linters, where only the current environment branch needs to be checked. See the docstring for `Lean.Position.getDeclsAfter` for details. -/ @[inline] protected def _root_.String.Pos.Raw.getDeclsAfter (env : Environment) (map : FileMap) (pos : String.Pos.Raw) (asyncMode := EnvExtension.AsyncMode.local) : Array Name := map.toPosition pos |>.getDeclsAfter env asyncMode /-- Converts a `DeclarationRange` to a `Syntax.Range`. This assumes that the `DeclarationRange` is sourced in the given `FileMap`. -/ def DeclarationRange.toSyntaxRange (map : FileMap) (range : DeclarationRange) : Syntax.Range := ⟨map.ofPosition range.pos, map.ofPosition range.endPos⟩ /-- Yields the `Syntax.Range` for the declaration `decl` in the current file. If `decl` is not in the current file, yields `none`. By default, this provides the "selection range", which is usually the declaration's identifier or e.g. the `instance` token for an unnamed instance. If `fullRange` is instead set to `true`, this returns the full declaration range (which includes modifiers, such as the docstring). -/ def findDeclarationSyntaxRange? {m : Type → Type} [Monad m] [MonadEnv m] [MonadLiftT BaseIO m] [MonadFileMap m] (decl : Name) (fullRange := false) : m (Option Syntax.Range) := do if (← getEnv).isImportedConst decl then return none let some ranges ← findDeclarationRanges? decl | return none return (if fullRange then ranges.range else ranges.selectionRange).toSyntaxRange (← getFileMap) /-- Runs `x` with a synthetic ref that has position info locating the given `decl` if it is defined in the current file, or else runs `x` without modifying the ref. This is useful for logging on a declaration's name from within linters. By default, this uses the "selection range" of the declaration, which is usually the declaration's identifier or e.g. the `instance` token for an unnamed instance. (This is also the place that receives hovers for the declaration.) If `fullRange` is instead set to `true`, this uses the full declaration range, which includes the modifiers (such as the docstring, if there is one) and the body of the declaration. `canonical` applies to the synthetic syntax generated for the ref; see `Syntax.ofRange`. -/ @[always_inline, inline] def withDeclRef? {α} {m : Type → Type} [Monad m] [MonadEnv m] [MonadLiftT BaseIO m] [MonadFileMap m] [MonadRef m] (decl : Name) (x : m α) (fullRange := false) (canonical := true) : m α := do let some range ← findDeclarationSyntaxRange? decl fullRange | x withRef (.ofRange range canonical) x end Lean ================================================ FILE: Batteries/Lean/SatisfiesM.lean ================================================ /- Copyright (c) 2024 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module public import Batteries.Classes.SatisfiesM public import Batteries.Lean.LawfulMonad public import Lean.Elab.Command import all Init.System.ST @[expose] public section /-! # Construct `MonadSatisfying` instances for the Lean monad stack. -/ open Lean Elab Term Tactic Command -- Note: as of nightly-2025-10-23, after https://github.com/leanprover/lean4/pull/10625 -- these instances need to be re-implemented. -- instance : MonadSatisfying (EIO ε) := inferInstanceAs <| MonadSatisfying (EStateM _ _) -- instance : MonadSatisfying BaseIO := inferInstanceAs <| MonadSatisfying (EIO _) -- instance : MonadSatisfying IO := inferInstanceAs <| MonadSatisfying (EIO _) -- instance : MonadSatisfying (EST ε σ) := inferInstanceAs <| MonadSatisfying (EStateM _ _) -- instance : MonadSatisfying CoreM := -- inferInstanceAs <| MonadSatisfying (ReaderT _ <| StateRefT' _ _ (EIO _)) -- instance : MonadSatisfying MetaM := -- inferInstanceAs <| MonadSatisfying (ReaderT _ <| StateRefT' _ _ CoreM) -- instance : MonadSatisfying TermElabM := -- inferInstanceAs <| MonadSatisfying (ReaderT _ <| StateRefT' _ _ MetaM) -- instance : MonadSatisfying TacticM := -- inferInstanceAs <| MonadSatisfying (ReaderT _ $ StateRefT' _ _ TermElabM) -- instance : MonadSatisfying CommandElabM := -- inferInstanceAs <| MonadSatisfying (ReaderT _ $ StateRefT' _ _ (EIO _)) ================================================ FILE: Batteries/Lean/Syntax.lean ================================================ /- Copyright (c) 2022 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public import Lean.Syntax @[expose] public section /-! # Helper functions for working with typed syntaxes. -/ namespace Lean /-- Applies the given function to every subsyntax. Like `Syntax.replaceM` but for typed syntax. (Note there are no guarantees of type correctness here.) -/ def TSyntax.replaceM [Monad M] (f : Syntax → M (Option Syntax)) (stx : TSyntax k) : M (TSyntax k) := .mk <$> stx.1.replaceM f ================================================ FILE: Batteries/Lean/System/IO.lean ================================================ /- Copyright (c) 2023 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ module @[expose] public section /-! # Functions for manipulating a list of tasks * `IO.waitAny'` is a wrapper for `IO.waitAny` that also returns the remaining tasks. * `List.waitAll : List (Task α) → Task (List α)` gathers a list of tasks into a task returning the list of all results. -/ set_option autoImplicit true -- duplicated from `lean4/src/Init/System/IO.lean` local macro "nonempty_list" : tactic => `(tactic| exact Nat.zero_lt_succ _) /-- Given a list of tasks, create the task returning the list of results, by waiting for each. -/ def List.waitAll (tasks : List (Task α)) : Task (List α) := match tasks with | [] => .pure [] | task :: tasks => task.bind (prio := .max) fun a => tasks.waitAll.map (prio := .max) fun as => a :: as ================================================ FILE: Batteries/Lean/TagAttribute.lean ================================================ /- Copyright (c) 2022 Gabriel Ebner. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public import Lean.Attributes @[expose] public section /-- Get the list of declarations tagged with the tag attribute `attr`. -/ def Lean.TagAttribute.getDecls (attr : TagAttribute) (env : Environment) : Array Name := core <| attr.ext.toEnvExtension.getState env where /-- Implementation of `TagAttribute.getDecls`. -/ core (st : PersistentEnvExtensionState Name NameSet) : Array Name := Id.run do let mut decls := st.state.toArray for ds in st.importedEntries do decls := decls ++ ds decls ================================================ FILE: Batteries/Lean/Util/EnvSearch.lean ================================================ /- Copyright (c) 2021 Shing Tak Lam. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Shing Tak Lam, Daniel Selsam, Mario Carneiro -/ module public import Batteries.Tactic.Lint.Misc namespace Lean /-- Find constants in current environment that match find options and predicate. -/ public meta def getMatchingConstants {m} [Monad m] [MonadEnv m] (p : ConstantInfo → m Bool) (includeImports := true) : m (Array ConstantInfo) := do let matches_ ← if includeImports then (← getEnv).constants.map₁.foldM (init := #[]) check else pure #[] (← getEnv).constants.map₂.foldlM (init := matches_) check where /-- Check constant should be returned -/ @[nolint unusedArguments] check matches_ (_name : Name) cinfo := do if ← p cinfo then pure $ matches_.push cinfo else pure matches_ ================================================ FILE: Batteries/Linter/UnnecessarySeqFocus.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Command public meta import Batteries.Lean.AttributeExtra public meta import Lean.Linter.Basic public meta section namespace Batteries.Linter open Lean Elab Command Linter Std /-- Enables the 'unnecessary `<;>`' linter. This will warn whenever the `<;>` tactic combinator is used when `;` would work. ``` example : True := by apply id <;> trivial ``` The `<;>` is unnecessary here because `apply id` only makes one subgoal. Prefer `apply id; trivial` instead. In some cases, the `<;>` is syntactically necessary because a single tactic is expected: ``` example : True := by cases () with apply id <;> apply id | unit => trivial ``` In this case, you should use parentheses, as in `(apply id; apply id)`: ``` example : True := by cases () with (apply id; apply id) | unit => trivial ``` -/ register_option linter.unnecessarySeqFocus : Bool := { defValue := true descr := "enable the 'unnecessary <;>' linter" } example : True := by cases () with apply id <;> apply id | unit => trivial namespace UnnecessarySeqFocus /-- Gets the value of the `linter.unnecessarySeqFocus` option. -/ def getLinterUnnecessarySeqFocus (o : LinterOptions) : Bool := getLinterValue linter.unnecessarySeqFocus o /-- The `multigoal` attribute keeps track of tactics that operate on multiple goals, meaning that `tac` acts differently from `focus tac`. This is used by the 'unnecessary `<;>`' linter to prevent false positives where `tac <;> tac'` cannot be replaced by `(tac; tac')` because the latter would expose `tac` to a different set of goals. -/ initialize multigoalAttr : TagAttributeExtra ← registerTagAttributeExtra `multigoal "this tactic acts on multiple goals" [ ``Parser.Tactic.«tacticNext_=>_», ``Parser.Tactic.allGoals, ``Parser.Tactic.anyGoals, ``Parser.Tactic.case, ``Parser.Tactic.case', ``Parser.Tactic.Conv.«convNext__=>_», ``Parser.Tactic.Conv.allGoals, ``Parser.Tactic.Conv.anyGoals, ``Parser.Tactic.Conv.case, ``Parser.Tactic.Conv.case', ``Parser.Tactic.rotateLeft, ``Parser.Tactic.rotateRight, ``Parser.Tactic.show, ``Parser.Tactic.tacticStop_ ] /-- The information we record for each `<;>` node appearing in the syntax. -/ structure Entry where /-- The `<;>` node itself. -/ stx : Syntax /-- * `true`: this `<;>` has been used unnecessarily at least once * `false`: it has never been executed * If it has been used properly at least once, the entry is removed from the table. -/ used : Bool /-- The monad for collecting used tactic syntaxes. -/ abbrev M (ω) := StateRefT (Std.HashMap Lean.Syntax.Range Entry) (ST ω) /-- True if this is a `<;>` node in either `tactic` or `conv` classes. -/ @[inline] def isSeqFocus (k : SyntaxNodeKind) : Bool := k == ``Parser.Tactic.«tactic_<;>_» || k == ``Parser.Tactic.Conv.«conv_<;>_» /-- Accumulates the set of tactic syntaxes that should be evaluated at least once. -/ @[specialize] partial def getTactics {ω} (stx : Syntax) : M ω Unit := do if let .node _ k args := stx then if isSeqFocus k then let r := stx.getRange? true if let some r := r then modify fun m => m.insert r { stx, used := false } args.forM getTactics /-- Traverse the info tree down a given path. Each `(n, i)` means that the array must have length `n` and we will descend into the `i`'th child. -/ def getPath : Info → PersistentArray InfoTree → List ((n : Nat) × Fin n) → Option Info | i, _, [] => some i | _, c, ⟨n, i, h⟩::ns => if e : c.size = n then if let .node i c' := c[i] then getPath i c' ns else none else none mutual variable (env : Environment) /-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/ partial def markUsedTacticsList (trees : PersistentArray InfoTree) : M ω Unit := trees.forM markUsedTactics /-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/ partial def markUsedTactics : InfoTree → M ω Unit | .node i c => do if let .ofTacticInfo i := i then if let some r := i.stx.getRange? true then if let some entry := (← get)[r]? then if i.stx.getKind == ``Parser.Tactic.«tactic_<;>_» then let isBad := do unless i.goalsBefore.length == 1 || !multigoalAttr.hasTag env i.stx[0].getKind do none -- Note: this uses the exact sequence of tactic applications -- in the macro expansion of `<;> : tactic` let .ofTacticInfo i ← getPath (.ofTacticInfo i) c [⟨1, 0⟩, ⟨2, 1⟩, ⟨1, 0⟩, ⟨5, 0⟩] | none guard <| i.goalsAfter.length == 1 modify fun s => if isBad.isSome then s.insert r { entry with used := true } else s.erase r else if i.stx.getKind == ``Parser.Tactic.Conv.«conv_<;>_» then let isBad := do unless i.goalsBefore.length == 1 || !multigoalAttr.hasTag env i.stx[0].getKind do none -- Note: this uses the exact sequence of tactic applications -- in the macro expansion of `<;> : conv` let .ofTacticInfo i ← getPath (.ofTacticInfo i) c [⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨2, 1⟩, ⟨1, 0⟩, ⟨5, 0⟩] | none guard <| i.goalsAfter.length == 1 modify fun s => if isBad.isSome then s.insert r { entry with used := true } else s.erase r markUsedTacticsList c | .context _ t => markUsedTactics t | .hole _ => pure () end @[inherit_doc Batteries.Linter.linter.unnecessarySeqFocus] def unnecessarySeqFocusLinter : Linter where run := withSetOptionIn fun stx => do unless getLinterUnnecessarySeqFocus (← getLinterOptions) && (← getInfoState).enabled do return if (← get).messages.hasErrors then return let trees ← getInfoTrees let env ← getEnv let go {ω} : M ω Unit := do getTactics stx markUsedTacticsList env trees let (_, map) := runST fun _ => go.run {} let unused := map.fold (init := #[]) fun acc r { stx, used } => if used then acc.push (stx[1].getRange?.getD r, stx[1]) else acc let key (r : Lean.Syntax.Range) := (r.start.byteIdx, (-r.stop.byteIdx : Int)) let mut last : Lean.Syntax.Range := ⟨0, 0⟩ for (r, stx) in let _ := @lexOrd; let _ := @ltOfOrd.{0}; unused.qsort (key ·.1 < key ·.1) do if last.start ≤ r.start && r.stop ≤ last.stop then continue logLint linter.unnecessarySeqFocus stx "Used `tac1 <;> tac2` where `(tac1; tac2)` would suffice" last := r initialize addLinter unnecessarySeqFocusLinter ================================================ FILE: Batteries/Linter/UnreachableTactic.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Command public meta import Lean.Parser.Syntax public meta import Init.Try public meta import Batteries.Tactic.Unreachable public meta import Lean.Linter.Basic public meta section namespace Batteries.Linter open Lean Elab Command Linter Std /-- Enables the 'unreachable tactic' linter. This will warn on any tactics that are never executed. For example, in `example : True := by trivial <;> done`, the tactic `done` is never executed because `trivial` produces no subgoals; you could put `sorry` or `apply I_don't_exist` or anything else there and no error would result. A common source of such things is `simp <;> tac` in the case that `simp` improves and closes a subgoal that was previously being closed by `tac`. -/ register_option linter.unreachableTactic : Bool := { defValue := true descr := "enable the 'unreachable tactic' linter" } namespace UnreachableTactic /-- Gets the value of the `linter.unreachableTactic` option. -/ def getLinterUnreachableTactic (o : LinterOptions) : Bool := getLinterValue linter.unreachableTactic o /-- The monad for collecting used tactic syntaxes. -/ abbrev M := StateRefT (Std.HashMap Lean.Syntax.Range Syntax) IO /-- A list of blacklisted syntax kinds, which are expected to have subterms that contain unevaluated tactics. -/ initialize ignoreTacticKindsRef : IO.Ref NameHashSet ← IO.mkRef <| (∅ : NameHashSet) |>.insert ``Parser.Term.binderTactic |>.insert ``Lean.Parser.Term.dynamicQuot |>.insert ``Lean.Parser.Tactic.quotSeq |>.insert ``Lean.Parser.Tactic.tacticStop_ |>.insert ``Lean.Parser.Command.notation |>.insert ``Lean.Parser.Command.mixfix |>.insert ``Lean.Parser.Command.registerTryTactic |>.insert ``Lean.Parser.Tactic.discharger /-- Is this a syntax kind that contains intentionally unevaluated tactic subterms? -/ def isIgnoreTacticKind (ignoreTacticKinds : NameHashSet) (k : SyntaxNodeKind) : Bool := match k with | .str _ "quot" => true | _ => ignoreTacticKinds.contains k /-- Adds a new syntax kind whose children will be ignored by the `unreachableTactic` linter. This should be called from an `initialize` block. -/ def addIgnoreTacticKind (kind : SyntaxNodeKind) : IO Unit := ignoreTacticKindsRef.modify (·.insert kind) variable (ignoreTacticKinds : NameHashSet) (isTacKind : SyntaxNodeKind → Bool) in /-- Accumulates the set of tactic syntaxes that should be evaluated at least once. -/ @[specialize] partial def getTactics (stx : Syntax) : M Unit := do if let .node _ k args := stx then if !isIgnoreTacticKind ignoreTacticKinds k then args.forM getTactics if isTacKind k then if let some r := stx.getRange? true then modify fun m => m.insert r stx mutual variable (isTacKind : SyntaxNodeKind → Bool) /-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/ partial def eraseUsedTacticsList (trees : PersistentArray InfoTree) : M Unit := trees.forM eraseUsedTactics /-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/ partial def eraseUsedTactics : InfoTree → M Unit | .node i c => do if let .ofTacticInfo i := i then if let some r := i.stx.getRange? true then modify (·.erase r) eraseUsedTacticsList c | .context _ t => eraseUsedTactics t | .hole _ => pure () end @[inherit_doc Batteries.Linter.linter.unreachableTactic] def unreachableTacticLinter : Linter where run := withSetOptionIn fun stx => do unless getLinterUnreachableTactic (← getLinterOptions) && (← getInfoState).enabled do return if (← get).messages.hasErrors then return let cats := (Parser.parserExtension.getState (← getEnv)).categories -- These lookups may fail when the linter is run in a fresh, empty environment let some tactics := Parser.ParserCategory.kinds <$> cats.find? `tactic | return let some convs := Parser.ParserCategory.kinds <$> cats.find? `conv | return let trees ← getInfoTrees let go : M Unit := do getTactics (← ignoreTacticKindsRef.get) (fun k => tactics.contains k || convs.contains k) stx eraseUsedTacticsList trees let (_, map) ← go.run {} let unreachable := map.toArray let key (r : Lean.Syntax.Range) := (r.start.byteIdx, (-r.stop.byteIdx : Int)) let mut last : Lean.Syntax.Range := ⟨0, 0⟩ for (r, stx) in let _ := @lexOrd; let _ := @ltOfOrd.{0}; unreachable.qsort (key ·.1 < key ·.1) do if stx.getKind ∈ [``Batteries.Tactic.unreachable, ``Batteries.Tactic.unreachableConv] then continue if last.start ≤ r.start && r.stop ≤ last.stop then continue logLint linter.unreachableTactic stx "this tactic is never executed" last := r initialize addLinter unreachableTacticLinter ================================================ FILE: Batteries/Linter.lean ================================================ module public meta import Batteries.Linter.UnreachableTactic public meta import Batteries.Linter.UnnecessarySeqFocus ================================================ FILE: Batteries/Logic.lean ================================================ /- Copyright (c) 2014 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Leonardo de Moura, Jeremy Avigad, Floris van Doorn, Mario Carneiro -/ module public import Batteries.Tactic.Alias @[expose] public section instance {f : α → β} [DecidablePred p] : DecidablePred (p ∘ f) := inferInstanceAs <| DecidablePred fun x => p (f x) /-! ## id -/ theorem Function.id_def : @id α = fun x => x := rfl /-! ## decidable -/ protected alias ⟨Decidable.exists_not_of_not_forall, _⟩ := Decidable.not_forall /-! ## classical logic -/ namespace Classical alias ⟨exists_not_of_not_forall, _⟩ := not_forall end Classical /-! ## equality -/ theorem heq_iff_eq {a b : α} : a ≍ b ↔ a = b := ⟨eq_of_heq, heq_of_eq⟩ @[simp] theorem eq_rec_constant {α : Sort _} {a a' : α} {β : Sort _} (y : β) (h : a = a') : (@Eq.rec α a (fun _ _ => β) y a' h) = y := by cases h; rfl theorem congrArg₂ (f : α → β → γ) {x x' : α} {y y' : β} (hx : x = x') (hy : y = y') : f x y = f x' y' := by subst hx hy; rfl theorem congrFun₂ {β : α → Sort _} {γ : ∀ a, β a → Sort _} {f g : ∀ a b, γ a b} (h : f = g) (a : α) (b : β a) : f a b = g a b := congrFun (congrFun h _) _ theorem congrFun₃ {β : α → Sort _} {γ : ∀ a, β a → Sort _} {δ : ∀ a b, γ a b → Sort _} {f g : ∀ a b c, δ a b c} (h : f = g) (a : α) (b : β a) (c : γ a b) : f a b c = g a b c := congrFun₂ (congrFun h _) _ _ theorem funext₂ {β : α → Sort _} {γ : ∀ a, β a → Sort _} {f g : ∀ a b, γ a b} (h : ∀ a b, f a b = g a b) : f = g := funext fun _ => funext <| h _ theorem funext₃ {β : α → Sort _} {γ : ∀ a, β a → Sort _} {δ : ∀ a b, γ a b → Sort _} {f g : ∀ a b c, δ a b c} (h : ∀ a b c, f a b c = g a b c) : f = g := funext fun _ => funext₂ <| h _ protected theorem Eq.congr (h₁ : x₁ = y₁) (h₂ : x₂ = y₂) : x₁ = x₂ ↔ y₁ = y₂ := by subst h₁; subst h₂; rfl theorem Eq.congr_left {x y z : α} (h : x = y) : x = z ↔ y = z := by rw [h] theorem Eq.congr_right {x y z : α} (h : x = y) : z = x ↔ z = y := by rw [h] alias congr_arg := congrArg alias congr_arg₂ := congrArg₂ alias congr_fun := congrFun alias congr_fun₂ := congrFun₂ alias congr_fun₃ := congrFun₃ theorem heq_of_cast_eq : ∀ (e : α = β) (_ : cast e a = a'), a ≍ a' | rfl, rfl => .rfl theorem cast_eq_iff_heq : cast e a = a' ↔ a ≍ a' := ⟨heq_of_cast_eq _, fun h => by cases h; rfl⟩ theorem eqRec_eq_cast {α : Sort _} {a : α} {motive : (a' : α) → a = a' → Sort _} (x : motive a rfl) {a' : α} (e : a = a') : @Eq.rec α a motive x a' e = cast (e ▸ rfl) x := by subst e; rfl --Porting note: new theorem. More general version of `eqRec_heq` theorem eqRec_heq_self {α : Sort _} {a : α} {motive : (a' : α) → a = a' → Sort _} (x : motive a rfl) {a' : α} (e : a = a') : @Eq.rec α a motive x a' e ≍ x := by subst e; rfl @[simp] theorem eqRec_heq_iff_heq {α : Sort _} {a : α} {motive : (a' : α) → a = a' → Sort _} {x : motive a rfl} {a' : α} {e : a = a'} {β : Sort _} {y : β} : @Eq.rec α a motive x a' e ≍ y ↔ x ≍ y := by subst e; rfl @[simp] theorem heq_eqRec_iff_heq {α : Sort _} {a : α} {motive : (a' : α) → a = a' → Sort _} {x : motive a rfl} {a' : α} {e : a = a'} {β : Sort _} {y : β} : y ≍ @Eq.rec α a motive x a' e ↔ y ≍ x := by subst e; rfl /-! ## miscellaneous -/ @[simp] theorem not_nonempty_empty : ¬Nonempty Empty := fun ⟨h⟩ => h.elim @[simp] theorem not_nonempty_pempty : ¬Nonempty PEmpty := fun ⟨h⟩ => h.elim -- TODO(Mario): profile first, this is a dangerous instance -- instance (priority := 10) {α} [Subsingleton α] : DecidableEq α -- | a, b => isTrue (Subsingleton.elim a b) -- TODO(Mario): profile adding `@[simp]` to `eq_iff_true_of_subsingleton` /-- If all points are equal to a given point `x`, then `α` is a subsingleton. -/ theorem subsingleton_of_forall_eq (x : α) (h : ∀ y, y = x) : Subsingleton α := ⟨fun a b => h a ▸ h b ▸ rfl⟩ theorem subsingleton_iff_forall_eq (x : α) : Subsingleton α ↔ ∀ y, y = x := ⟨fun _ y => Subsingleton.elim y x, subsingleton_of_forall_eq x⟩ theorem congr_eqRec {β : α → Sort _} (f : (x : α) → β x → γ) (h : x = x') (y : β x) : f x' (Eq.rec y h) = f x y := by cases h; rfl ================================================ FILE: Batteries/Tactic/Alias.lean ================================================ /- Copyright (c) 2017 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, David Renshaw, François G. Dorais -/ module public meta import Lean.Elab.Command public meta import Lean.Elab.DeclarationRange public meta import Lean.Compiler.NoncomputableAttr public meta import Lean.DocString public meta import Batteries.CodeAction.Deprecated public meta section /-! # The `alias` command The `alias` command is used to create synonyms. The plain command can create a synonym of any declaration. There is also a version to create synonyms for the forward and reverse implications of an iff theorem. -/ namespace Batteries.Tactic.Alias open Lean Elab Parser.Command /-- An alias can be in one of three forms -/ inductive AliasInfo where /-- Plain alias -/ | plain (n : Name) /-- Forward direction of an iff alias -/ | forward (n : Name) /-- Reverse direction of an iff alias -/ | reverse (n : Name) deriving Inhabited /-- The name underlying an alias target -/ def AliasInfo.name : AliasInfo → Name | plain n => n | forward n => n | reverse n => n /-- The docstring for an alias. -/ def AliasInfo.toString : AliasInfo → String | plain n => s!"**Alias** of `{n}`." | forward n => s!"**Alias** of the forward direction of `{n}`." | reverse n => s!"**Alias** of the reverse direction of `{n}`." /-- Environment extension for registering aliases -/ initialize aliasExt : MapDeclarationExtension AliasInfo ← mkMapDeclarationExtension /-- Get the alias information for a name -/ def getAliasInfo [Monad m] [MonadEnv m] (name : Name) : m (Option AliasInfo) := do return aliasExt.find? (← getEnv) name /-- Set the alias info for a new declaration -/ def setAliasInfo [MonadEnv m] (info : AliasInfo) (declName : Name) : m Unit := modifyEnv (aliasExt.insert · declName info) /-- Updates the `deprecated` declaration to point to `target` if no target is provided. -/ def setDeprecatedTarget (target : Name) (arr : Array Attribute) : Array Attribute × Bool := StateT.run (m := Id) (s := false) do arr.mapM fun s => do if s.name == `deprecated then if let `(deprecated| deprecated%$tk $[$desc:str]? $[(since := $since)]?) := s.stx then set true let stx := Unhygienic.run `(deprecated| deprecated%$tk $(mkCIdent target) $[$desc:str]? $[(since := $since)]?) pure { s with stx } else pure s else pure s /-- The command `alias name := target` creates a synonym of `target` with the given name. The command `alias ⟨fwd, rev⟩ := target` creates synonyms for the forward and reverse directions of an iff theorem. Use `_` if only one direction is required. These commands accept all modifiers and attributes that `def` and `theorem` do. -/ elab (name := alias) mods:declModifiers "alias " alias:ident " := " name:ident : command => do Lean.withExporting (isExporting := (← Command.getScope).isPublic) do Command.liftTermElabM do let name ← realizeGlobalConstNoOverloadWithInfo name let cinfo ← getConstInfo name let declMods ← elabModifiers mods Lean.withExporting (isExporting := declMods.isInferredPublic (← getEnv)) do let (attrs, machineApplicable) := setDeprecatedTarget name declMods.attrs let env ← getEnv let declMods := { declMods with computeKind := if isNoncomputable env name then .noncomputable else if isMarkedMeta env name then .meta else declMods.computeKind isUnsafe := declMods.isUnsafe || cinfo.isUnsafe attrs } let (declName, _) ← mkDeclName (← getCurrNamespace) declMods alias.getId let decl : Declaration := if wasOriginallyTheorem (← getEnv) name then .thmDecl { cinfo.toConstantVal with name := declName value := mkConst name (cinfo.toConstantVal.levelParams.map mkLevelParam) } else .defnDecl { cinfo.toConstantVal with name := declName value := mkConst name (cinfo.levelParams.map mkLevelParam) hints := .regular 0 -- FIXME safety := if declMods.isUnsafe then .unsafe else .safe } checkNotAlreadyDeclared declName addDecl decl if !declMods.isNoncomputable then if declMods.isMeta then modifyEnv (markMeta · declName) compileDecl decl addDeclarationRangesFromSyntax declName (← getRef) alias Term.addTermInfo' alias (← mkConstWithLevelParams declName) (isBinder := true) if let some (doc, isVerso) := declMods.docString? then addDocStringOf isVerso declName (mkNullNode #[]) doc enableRealizationsForConst declName Term.applyAttributes declName declMods.attrs let info := (← getAliasInfo name).getD <| AliasInfo.plain name setAliasInfo info declName if machineApplicable then modifyEnv (machineApplicableDeprecated.tag · declName) /- alias doesn't trigger the missing docs linter so we add a default. We can't just check `declMods` because a docstring may have been added by an attribute. -/ if (← findDocString? (← getEnv) declName).isNone then let mut doc := info.toString if let some origDoc ← findDocString? (← getEnv) name then doc := s!"{doc}\n\n---\n\n{origDoc}" addDocStringCore declName doc /-- Given a possibly forall-quantified iff expression `prf`, produce a value for one of the implication directions (determined by `mp`). -/ def mkIffMpApp (mp : Bool) (ty prf : Expr) : MetaM Expr := do Meta.forallTelescope ty fun xs ty => do let some (lhs, rhs) := ty.iff? | throwError "Target theorem must have the form `∀ x y z, a ↔ b`" Meta.mkLambdaFVars xs <| mkApp3 (mkConst (if mp then ``Iff.mp else ``Iff.mpr)) lhs rhs (mkAppN prf xs) private def addSide (mp : Bool) (declName : Name) (declMods : Modifiers) (thm : ConstantInfo) : TermElabM Unit := do checkNotAlreadyDeclared declName let value ← mkIffMpApp mp thm.type (mkConst thm.name (thm.levelParams.map mkLevelParam)) let type ← Meta.inferType value addDecl <| Declaration.thmDecl { name := declName value := value type := type levelParams := thm.levelParams } if let some (doc, isVerso) := declMods.docString? then addDocStringOf isVerso declName (mkNullNode #[]) doc Term.applyAttributes declName declMods.attrs let info := match ← getAliasInfo thm.name with | some (.plain name) => if mp then AliasInfo.forward name else AliasInfo.reverse name | _ => if mp then AliasInfo.forward thm.name else AliasInfo.reverse thm.name setAliasInfo info declName /- alias doesn't trigger the missing docs linter so we add a default. We can't just check `declMods` because a docstring may have been added by an attribute. -/ if (← findDocString? (← getEnv) declName).isNone then let mut doc := info.toString if let some origDoc ← findDocString? (← getEnv) thm.name then doc := s!"{doc}\n\n---\n\n{origDoc}" addDocStringCore declName doc @[inherit_doc «alias»] elab (name := aliasLR) mods:declModifiers "alias " "⟨" aliasFwd:binderIdent ", " aliasRev:binderIdent "⟩" " := " name:ident : command => do Lean.withExporting (isExporting := (← Command.getScope).isPublic) do Command.liftTermElabM do let name ← realizeGlobalConstNoOverloadWithInfo name let declMods ← elabModifiers mods let declMods := { declMods with attrs := (setDeprecatedTarget name declMods.attrs).1 } Lean.withExporting (isExporting := declMods.isInferredPublic (← getEnv)) do let thm ← getConstInfo name if let `(binderIdent| $idFwd:ident) := aliasFwd then let (declName, _) ← mkDeclName (← getCurrNamespace) declMods idFwd.getId addSide true declName declMods thm addDeclarationRangesFromSyntax declName (← getRef) idFwd Term.addTermInfo' idFwd (← mkConstWithLevelParams declName) (isBinder := true) if let `(binderIdent| $idRev:ident) := aliasRev then let (declName, _) ← mkDeclName (← getCurrNamespace) declMods idRev.getId addSide false declName declMods thm addDeclarationRangesFromSyntax declName (← getRef) idRev Term.addTermInfo' idRev (← mkConstWithLevelParams declName) (isBinder := true) ================================================ FILE: Batteries/Tactic/Basic.lean ================================================ module public meta import Lean.Elab.Tactic.ElabTerm public meta import Batteries.Linter public meta import Batteries.Tactic.Init public meta import Batteries.Tactic.SeqFocus public meta import Batteries.Util.ProofWanted -- This is an import only file for common tactics used throughout Batteries ================================================ FILE: Batteries/Tactic/Case.lean ================================================ /- Copyright (c) 2023 Kyle Miller. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kyle Miller -/ module public meta import Lean.Elab.Tactic.BuiltinTactic public meta import Lean.Elab.Tactic.RenameInaccessibles public meta section /-! # Extensions to the `case` tactic Adds a variant of `case` that looks for a goal with a particular type, rather than a goal with a particular tag. For consistency with `case`, it takes a tag as well, but the tag can be a hole `_`. Also adds `case'` extensions. -/ namespace Batteries.Tactic open Lean Meta Elab Tactic /-- Clause for a `case ... : ...` tactic. -/ syntax casePattArg := Parser.Tactic.caseArg (" : " term)? /-- The body of a `case ... | ...` tactic that's a tactic sequence (or hole). -/ syntax casePattTac := " => " (hole <|> syntheticHole <|> tacticSeq) /-- The body of a `case ... | ...` tactic that's an exact term. -/ syntax casePattExpr := " := " colGt term /-- The body of a `case ... : ...` tactic. -/ syntax casePattBody := casePattTac <|> casePattExpr /-- * `case _ : t => tac` finds the first goal that unifies with `t` and then solves it using `tac` or else fails. Like `show`, it changes the type of the goal to `t`. The `_` can optionally be a case tag, in which case it only looks at goals whose tag would be considered by `case` (goals with an exact tag match, followed by goals with the tag as a suffix, followed by goals with the tag as a prefix). * `case _ n₁ ... nₘ : t => tac` additionally names the `m` most recent hypotheses with inaccessible names to the given names. The names are renamed before matching against `t`. The `_` can optionally be a case tag. * `case _ : t := e` is short for `case _ : t => exact e`. * `case _ : t₁ | _ : t₂ | ... => tac` is equivalent to `(case _ : t₁ => tac); (case _ : t₂ => tac); ...` but with all matching done on the original list of goals -- each goal is consumed as they are matched, so patterns may repeat or overlap. * `case _ : t` will make the matched goal be the first goal. `case _ : t₁ | _ : t₂ | ...` makes the matched goals be the first goals in the given order. * `case _ : t := _` and `case _ : t := ?m` are the same as `case _ : t` but in the `?m` case the goal tag is changed to `m`. In particular, the goal becomes metavariable `?m`. -/ -- Low priority so that type-free `case` doesn't conflict with core `case`, -- though it should be a drop-in replacement. syntax (name := casePatt) (priority := low) "case " sepBy1(casePattArg, " | ") (casePattBody)? : tactic macro_rules | `(tactic| case $[$ps:casePattArg]|* := $t) => `(tactic| case $[$ps:casePattArg]|* => exact $t) | `(tactic| case $[$ps:casePattArg]|*) => `(tactic| case $[$ps:casePattArg]|* => ?_) /-- `case' _ : t => tac` is similar to the `case _ : t => tac` tactic, but it does not ensure the goal has been solved after applying `tac`, nor does it admit the goal if `tac` failed. Recall that `case` closes the goal using `sorry` when `tac` fails, and the tactic execution is not interrupted. -/ syntax (name := casePatt') (priority := low) "case' " sepBy1(casePattArg, " | ") casePattTac : tactic /-- Filter the `mvarIds` by tag. Returns those `MVarId`s that have `tag` either as its user name, as a suffix of its user name, or as a prefix of its user name. The results are sorted in this order. This is like `Lean.Elab.Tactic.findTag?` but it returns all results rather than just the first. -/ private def filterTag (mvarIds : List MVarId) (tag : Name) : TacticM (List MVarId) := do let gs ← mvarIds.toArray.filterMapM fun mvarId => do let userName := (← mvarId.getDecl).userName if tag == userName then return some (0, mvarId) else if tag.isSuffixOf userName then return some (1, mvarId) else if tag.isPrefixOf userName then return some (2, mvarId) else return none -- Insertion sort is a stable sort: let gs := gs.insertionSort (·.1 < ·.1) return gs |>.map (·.2) |>.toList /-- Find the first goal among those matching `tag` whose type unifies with `patt`. The `renameI` array consists of names to use to rename inaccessibles. The `patt` term is elaborated in the context where the inaccessibles have been renamed. Returns the found goal, goals caused by elaborating `patt`, and the remaining goals. -/ def findGoalOfPatt (gs : List MVarId) (tag : TSyntax ``binderIdent) (patt? : Option Term) (renameI : TSyntaxArray `Lean.binderIdent) : TacticM (MVarId × List MVarId × List MVarId) := Term.withoutErrToSorry do let fgs ← match tag with | `(binderIdent|$tag:ident) => filterTag gs tag.getId | _ => pure gs for g in fgs do let gs := gs.erase g if let some patt := patt? then let s ← saveState try let g ← renameInaccessibles g renameI -- Make a copy of `g` so that we don't assign type hints to `g` if we don't need to. let gCopy ← g.withContext <| mkFreshExprSyntheticOpaqueMVar (← g.getType) (← g.getTag) let g' :: gs' ← run gCopy.mvarId! <| withoutRecover <| evalTactic (← `(tactic| refine_lift show $patt from ?_)) | throwNoGoalsToBeSolved -- This should not happen -- Avoid assigning the type hint if the original type and the new type are -- defeq at reducible transparency. if ← g.withContext <| withReducible <| isDefEq (← g.getType) (← g'.getType) then g.assign (.mvar g') else g.assign gCopy return (g', gs', gs) catch _ => restoreState s else let g ← renameInaccessibles g renameI return (g, [], gs) throwError "\ No goals with tag {tag} unify with the term {patt?.getD (← `(_))}, \ or too many names provided for renaming inaccessible variables." /-- Given a `casePattBody`, either give a synthetic hole or a tactic sequence (along with the syntax for the `=>`). Converts holes into synthetic holes since they are processed with `elabTermWithHoles`. -/ def processCasePattBody (stx : TSyntax ``casePattTac) : TacticM (Term ⊕ (Syntax × TSyntax ``Parser.Tactic.tacticSeq)) := do match stx with | `(casePattTac| => $t:hole) => return Sum.inl ⟨← withRef t `(?_)⟩ | `(casePattTac| => $t:syntheticHole) => return Sum.inl ⟨t⟩ | `(casePattTac| =>%$arr $tac:tacticSeq) => return Sum.inr (arr, tac) | _ => throwUnsupportedSyntax /-- Implementation for `case` and `case'`. -/ def evalCase (close : Bool) (stx : Syntax) (tags : Array (TSyntax `Lean.binderIdent)) (hss : Array (TSyntaxArray `Lean.binderIdent)) (patts? : Array (Option Term)) (caseBody : TSyntax `Batteries.Tactic.casePattTac) : TacticM Unit := do let body ← processCasePattBody caseBody -- Accumulated goals in the hole cases. let mut acc : List MVarId := [] -- Accumulated goals from refining patterns let mut pattref : List MVarId := [] for tag in tags, hs in hss, patt? in patts? do let (g, gs', gs) ← findGoalOfPatt (← getUnsolvedGoals) tag patt? hs setGoals gs pattref := pattref ++ gs' match body with | Sum.inl hole => let gs' ← run g <| withRef hole do let (val, gs') ← elabTermWithHoles hole (← getMainTarget) `case unless ← occursCheck g val do throwError "\ 'case' tactic failed, value{indentExpr val}\n\ depends on the main goal metavariable '{Expr.mvar g}'" g.assign val setGoals gs' acc := acc ++ gs' | Sum.inr (arr, tac) => if close then if tag matches `(binderIdent|$_:ident) then -- If a tag is provided, follow the behavior of the core `case` tactic and clear the tag. g.setTag .anonymous discard <| run g do withCaseRef arr tac do closeUsingOrAdmit (withTacticInfoContext stx (evalTactic tac)) else let mvarTag ← g.getTag let gs' ← run g <| withCaseRef arr tac (evalTactic tac) if let [g'] := gs' then -- If a single goal is remaining, follow the core `case'` tactic and preserve the tag. g'.setTag mvarTag acc := acc ++ gs' setGoals (acc ++ pattref ++ (← getUnsolvedGoals)) elab_rules : tactic | `(tactic| case $[$tags $hss* $[: $patts?]?]|* $caseBody:casePattTac) => do evalCase (close := true) (← getRef) tags hss patts? caseBody elab_rules : tactic | `(tactic| case' $[$tags $hss* $[: $patts?]?]|* $caseBody:casePattTac) => do evalCase (close := false) (← getRef) tags hss patts? caseBody ================================================ FILE: Batteries/Tactic/Congr.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Miyahara Kō -/ module public meta import Lean.Meta.Tactic.Congr public meta import Lean.Elab.Tactic.Config public meta import Lean.Elab.Tactic.Ext public meta import Lean.Elab.Tactic.RCases public meta section /-! # `congr with` tactic, `rcongr` tactic -/ namespace Batteries.Tactic open Lean Meta Elab Tactic /-- Configuration options for `congr` & `rcongr` -/ structure Congr.Config where /-- If `closePre := true`, it will attempt to close new goals using `Eq.refl`, `HEq.refl`, and `assumption` with reducible transparency. -/ closePre : Bool := true /-- If `closePost := true`, it will try again on goals on which `congr` failed to make progress with default transparency. -/ closePost : Bool := true /-- Function elaborating `Congr.Config` -/ declare_config_elab Congr.elabConfig Congr.Config @[inherit_doc Lean.Parser.Tactic.congr] syntax (name := congrConfig) "congr" Parser.Tactic.config (ppSpace num)? : tactic /-- Apply congruence (recursively) to goals of the form `⊢ f as = f bs` and `⊢ f as ≍ f bs`. * `congr n` controls the depth of the recursive applications. This is useful when `congr` is too aggressive in breaking down the goal. For example, given `⊢ f (g (x + y)) = f (g (y + x))`, `congr` produces the goals `⊢ x = y` and `⊢ y = x`, while `congr 2` produces the intended `⊢ x + y = y + x`. * If, at any point, a subgoal matches a hypothesis then the subgoal will be closed. * You can use `congr with p (: n)?` to call `ext p (: n)?` to all subgoals generated by `congr`. For example, if the goal is `⊢ f '' s = g '' s` then `congr with x` generates the goal `x : α ⊢ f x = g x`. -/ syntax (name := congrConfigWith) "congr" (Parser.Tactic.config)? (ppSpace colGt num)? " with" (ppSpace colGt rintroPat)* (" : " num)? : tactic elab_rules : tactic | `(tactic| congr $cfg:config $[$n?]?) => do let config ← Congr.elabConfig (mkOptionalNode cfg) let hugeDepth := 1000000 let depth := n?.map (·.getNat) |>.getD hugeDepth liftMetaTactic fun mvarId => mvarId.congrN depth (closePre := config.closePre) (closePost := config.closePost) macro_rules | `(tactic| congr $(cfg)? $(depth)? with $ps* $[: $n]?) => match cfg with | none => `(tactic| congr $(depth)? <;> ext $ps* $[: $n]?) | some cfg => `(tactic| congr $cfg $(depth)? <;> ext $ps* $[: $n]?) /-- Recursive core of `rcongr`. Calls `ext pats <;> congr` and then itself recursively, unless `ext pats <;> congr` made no progress. -/ partial def rcongrCore (g : MVarId) (config : Congr.Config) (pats : List (TSyntax `rcasesPat)) (acc : Array MVarId) : TermElabM (Array MVarId) := do let mut acc := acc for (g, qs) in (← Ext.extCore g pats (failIfUnchanged := false)).2 do let s ← saveState let gs ← g.congrN 1000000 (closePre := config.closePre) (closePost := config.closePost) if ← not <$> g.isAssigned <||> gs.anyM fun g' => return (← g'.getType).eqv (← g.getType) then s.restore acc := acc.push g else for g in gs do acc ← rcongrCore g config qs acc pure acc /-- Repeatedly apply `congr` and `ext`, using the given patterns as arguments for `ext`. There are two ways this tactic stops: * `congr` fails (makes no progress), after having already applied `ext`. * `congr` canceled out the last usage of `ext`. In this case, the state is reverted to before the `congr` was applied. For example, when the goal is ``` ⊢ (fun x => f x + 3) '' s = (fun x => g x + 3) '' s ``` then `rcongr x` produces the goal ``` x : α ⊢ f x = g x ``` This gives the same result as `congr; ext x; congr`. In contrast, `congr` would produce ``` ⊢ (fun x => f x + 3) = (fun x => g x + 3) ``` and `congr with x` (or `congr; ext x`) would produce ``` x : α ⊢ f x + 3 = g x + 3 ``` -/ elab (name := rcongr) "rcongr" cfg:((Parser.Tactic.config)?) ps:(ppSpace colGt rintroPat)* : tactic => do let gs ← rcongrCore (← getMainGoal) (← Congr.elabConfig cfg) (RCases.expandRIntroPats ps).toList #[] replaceMainGoal gs.toList ================================================ FILE: Batteries/Tactic/Exact.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Batteries.Tactic.Alias public meta section /-! # `exact` tactic (`MetaM` version) -/ open Lean Meta /-- `MetaM` version of `Lean.Elab.Tactic.evalExact`: add `mvarId := x` to the metavariable assignment. This method wraps `Lean.MVarId.assign`, checking whether `mvarId` is already assigned, and whether the expression has the right type. -/ def Lean.MVarId.assignIfDefEq (g : MVarId) (e : Expr) : MetaM Unit := do guard <| ← isDefEq (← g.getType) (← inferType e) g.checkNotAssigned `assignIfDefEq g.assign e @[deprecated (since := "2025-04-09")] alias Lean.MVarId.assignIfDefeq := Lean.MVarId.assignIfDefEq ================================================ FILE: Batteries/Tactic/GeneralizeProofs.lean ================================================ /- Copyright (c) 2022 Alex J. Best. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Alex J. Best, Kyle Miller -/ module public meta import Lean.Elab.Tactic.Location public meta import Batteries.Lean.Expr /-! # The `generalize_proofs` tactic Generalize any proofs occurring in the goal or in chosen hypotheses, replacing them by local hypotheses. When these hypotheses are named, this makes it easy to refer to these proofs later in a proof, commonly useful when dealing with functions like `Classical.choose` that produce data from proofs. It is also useful to eliminate proof terms to handle issues with dependent types. For example: ```lean def List.nthLe {α} (l : List α) (n : ℕ) (_h : n < l.length) : α := sorry example : List.nthLe [1, 2] 1 (by simp) = 2 := by -- ⊢ [1, 2].nthLe 1 ⋯ = 2 generalize_proofs h -- h : 1 < [1, 2].length -- ⊢ [1, 2].nthLe 1 h = 2 ``` The tactic is similar in spirit to `Lean.Meta.AbstractNestedProofs` in core. One difference is that it the tactic tries to propagate expected types so that we get `1 < [1, 2].length` in the above example rather than `1 < Nat.succ 1`. -/ public meta section namespace Batteries.Tactic open Lean Meta Elab Parser.Tactic Elab.Tactic initialize registerTraceClass `Tactic.generalize_proofs namespace GeneralizeProofs /-- Configuration for the `generalize_proofs` tactic. -/ structure Config where /-- The maximum recursion depth when generalizing proofs. When `maxDepth > 0`, then proofs are generalized from the types of the generalized proofs too. -/ maxDepth : Nat := 8 /-- When `abstract` is `true`, then the tactic will create universally quantified proofs to account for bound variables. When it is `false` then such proofs are left alone. -/ abstract : Bool := true /-- (Debugging) When `true`, enables consistency checks. -/ debug : Bool := false /-- Elaborates a `Parser.Tactic.config` for `generalize_proofs`. -/ declare_config_elab elabConfig Config /-- State for the `MGen` monad. -/ structure GState where /-- Mapping from propositions to an fvar in the local context with that type. -/ propToFVar : ExprMap Expr /-- Monad used to generalize proofs. Carries `Mathlib.Tactic.GeneralizeProofs.Config` and `Mathlib.Tactic.GeneralizeProofs.State`. -/ abbrev MGen := ReaderT Config <| StateRefT GState MetaM /-- Inserts a prop/fvar pair into the `propToFVar` map. -/ def MGen.insertFVar (prop fvar : Expr) : MGen Unit := modify fun s => { s with propToFVar := s.propToFVar.insert prop fvar } /-- Context for the `MAbs` monad. -/ structure AContext where /-- The local fvars corresponding to bound variables. Abstraction needs to be sure that these variables do not appear in abstracted terms. -/ fvars : Array Expr := #[] /-- A copy of `propToFVar` from `GState`. -/ propToFVar : ExprMap Expr /-- The recursion depth, for how many times `visit` is called from within `visitProof. -/ depth : Nat := 0 /-- The initial local context, for resetting when recursing. -/ initLCtx : LocalContext /-- The tactic configuration. -/ config : Config /-- State for the `MAbs` monad. -/ structure AState where /-- The prop/proof triples to add to the local context. The proofs must not refer to fvars in `fvars`. -/ generalizations : Array (Expr × Expr) := #[] /-- Map version of `generalizations`. Use `MAbs.findProof?` and `MAbs.insertProof`. -/ propToProof : ExprMap Expr := {} /-- Monad used to abstract proofs, to prepare for generalization. Has a cache (of expr/type? pairs), and it also has a reader context `Mathlib/Tactic/GeneralizeProofs/AContext.lean` and a state `Mathlib/Tactic/GeneralizeProofs/AState.lean`. -/ abbrev MAbs := ReaderT AContext <| MonadCacheT (Expr × Option Expr) Expr <| StateRefT AState MetaM /-- Runs `MAbs` in `MGen`. Returns the value and the `generalizations`. -/ def MGen.runMAbs {α : Type} (mx : MAbs α) : MGen (α × Array (Expr × Expr)) := do let s ← get let (x, s') ← mx |>.run { initLCtx := ← getLCtx, propToFVar := s.propToFVar, config := (← read) } |>.run |>.run {} return (x, s'.generalizations) /-- Finds a proof of `prop` by looking at `propToFVar` and `propToProof`. -/ def MAbs.findProof? (prop : Expr) : MAbs (Option Expr) := do if let some pf := (← read).propToFVar[prop]? then return pf else return (← get).propToProof[prop]? /-- Generalize `prop`, where `proof` is its proof. -/ def MAbs.insertProof (prop pf : Expr) : MAbs Unit := do if (← read).config.debug then unless ← isDefEq prop (← inferType pf) do throwError "insertProof: proof{indentD pf}does not have type{indentD prop}" unless ← Lean.MetavarContext.isWellFormed (← read).initLCtx pf do throwError "insertProof: proof{indentD pf}\nis not well-formed in the initial context\n\ fvars: {(← read).fvars}" unless ← Lean.MetavarContext.isWellFormed (← read).initLCtx prop do throwError "insertProof: proof{indentD prop}\nis not well-formed in the initial context\n\ fvars: {(← read).fvars}" modify fun s => { s with generalizations := s.generalizations.push (prop, pf) propToProof := s.propToProof.insert prop pf } /-- Runs `x` with an additional local variable. -/ def MAbs.withLocal {α : Type} (fvar : Expr) (x : MAbs α) : MAbs α := withReader (fun r => {r with fvars := r.fvars.push fvar}) x /-- Runs `x` with an increased recursion depth and the initial local context, clearing `fvars`. -/ def MAbs.withRecurse {α : Type} (x : MAbs α) : MAbs α := do withLCtx (← read).initLCtx (← getLocalInstances) do withReader (fun r => {r with fvars := #[], depth := r.depth + 1}) x /-- Computes expected types for each argument to `f`, given that the type of `mkAppN f args` is supposed to be `ty?` (where if `ty?` is none, there's no type to propagate inwards). -/ def appArgExpectedTypes (f : Expr) (args : Array Expr) (ty? : Option Expr) : MetaM (Array (Option Expr)) := withTransparency .all <| withNewMCtxDepth do -- Try using the expected type, but (*) below might find a bad solution (guard ty?.isSome *> go f args ty?) <|> go f args none where /-- Core implementation for `appArgExpectedTypes`. -/ go (f : Expr) (args : Array Expr) (ty? : Option Expr) : MetaM (Array (Option Expr)) := do -- Metavariables for each argument to `f`: let mut margs := #[] -- The current type of `mAppN f margs`: let mut fty ← inferType f -- Whether we have already unified the type `ty?` with `fty` (once `margs` is filled) let mut unifiedFTy := false for h : i in [0 : args.size] do unless i < margs.size do let (margs', _, fty') ← forallMetaBoundedTelescope fty (args.size - i) if margs'.isEmpty then throwError "could not make progress at argument {i}" fty := fty' margs := margs ++ margs' let arg := args[i] let marg := margs[i]! if !unifiedFTy && margs.size == args.size then if let some ty := ty? then unifiedFTy := (← observing? <| isDefEq fty ty).getD false -- (*) unless ← isDefEq (← inferType marg) (← inferType arg) do throwError s!"failed isDefEq types {i}, {← ppExpr marg}, {← ppExpr arg}" unless ← isDefEq marg arg do throwError s!"failed isDefEq values {i}, {← ppExpr marg}, {← ppExpr arg}" unless ← marg.mvarId!.isAssigned do marg.mvarId!.assign arg margs.mapM fun marg => do -- Note: all mvars introduced by `appArgExpectedTypes` are assigned by this point -- so there is no mvar leak. return (← instantiateMVars (← inferType marg)).cleanupAnnotations /-- Does `mkLambdaFVars fvars e` but 1. zeta reduces let bindings 2. only includes used fvars 3. returns the list of fvars that were actually abstracted -/ def mkLambdaFVarsUsedOnly (fvars : Array Expr) (e : Expr) : MetaM (Array Expr × Expr) := do let mut e := e let mut fvars' : List Expr := [] for i' in [0:fvars.size] do let i := fvars.size - i' - 1 let fvar := fvars[i]! e ← mkLambdaFVars #[fvar] e match e with | .letE _ _ v b _ => e := b.instantiate1 v | .lam _ _ b _ => if b.hasLooseBVars then fvars' := fvar :: fvars' else e := b | _ => unreachable! return (fvars'.toArray, e) /-- Abstract proofs occurring in the expression. A proof is *abstracted* if it is of the form `f a b ...` where `a b ...` are bound variables (that is, they are variables that are not present in the initial local context) and where `f` contains no bound variables. In this form, `f` can be immediately lifted to be a local variable and generalized. The abstracted proofs are recorded in the state. This function is careful to track the type of `e` based on where it's used, since the inferred type might be different. For example, `(by simp : 1 < [1, 2].length)` has `1 < Nat.succ 1` as the inferred type, but from knowing it's an argument to `List.nthLe` we can deduce `1 < [1, 2].length`. -/ partial def abstractProofs (e : Expr) (ty? : Option Expr) : MAbs Expr := do if (← read).depth ≤ (← read).config.maxDepth then MAbs.withRecurse <| visit (← instantiateMVars e) ty? else return e where /-- Core implementation of `abstractProofs`. -/ visit (e : Expr) (ty? : Option Expr) : MAbs Expr := do trace[Tactic.generalize_proofs] "visit (fvars := {(← read).fvars}) e is {e}" if (← read).config.debug then if let some ty := ty? then unless ← isDefEq (← inferType e) ty do throwError "visit: type of{indentD e}\nis not{indentD ty}" if e.isAtomic then return e else checkCache (e, ty?) fun _ => do if ← isProof e then visitProof e ty? else match e with | .forallE n t b i => withLocalDecl n i (← visit t none) fun x => MAbs.withLocal x do mkForallFVars #[x] (← visit (b.instantiate1 x) none) | .lam n t b i => do withLocalDecl n i (← visit t none) fun x => MAbs.withLocal x do let ty'? ← if let some ty := ty? then let .forallE _ _ tyB _ ← whnfD ty | throwError "Expecting forall in abstractProofs .lam" pure <| some <| tyB.instantiate1 x else pure none mkLambdaFVars #[x] (← visit (b.instantiate1 x) ty'?) | .letE n t v b nondep => let t' ← visit t none mapLetDecl n t' (← visit v t') (nondep := nondep) fun x => MAbs.withLocal x do visit (b.instantiate1 x) ty? | .app .. => e.withApp fun f args => do let f' ← visit f none let argTys ← appArgExpectedTypes f' args ty? let mut args' := #[] for arg in args, argTy in argTys do args' := args'.push <| ← visit arg argTy return mkAppN f' args' | .mdata _ b => return e.updateMData! (← visit b ty?) -- Giving up propagating expected types for `.proj`, which we shouldn't see anyway: | .proj _ _ b => return e.updateProj! (← visit b none) | _ => unreachable! /-- Core implementation of abstracting a proof. -/ visitProof (e : Expr) (ty? : Option Expr) : MAbs Expr := do let eOrig := e let fvars := (← read).fvars -- Strip metadata and beta reduce, in case there are some false dependencies let e := e.withApp' fun f args => f.beta args -- If head is atomic and arguments are bound variables, then it's already abstracted. if e.withApp' fun f args => f.isAtomic && args.all fvars.contains then return e -- Abstract `fvars` out of `e` to make the abstracted proof `pf` -- The use of `mkLambdaFVarsUsedOnly` is *key* to make sure that the fvars in `fvars` -- don't leak into the expression, since that would poison the cache in `MonadCacheT`. let e ← if let some ty := ty? then if (← read).config.debug then unless ← isDefEq ty (← inferType e) do throwError m!"visitProof: incorrectly propagated type{indentD ty}\nfor{indentD e}" mkExpectedTypeHint e ty else pure e trace[Tactic.generalize_proofs] "before mkLambdaFVarsUsedOnly, e = {e}\nfvars={fvars}" if (← read).config.debug then unless ← Lean.MetavarContext.isWellFormed (← getLCtx) e do throwError m!"visitProof: proof{indentD e}\nis not well-formed in the current context\n\ fvars: {fvars}" let (fvars', pf) ← mkLambdaFVarsUsedOnly fvars e if !(← read).config.abstract && !fvars'.isEmpty then trace[Tactic.generalize_proofs] "'abstract' is false and proof uses fvars, not abstracting" return eOrig trace[Tactic.generalize_proofs] "after mkLambdaFVarsUsedOnly, pf = {pf}\nfvars'={fvars'}" if (← read).config.debug then unless ← Lean.MetavarContext.isWellFormed (← read).initLCtx pf do throwError m!"visitProof: proof{indentD pf}\nis not well-formed in the initial context\n\ fvars: {fvars}\n{(← mkFreshExprMVar none).mvarId!}" let pfTy ← instantiateMVars (← inferType pf) -- Visit the proof type to normalize it and abstract more proofs let pfTy ← abstractProofs pfTy none -- Check if there is already a recorded proof for this proposition. trace[Tactic.generalize_proofs] "finding {pfTy}" if let some pf' ← MAbs.findProof? pfTy then trace[Tactic.generalize_proofs] "found proof" return mkAppN pf' fvars' -- Record the proof in the state and return the proof. MAbs.insertProof pfTy pf trace[Tactic.generalize_proofs] "added proof" return mkAppN pf fvars' /-- Create a mapping of all propositions in the local context to their fvars. -/ def initialPropToFVar : MetaM (ExprMap Expr) := do -- Visit decls in reverse order so that in case there are duplicates, -- earlier proofs are preferred (← getLCtx).foldrM (init := {}) fun decl m => do if !decl.isImplementationDetail then let ty := (← instantiateMVars decl.type).cleanupAnnotations if ← Meta.isProp ty then return m.insert ty decl.toExpr return m /-- Generalizes the proofs in the type `e` and runs `k` in a local context with these propositions. This continuation `k` is passed 1. an array of fvars for the propositions 2. an array of proof terms (extracted from `e`) that prove these propositions 3. the generalized `e`, which refers to these fvars The `propToFVar` map is updated with the new proposition fvars. -/ partial def withGeneralizedProofs {α : Type} [Nonempty α] (e : Expr) (ty? : Option Expr) (k : Array Expr → Array Expr → Expr → MGen α) : MGen α := do let propToFVar := (← get).propToFVar trace[Tactic.generalize_proofs] "pre-abstracted{indentD e}\npropToFVar: {propToFVar.toArray}" let (e, generalizations) ← MGen.runMAbs <| abstractProofs e ty? trace[Tactic.generalize_proofs] "\ post-abstracted{indentD e}\nnew generalizations: {generalizations}" let rec /-- Core loop for `withGeneralizedProofs`, adds generalizations one at a time. -/ go [Nonempty α] (i : Nat) (fvars pfs : Array Expr) (proofToFVar propToFVar : ExprMap Expr) : MGen α := do if h : i < generalizations.size then let (ty, pf) := generalizations[i] let ty := (← instantiateMVars (ty.replace proofToFVar.get?)).cleanupAnnotations withLocalDeclD (← mkFreshUserName `pf) ty fun fvar => do go (i + 1) (fvars := fvars.push fvar) (pfs := pfs.push pf) (proofToFVar := proofToFVar.insert pf fvar) (propToFVar := propToFVar.insert ty fvar) else withNewLocalInstances fvars 0 do let e' := e.replace proofToFVar.get? trace[Tactic.generalize_proofs] "after: e' = {e}" modify fun s => { s with propToFVar } k fvars pfs e' go 0 #[] #[] (proofToFVar := {}) (propToFVar := propToFVar) /-- Main loop for `Lean.MVarId.generalizeProofs`. The `fvars` array is the array of fvars to generalize proofs for, and `rfvars` is the array of fvars that have been reverted. The `g` metavariable has all of these fvars reverted. -/ partial def generalizeProofsCore (g : MVarId) (fvars rfvars : Array FVarId) (target : Bool) : MGen (Array Expr × MVarId) := go g 0 #[] where /-- Loop for `generalizeProofsCore`. -/ go (g : MVarId) (i : Nat) (hs : Array Expr) : MGen (Array Expr × MVarId) := g.withContext do let tag ← g.getTag if h : i < rfvars.size then trace[Tactic.generalize_proofs] "generalizeProofsCore {i}{g}\n{(← get).propToFVar.toArray}" let fvar := rfvars[i] if fvars.contains fvar then -- This is one of the hypotheses that was intentionally reverted. let tgt ← instantiateMVars <| ← g.getType let ty := (if tgt.isLet then tgt.letType! else tgt.bindingDomain!).cleanupAnnotations if ← pure tgt.isLet <&&> Meta.isProp ty then -- Clear the proof value (using proof irrelevance) and `go` again let tgt' := Expr.forallE tgt.letName! ty tgt.letBody! .default let g' ← mkFreshExprSyntheticOpaqueMVar tgt' tag g.assign <| .app g' tgt.letValue! return ← go g'.mvarId! i hs if let some pf := (← get).propToFVar[ty]? then -- Eliminate this local hypothesis using the pre-existing proof, using proof irrelevance let tgt' := tgt.bindingBody!.instantiate1 pf let g' ← mkFreshExprSyntheticOpaqueMVar tgt' tag g.assign <| .lam tgt.bindingName! tgt.bindingDomain! g' tgt.bindingInfo! return ← go g'.mvarId! (i + 1) hs -- Now the main case, handling forall or let match tgt with | .forallE n t b bi => let prop ← Meta.isProp t withGeneralizedProofs t none fun hs' pfs' t' => do let t' := t'.cleanupAnnotations let tgt' := Expr.forallE n t' b bi let g' ← mkFreshExprSyntheticOpaqueMVar tgt' tag g.assign <| mkAppN (← mkLambdaFVars hs' g') pfs' let (fvar', g') ← g'.mvarId!.intro1P g'.withContext do Elab.pushInfoLeaf <| .ofFVarAliasInfo { id := fvar', baseId := fvar, userName := ← fvar'.getUserName } if prop then -- Make this prop available as a proof MGen.insertFVar t' (.fvar fvar') go g' (i + 1) (hs ++ hs') | .letE n t v b nondep => withGeneralizedProofs t none fun hs' pfs' t' => do withGeneralizedProofs v t' fun hs'' pfs'' v' => do let tgt' := Expr.letE n t' v' b nondep let g' ← mkFreshExprSyntheticOpaqueMVar tgt' tag g.assign <| mkAppN (← mkLambdaFVars (hs' ++ hs'') g') (pfs' ++ pfs'') let (fvar', g') ← g'.mvarId!.intro1P g'.withContext do Elab.pushInfoLeaf <| .ofFVarAliasInfo { id := fvar', baseId := fvar, userName := ← fvar'.getUserName } go g' (i + 1) (hs ++ hs' ++ hs'') | _ => unreachable! else -- This is one of the hypotheses that was incidentally reverted. let (fvar', g') ← g.intro1P g'.withContext do Elab.pushInfoLeaf <| .ofFVarAliasInfo { id := fvar', baseId := fvar, userName := ← fvar'.getUserName } go g' (i + 1) hs else if target then trace[Tactic.generalize_proofs] "\ generalizeProofsCore target{g}\n{(← get).propToFVar.toArray}" withGeneralizedProofs (← g.getType) none fun hs' pfs' ty' => do let g' ← mkFreshExprSyntheticOpaqueMVar ty' tag g.assign <| mkAppN (← mkLambdaFVars hs' g') pfs' return (hs ++ hs', g'.mvarId!) else return (hs, g) end GeneralizeProofs /-- Generalize proofs in the hypotheses `fvars` and, if `target` is true, the target. Returns the fvars for the generalized proofs and the new goal. If a hypothesis is a proposition and a `let` binding, this will clear the value of the let binding. If a hypothesis is a proposition that already appears in the local context, it will be eliminated. Only *nontrivial* proofs are generalized. These are proofs that aren't of the form `f a b ...` where `f` is atomic and `a b ...` are bound variables. These sorts of proofs cannot be meaningfully generalized, and also these are the sorts of proofs that are left in a term after generalization. -/ partial def _root_.Lean.MVarId.generalizeProofs (g : MVarId) (fvars : Array FVarId) (target : Bool) (config : GeneralizeProofs.Config := {}) : MetaM (Array Expr × MVarId) := do let (rfvars, g) ← g.revert fvars (clearAuxDeclsInsteadOfRevert := true) g.withContext do let s := { propToFVar := ← GeneralizeProofs.initialPropToFVar } GeneralizeProofs.generalizeProofsCore g fvars rfvars target |>.run config |>.run' s /-- `generalize_proofs ids* [at locs]?` generalizes proofs in the current goal, turning them into new local hypotheses. - `generalize_proofs` generalizes proofs in the target. - `generalize_proofs at h₁ h₂` generalized proofs in hypotheses `h₁` and `h₂`. - `generalize_proofs at *` generalizes proofs in the entire local context. - `generalize_proofs pf₁ pf₂ pf₃` uses names `pf₁`, `pf₂`, and `pf₃` for the generalized proofs. These can be `_` to not name proofs. If a proof is already present in the local context, it will use that rather than create a new local hypothesis. When doing `generalize_proofs at h`, if `h` is a let binding, its value is cleared, and furthermore if `h` duplicates a preceding local hypothesis then it is eliminated. The tactic is able to abstract proofs from under binders, creating universally quantified proofs in the local context. To disable this, use `generalize_proofs -abstract`. The tactic is also set to recursively abstract proofs from the types of the generalized proofs. This can be controlled with the `maxDepth` configuration option, with `generalize_proofs (config := { maxDepth := 0 })` turning this feature off. For example: ```lean def List.nthLe {α} (l : List α) (n : ℕ) (_h : n < l.length) : α := sorry example : List.nthLe [1, 2] 1 (by simp) = 2 := by -- ⊢ [1, 2].nthLe 1 ⋯ = 2 generalize_proofs h -- h : 1 < [1, 2].length -- ⊢ [1, 2].nthLe 1 h = 2 ``` -/ elab (name := generalizeProofsElab) "generalize_proofs" config:Parser.Tactic.optConfig hs:(ppSpace colGt binderIdent)* loc?:(location)? : tactic => withMainContext do let config ← GeneralizeProofs.elabConfig config let (fvars, target) ← match expandOptLocation (Lean.mkOptionalNode loc?) with | .wildcard => pure ((← getLCtx).getFVarIds, true) | .targets t target => pure (← getFVarIds t, target) liftMetaTactic1 fun g => do let (pfs, g) ← g.generalizeProofs fvars target config -- Rename the proofs using `hs` and record info g.withContext do let mut lctx ← getLCtx for h in hs, fvar in pfs do if let `(binderIdent| $s:ident) := h then lctx := lctx.setUserName fvar.fvarId! s.getId Expr.addLocalVarInfoForBinderIdent fvar h withLCtx lctx (← getLocalInstances) do let g' ← mkFreshExprSyntheticOpaqueMVar (← g.getType) (← g.getTag) g.assign g' return g'.mvarId! end Batteries.Tactic ================================================ FILE: Batteries/Tactic/HelpCmd.lean ================================================ /- Copyright (c) 2024 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro, Edward van de Meent -/ module public meta import Lean.Elab.Syntax public meta import Lean.DocString public meta import Batteries.Util.LibraryNote public meta section /-! # The `#help` command The `#help` command can be used to list all definitions in a variety of extensible aspects of lean. * `#help option` lists options (used in `set_option myOption`) * `#help attr` lists attributes (used in `@[myAttr] def foo := ...`) * `#help cats` lists syntax categories (like `term`, `tactic`, `stx` etc) * `#help cat C` lists elements of syntax category C * `#help term`, `#help tactic`, `#help conv`, `#help command` are shorthand for `#help cat term` etc. * `#help cat+ C` also shows `elab` and `macro` definitions associated to the syntaxes * `#help note "some note"` lists library notes for which "some note" is a prefix of the label Most forms take an optional identifier to narrow the search; for example `#help option pp` shows only `pp.*` options. However, `#help cat` makes the identifier mandatory, while `#help note` takes a mandatory string literal, rather than an identifier. -/ namespace Batteries.Tactic open Lean Meta Elab Tactic Command /-- The command `#help option` shows all options that have been defined in the current environment. Each option has a format like: ``` option pp.all : Bool := false (pretty printer) display coercions, implicit parameters, proof terms, fully qualified names, universe, and disable beta reduction and notations during pretty printing ``` This says that `pp.all` is an option which can be set to a `Bool` value, and the default value is `false`. If an option has been modified from the default using e.g. `set_option pp.all true`, it will appear as a `(currently: true)` note next to the option. The form `#help option id` will show only options that begin with `id`. -/ syntax withPosition("#help " colGt &"option" (colGt ppSpace Parser.rawIdent)?) : command private def elabHelpOption (id : Option Ident) : CommandElabM Unit := do let id := id.map (·.raw.getId.toString false) let mut decls : Std.TreeMap _ _ compare := {} for (name, decl) in show NameMap OptionDecl from ← getOptionDecls do let name := name.toString false if let some id := id then if !id.isPrefixOf name then continue decls := decls.insert name decl let mut msg := Format.nil let opts ← getOptions if decls.isEmpty then match id with | some id => throwError "no options start with {id}" | none => throwError "no options found (!)" for (name, decl) in decls do let mut msg1 := match decl.defValue with | .ofString val => s!"String := {repr val}" | .ofBool val => s!"Bool := {repr val}" | .ofName val => s!"Name := {repr val}" | .ofNat val => s!"Nat := {repr val}" | .ofInt val => s!"Int := {repr val}" | .ofSyntax val => s!"Syntax := {repr val}" if let some val := opts.find? (.mkSimple name) then msg1 := s!"{msg1} (currently: {val})" msg := msg ++ .nest 2 (f!"option {name} : {msg1}" ++ .line ++ decl.descr) ++ .line ++ .line logInfo msg elab_rules : command | `(#help option $(id)?) => elabHelpOption id /-- The command `#help attribute` (or the short form `#help attr`) shows all attributes that have been defined in the current environment. Each attribute has a format like: ``` [inline]: mark definition to always be inlined ``` This says that `inline` is an attribute that can be placed on definitions like `@[inline] def foo := 1`. (Individual attributes may have restrictions on where they can be applied; see the attribute's documentation for details.) Both the attribute's `descr` field as well as the docstring will be displayed here. The form `#help attr id` will show only attributes that begin with `id`. -/ syntax withPosition("#help " colGt (&"attr" <|> &"attribute") (colGt ppSpace Parser.rawIdent)?) : command private def elabHelpAttr (id : Option Ident) : CommandElabM Unit := do let id := id.map (·.raw.getId.toString false) let mut decls : Std.TreeMap _ _ compare := {} /- #adaptation_note On nightly-2024-06-21, added the `.toList` here: without it the requisite `ForIn` instance can't be found. -/ for (name, decl) in (← attributeMapRef.get).toList do let name := name.toString false if let some id := id then if !id.isPrefixOf name then continue decls := decls.insert name decl let mut msg := Format.nil let env ← getEnv if decls.isEmpty then match id with | some id => throwError "no attributes start with {id}" | none => throwError "no attributes found (!)" for (name, decl) in decls do let mut msg1 := s!"[{name}]: {decl.descr}" if let some doc ← findDocString? env decl.ref then msg1 := s!"{msg1}\n{doc.trimAscii}" msg := msg ++ .nest 2 msg1 ++ .line ++ .line logInfo msg elab_rules : command | `(#help attr $(id)?) => elabHelpAttr id | `(#help attribute $(id)?) => elabHelpAttr id /-- The command `#help cats` shows all syntax categories that have been defined in the current environment. Each syntax has a format like: ``` category command [Lean.Parser.initFn✝] ``` The name of the syntax category in this case is `command`, and `Lean.Parser.initFn✝` is the name of the declaration that introduced it. (It is often an anonymous declaration like this, but you can click to go to the definition.) It also shows the doc string if available. The form `#help cats id` will show only syntax categories that begin with `id`. -/ syntax withPosition("#help " colGt &"cats" (colGt ppSpace Parser.rawIdent)?) : command private def elabHelpCats (id : Option Ident) : CommandElabM Unit := do let id := id.map (·.raw.getId.toString false) let mut decls : Std.TreeMap _ _ compare := {} for (name, cat) in (Parser.parserExtension.getState (← getEnv)).categories do let name := name.toString false if let some id := id then if !id.isPrefixOf name then continue decls := decls.insert name cat let mut msg := MessageData.nil let env ← getEnv if decls.isEmpty then match id with | some id => throwError "no syntax categories start with {id}" | none => throwError "no syntax categories found (!)" for (name, cat) in decls do let mut msg1 := m!"category {name} [{mkConst cat.declName}]" if let some doc ← findDocString? env cat.declName then msg1 := msg1 ++ Format.line ++ doc.trimAscii.copy msg := msg ++ .nest 2 msg1 ++ (.line ++ .line : Format) logInfo msg elab_rules : command | `(#help cats $(id)?) => elabHelpCats id /-- The command `#help cat C` shows all syntaxes that have been defined in syntax category `C` in the current environment. Each syntax has a format like: ``` syntax "first"... [Parser.tactic.first] `first | tac | ...` runs each `tac` until one succeeds, or else fails. ``` The quoted string is the leading token of the syntax, if applicable. It is followed by the full name of the syntax (which you can also click to go to the definition), and the documentation. * The form `#help cat C id` will show only attributes that begin with `id`. * The form `#help cat+ C` will also show information about any `macro`s and `elab`s associated to the listed syntaxes. -/ syntax withPosition("#help " colGt &"cat" "+"? colGt ident (colGt ppSpace (Parser.rawIdent <|> str))?) : command private def tokensToList (tks : Parser.FirstTokens) : List String := match tks with | .epsilon | .unknown => [] | .tokens tks | .optTokens tks => tks private def elabHelpCat (more : Option Syntax) (catStx : Ident) (id : Option String) : CommandElabM Unit := do let mut decls : Std.TreeMap _ _ compare := {} let mut rest : Std.TreeMap _ _ compare := {} let catName := catStx.getId.eraseMacroScopes let categories := (Parser.parserExtension.getState (← getEnv)).categories let some cat := categories.find? catName | throwErrorAt catStx "{catStx} is not a syntax category" liftTermElabM <| Term.addCategoryInfo catStx catName let mut declsArray : Array (SyntaxNodeKind × List String × Bool) := {} let mut tokenUsage : Std.HashMap String Nat := {} for (k, _) in cat.kinds do let mut used := false try let (leading, parser) ← liftCoreM <| Parser.mkParserOfConstant categories k let tks := tokensToList parser.info.firstTokens let tks := tks.filter (· != "$") -- filter antiquotations -- collect the usage of every token regardless of filtering to make sure that the -- token detection is independent of a filter for tk in tks.eraseDups do tokenUsage := tokenUsage.alter tk fun n => some (n.getD 0 + 1) if let some id := id then unless tks.any (·.startsWith id) do continue unless tks.isEmpty do used := true declsArray := declsArray.push (k, tks, leading) catch _ => pure () if !used && id.isNone then rest := rest.insert (k.toString false) k for (kind, tks, leading) in declsArray do -- we choose the first, least common token let winnerTk := tks.minOn? (tokenUsage[·]!) |>.get! decls := decls.alter winnerTk fun arr => some (arr.getD #[] |>.push (kind, leading)) let mut msg := MessageData.nil if decls.isEmpty && rest.isEmpty then match id with | some id => throwError "no {catName} declarations start with {id}" | none => throwError "no {catName} declarations found" let env ← getEnv let addMsg (k : SyntaxNodeKind) (msg msg1 : MessageData) : CommandElabM MessageData := do let mut msg1 := msg1 if let some doc ← findDocString? env k then msg1 := msg1 ++ Format.line ++ doc.trimAscii.copy msg1 := .nest 2 msg1 if more.isSome then let addElabs {α} (type : String) (attr : KeyedDeclsAttribute α) (msg : MessageData) : CommandElabM MessageData := do let mut msg := msg for e in attr.getEntries env k do let x := e.declName msg := msg ++ Format.line ++ m!"+ {type} {mkConst x}" if let some doc ← findDocString? env x then msg := msg ++ .nest 2 (Format.line ++ doc.trimAscii.copy) pure msg msg1 ← addElabs "macro" macroAttribute msg1 match catName with | `term => msg1 ← addElabs "term elab" Term.termElabAttribute msg1 | `command => msg1 ← addElabs "command elab" commandElabAttribute msg1 | `tactic | `conv => msg1 ← addElabs "tactic elab" tacticElabAttribute msg1 | _ => pure () return msg ++ msg1 ++ (.line ++ .line : Format) for (name, ks) in decls do for (k, leading) in ks do if leading then msg ← addMsg k msg m!"syntax {repr name}... [{mkConst k}]" else msg ← addMsg k msg m!"syntax ...{repr name}... [{mkConst k}]" for (_, k) in rest do msg ← addMsg k msg m!"syntax ... [{mkConst k}]" logInfo msg elab_rules : command | `(#help cat $[+%$more]? $cat) => elabHelpCat more cat none | `(#help cat $[+%$more]? $cat $id:ident) => elabHelpCat more cat (id.getId.toString false) | `(#help cat $[+%$more]? $cat $id:str) => elabHelpCat more cat id.getString open Lean Parser Batteries.Util.LibraryNote in /-- `#help note "foo"` searches for all library notes whose label starts with "foo", then displays those library notes sorted alphabetically by label, grouped by label. The command only displays the library notes that are declared in imported files or in the same file above the line containing the command. -/ elab "#help " colGt &"note" colGt ppSpace name:strLit : command => do let env ← getEnv -- get the library notes from both this and imported files let local_entries := (libraryNoteExt.getEntries env).reverse let imported_entries := (libraryNoteExt.toEnvExtension.getState env).importedEntries -- The key for searching and sorting library notes is their value as a string, -- without any «escaping using french quotes». let key (n : LibraryNoteEntry) := n.toString (escape := false) -- filter for the appropriate notes while casting to list let label_prefix := name.getString let imported_entries_filtered := imported_entries.flatten.toList.filterMap fun x => if label_prefix.isPrefixOf (key x) then some x else none let valid_entries := (imported_entries_filtered ++ local_entries.filterMap fun x => if label_prefix.isPrefixOf (key x) then some x else none) |>.mergeSort (key · ≤ key ·) -- display results in a readable style if valid_entries.isEmpty then logError "Note not found" else logInfo <| "\n\n".intercalate <| ← valid_entries.filterMapM fun x => do -- Use encoded name (spaces → underscores) for docstring lookup, -- matching the declaration name created by `library_note` let encodedName := encodeNameForExport x let some doc ← findDocString? env <| (`LibraryNote).eraseMacroScopes.append encodedName | return none return "library_note " ++ x.toString (escape := true) ++ "\n" ++ "/-- " ++ doc.trimAscii ++ " -/" /-- The command `#help term` shows all term syntaxes that have been defined in the current environment. See `#help cat` for more information. -/ syntax withPosition("#help " colGt &"term" "+"? (colGt ppSpace (Parser.rawIdent <|> str))?) : command macro_rules | `(#help term%$tk $[+%$more]? $(id)?) => `(#help cat$[+%$more]? $(mkIdentFrom tk `term) $(id)?) /-- The command `#help tactic` shows all tactics that have been defined in the current environment. See `#help cat` for more information. -/ syntax withPosition("#help " colGt &"tactic" "+"? (colGt ppSpace (Parser.rawIdent <|> str))?) : command macro_rules | `(#help tactic%$tk $[+%$more]? $(id)?) => `(#help cat$[+%$more]? $(mkIdentFrom tk `tactic) $(id)?) /-- The command `#help conv` shows all tactics that have been defined in the current environment. See `#help cat` for more information. -/ syntax withPosition("#help " colGt &"conv" "+"? (colGt ppSpace (Parser.rawIdent <|> str))?) : command macro_rules | `(#help conv%$tk $[+%$more]? $(id)?) => `(#help cat$[+%$more]? $(mkIdentFrom tk `conv) $(id)?) /-- The command `#help command` shows all commands that have been defined in the current environment. See `#help cat` for more information. -/ syntax withPosition("#help " colGt &"command" "+"? (colGt ppSpace (Parser.rawIdent <|> str))?) : command macro_rules | `(#help command%$tk $[+%$more]? $(id)?) => `(#help cat$[+%$more]? $(mkIdentFrom tk `command) $(id)?) ================================================ FILE: Batteries/Tactic/Init.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Tactic.ElabTerm public meta import Lean.Meta.MatchUtil public meta section /-! # Simple tactics that are used throughout Batteries. -/ namespace Batteries.Tactic open Lean Parser.Tactic Elab Elab.Tactic Meta /-- `_` in tactic position acts like the `done` tactic: it fails and gives the list of goals if there are any. It is useful as a placeholder after starting a tactic block such as `by _` to make it syntactically correct and show the current goal. -/ macro "_" : tactic => `(tactic| {}) /-- Like `exact`, but takes a list of terms and checks that all goals are discharged after the tactic. -/ elab (name := exacts) "exacts " "[" hs:term,* "]" : tactic => do for stx in hs.getElems do evalTactic (← `(tactic| exact $stx)) evalTactic (← `(tactic| done)) /-- `by_contra_core` is the component of `by_contra` that turns the goal into the form `p → False`. `by_contra h` is defined as `by_contra_core` followed by `rintro h`. * If the goal is a negation `¬q`, the goal becomes `q → False`. * If the goal has a `Decidable` instance, it uses `Decidable.byContradiction` instead of `Classical.byContradiction`. -/ scoped macro "by_contra_core" : tactic => `(tactic| first | guard_target = Not _; change _ → False | refine @Decidable.byContradiction _ _ ?_ | refine @Classical.byContradiction _ ?_) /-- `by_contra h` proves `⊢ p` by contradiction, introducing a hypothesis `h : ¬p` and proving `False`. * If `p` is a negation `¬q`, `h : q` will be introduced instead of `¬¬q`. * If `p` is decidable, it uses `Decidable.byContradiction` instead of `Classical.byContradiction`. * If `h` is omitted, the introduced variable will be called `this`. -/ syntax (name := byContra) "by_contra" (ppSpace colGt rcasesPatMed)? (" : " term)? : tactic macro_rules | `(tactic| by_contra $[$pat?]? $[: $ty?]?) => do let pat ← pat?.getDM `(rcasesPatMed| $(mkIdent `this):ident) `(tactic| (by_contra_core; rintro ($pat:rcasesPatMed) $[: $ty?]?)) /-- Given a proof `h` of `p`, `absurd h` changes the goal to `⊢ ¬ p`. If `p` is a negation `¬q` then the goal is changed to `⊢ q` instead. -/ macro "absurd " h:term : tactic => -- we can't use `( :)` here as that would make `·` behave weirdly. `(tactic| first | refine @absurd _ _ ?_ $h | refine @absurd _ _ $h ?_) /-- `split_ands` applies `And.intro` until it does not make progress. -/ syntax "split_ands" : tactic macro_rules | `(tactic| split_ands) => `(tactic| repeat' refine And.intro ?_ ?_) /-- `fapply e` is like `apply e` but it adds goals in the order they appear, rather than putting the dependent goals first. -/ elab "fapply " e:term : tactic => evalApplyLikeTactic (·.apply (cfg := {newGoals := .all})) e /-- `eapply e` is like `apply e` but it does not add subgoals for variables that appear in the types of other goals. Note that this can lead to a failure where there are no goals remaining but there are still metavariables in the term: ``` example (h : ∀ x : Nat, x = x → True) : True := by eapply h rfl -- no goals -- (kernel) declaration has metavariables '_example' ``` -/ elab "eapply " e:term : tactic => evalApplyLikeTactic (·.apply (cfg := {newGoals := .nonDependentOnly})) e /-- Deprecated variant of `trivial`. -/ elab (name := triv) "triv" : tactic => throwError "`triv` has been removed; use `trivial` instead" /-- `conv` tactic to close a goal using an equality theorem. -/ macro (name := Conv.exact) "exact " t:term : conv => `(conv| tactic => exact $t) /-- The `conv` tactic `equals` claims that the currently focused subexpression is equal to the given expression, and proves this claim using the given tactic. ``` example (P : (Nat → Nat) → Prop) : P (fun n => n - n) := by conv in (_ - _) => equals 0 => -- current goal: ⊢ n - n = 0 apply Nat.sub_self -- current goal: P (fun n => 0) ``` -/ elab (name := Conv.equals) "equals " t:term " => " tac:tacticSeq : conv => do let mvarId ← getMainGoal mvarId.withContext do let goal ← mvarId.getType let some (α, _, rhs) ← matchEq? goal | throwError "invalid 'conv' goal" let e ← Term.withSynthesize do Term.elabTermEnsuringType t (some α) unless ← isDefEq rhs e do throwError m!"failed to resolve{indentExpr rhs}\n=?={indentExpr e}" evalTactic <| ← `(conv| tactic => · $tac) ================================================ FILE: Batteries/Tactic/Instances.lean ================================================ /- Copyright (c) 2023 Kyle Miller. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kyle Miller -/ module public meta import Lean.Elab.Command public meta import Lean.PrettyPrinter public meta section /-! # `#instances` command The `#instances` command prints lists all instances that apply to the given type, if it is a class. It is similar to `#synth` but it only does the very first step of the instance synthesis algorithm, which is to enumerate potential instances. -/ open Lean Elab Command Meta namespace Batteries.Tactic.Instances /-- `#instances term` prints all the instances for the given class. For example, `#instances Add _` gives all `Add` instances, and `#instances Add Nat` gives the `Nat` instance. The `term` can be any type that can appear in `[...]` binders. Trailing underscores can be omitted, and `#instances Add` and `#instances Add _` are equivalent; the command adds metavariables until the argument is no longer a function. The `#instances` command is closely related to `#synth`, but `#synth` does the full instance synthesis algorithm and `#instances` does the first step of finding potential instances. -/ elab (name := instancesCmd) tk:"#instances " stx:term : command => runTermElabM fun _ => do let type ← Term.elabTerm stx none -- Throw in missing arguments using metavariables. let (args, _, _) ← withDefault <| forallMetaTelescopeReducing (← inferType type) -- Use free variables for explicit quantifiers withDefault <| forallTelescopeReducing (mkAppN type args) fun _ type => do let some className ← isClass? type | throwErrorAt stx "type class instance expected{indentExpr type}" let globalInstances ← getGlobalInstancesIndex let result ← globalInstances.getUnify type let erasedInstances ← getErasedInstances let mut msgs := #[] for e in result.insertionSort fun e₁ e₂ => e₁.priority < e₂.priority do let Expr.const c _ := e.val | unreachable! if erasedInstances.contains c then continue let mut msg := m!"\n" if e.priority != 1000 then -- evalPrio default := 1000 msg := msg ++ m!"(prio {e.priority}) " msgs := msgs.push <| msg ++ MessageData.signature c for linst in ← getLocalInstances do if linst.className == className then msgs := msgs.push m!"(local) {linst.fvar} : {← inferType linst.fvar}" if msgs.isEmpty then logInfoAt tk m!"No instances" else let instances := if msgs.size == 1 then "instance" else "instances" logInfoAt tk <| msgs.reverse.foldl (·++·) m!"{msgs.size} {instances}:\n" @[inherit_doc instancesCmd] macro tk:"#instances" bi:(ppSpace bracketedBinder)* " : " t:term : command => `(command| variable $bi* in #instances%$tk $t) ================================================ FILE: Batteries/Tactic/Lemma.lean ================================================ /- Copyright (c) 2024 Johan Commelin. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Johan Commelin, Damiano Testa -/ module public meta import Lean.Meta.Tactic.TryThis public meta import Lean.Elab.Command public meta section /-! # Control for `lemma` command The `lemma` command exists in `Mathlib`, but not in `Std`. This file enforces the convention by introducing a code-action to replace `lemma` by `theorem`. -/ namespace Batteries.Tactic.Lemma open Lean Elab.Command Meta.Tactic /-- Enables the use of `lemma` as a synonym for `theorem` -/ register_option lang.lemmaCmd : Bool := { defValue := false descr := "enable the use of the `lemma` command as a synonym for `theorem`" } /-- Check whether `lang.lemmaCmd` option is enabled -/ def checkLangLemmaCmd (o : Options) : Bool := o.get `lang.lemmaCmd lang.lemmaCmd.defValue /-- `lemma` is not supported, please use `theorem` instead -/ syntax (name := lemmaCmd) declModifiers group("lemma " declId ppIndent(declSig) declVal) : command /-- Elaborator for the `lemma` command, if the option `lang.lemmaCmd` is false the command emits a warning and code action instructing the user to use `theorem` instead.-/ @[command_elab «lemmaCmd»] def elabLemma : CommandElab := fun stx => do unless checkLangLemmaCmd (← getOptions) do let lemmaStx := stx[1][0] Elab.Command.liftTermElabM <| TryThis.addSuggestion lemmaStx { suggestion := "theorem" } logErrorAt lemmaStx "`lemma` is not supported by default, please use `theorem` instead.\n\ Use `set_option lang.lemmaCmd true` to enable the use of the `lemma` command in a file.\n\ Use the command line option `-Dlang.lemmaCmd=true` to enable the use of `lemma` globally." let out ← Elab.liftMacroM <| do let stx := stx.modifyArg 1 fun stx => let stx := stx.modifyArg 0 (mkAtomFrom · "theorem" (canonical := true)) stx.setKind ``Parser.Command.theorem pure <| stx.setKind ``Parser.Command.declaration Elab.Command.elabCommand out ================================================ FILE: Batteries/Tactic/Lint/Basic.lean ================================================ /- Copyright (c) 2020 Floris van Doorn. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner -/ module public meta import Lean.Structure public meta import Lean.Elab.InfoTree.Main public meta import Lean.Elab.Exception public meta import Lean.ExtraModUses public meta section open Lean Meta namespace Batteries.Tactic.Lint /-! # Basic linter types and attributes This file defines the basic types and attributes used by the linting framework. A linter essentially consists of a function `(declaration : Name) → MetaM (Option MessageData)`, this function together with some metadata is stored in the `Linter` structure. We define two attributes: * `@[env_linter]` applies to a declaration of type `Linter` and adds it to the default linter set. * `@[nolint linterName]` omits the tagged declaration from being checked by the linter with name `linterName`. -/ /-- Returns true if `decl` is an automatically generated declaration. Also returns true if `decl` is an internal name or created during macro expansion. -/ def isAutoDecl (decl : Name) : CoreM Bool := do if decl.hasMacroScopes then return true if decl.isInternal then return true let env ← getEnv if isReservedName env decl then return true if let Name.str n s := decl then if (← isAutoDecl n) then return true if s.startsWith "proof_" || s.startsWith "match_" || s.startsWith "unsafe_" || s.startsWith "grind_" then return true if env.isConstructor n && s ∈ ["injEq", "inj", "sizeOf_spec", "elim", "noConfusion"] then return true if let ConstantInfo.inductInfo _ := (← getEnv).find? n then if s.startsWith "brecOn_" || s.startsWith "below_" then return true if s ∈ [casesOnSuffix, recOnSuffix, brecOnSuffix, belowSuffix, "ndrec", "ndrecOn", "noConfusionType", "noConfusion", "ofNat", "toCtorIdx", "ctorIdx", "ctorElim", "ctorElimType"] then return true if let some _ := isSubobjectField? env n (.mkSimple s) then return true -- Coinductive/inductive lattice-theoretic predicates: if let ConstantInfo.inductInfo _ := env.find? (Name.str n "_functor") then if s == "functor_unfold" || s == casesOnSuffix || s == "mutual" then return true if env.isConstructor (Name.str (Name.str n "_functor") s) then return true pure false /-- A linting test for the `#lint` command. -/ structure Linter where /-- `test` defines a test to perform on every declaration. It should never fail. Returning `none` signifies a passing test. Returning `some msg` reports a failing test with error `msg`. -/ test : Name → MetaM (Option MessageData) /-- `noErrorsFound` is the message printed when all tests are negative -/ noErrorsFound : MessageData /-- `errorsFound` is printed when at least one test is positive -/ errorsFound : MessageData /-- If `isFast` is false, this test will be omitted from `#lint-`. -/ isFast := true /-- A `NamedLinter` is a linter associated to a particular declaration. -/ structure NamedLinter extends Linter where /-- The name of the named linter. This is just the declaration name without the namespace. -/ name : Name /-- The linter declaration name -/ declName : Name /-- Gets a linter by declaration name. -/ def getLinter (name declName : Name) : CoreM NamedLinter := unsafe return { ← evalConstCheck Linter ``Linter declName with name, declName } /-- Defines the `env_linter` extension for adding a linter to the default set. -/ initialize batteriesLinterExt : SimplePersistentEnvExtension (Name × Bool) (NameMap (Name × Bool)) ← let addEntryFn := fun m (n, b) => m.insert (n.updatePrefix .anonymous) (n, b) registerSimplePersistentEnvExtension { addImportedFn := fun nss => nss.foldl (init := {}) fun m ns => ns.foldl (init := m) addEntryFn addEntryFn } /-- Defines the `@[env_linter]` attribute for adding a linter to the default set. The form `@[env_linter disabled]` will not add the linter to the default set, but it will be shown by `#list_linters` and can be selected by the `#lint` command. Linters are named using their declaration names, without the namespace. These must be distinct. -/ syntax (name := env_linter) "env_linter" &" disabled"? : attr initialize registerBuiltinAttribute { name := `env_linter descr := "Use this declaration as a linting test in #lint" add := fun decl stx kind => do let dflt := stx[1].isNone unless kind == .global do throwError "invalid attribute `env_linter`, must be global" let shortName := decl.updatePrefix .anonymous if let some (declName, _) := (batteriesLinterExt.getState (← getEnv)).find? shortName then Elab.addConstInfo stx declName throwError "invalid attribute `env_linter`, linter `{shortName}` has already been declared" /- Just as `env_linter`s must be `global`, they also must be accessible from `#lint`, and thus must be `public` and `meta`. `Linter.mk` is already `meta` and thus will likely cause an error anyway, but the explicit instruction to mark this declaration `meta` might help the user resolve that and similar errors. -/ let isPublic := !isPrivateName decl; let isMeta := isMarkedMeta (← getEnv) decl unless isPublic && isMeta do throwError "invalid attribute `env_linter`, \ declaration `{.ofConstName decl}` must be marked as `public` and `meta`\ {if isPublic then " but is only marked `public`" else ""}\ {if isMeta then " but is only marked `meta`" else ""}" let constInfo ← getConstInfo decl unless ← (isDefEq constInfo.type (mkConst ``Linter)).run' do throwError "`{.ofConstName decl}` must have type `{.ofConstName ``Linter}`, got \ `{constInfo.type}`" modifyEnv fun env => batteriesLinterExt.addEntry env (decl, dflt) } /-- `@[nolint linterName]` omits the tagged declaration from being checked by the linter with name `linterName`. -/ syntax (name := nolint) "nolint" (ppSpace ident)+ : attr /-- Defines the user attribute `nolint` for skipping `#lint` -/ initialize nolintAttr : ParametricAttribute (Array Name) ← registerParametricAttribute { name := `nolint descr := "Do not report this declaration in any of the tests of `#lint`" getParam := fun _ => fun | `(attr| nolint $[$ids]*) => ids.mapM fun id => withRef id <| do let shortName := id.getId.eraseMacroScopes let some (declName, _) := (batteriesLinterExt.getState (← getEnv)).find? shortName | throwError "linter '{shortName}' not found" Elab.addConstInfo id declName recordExtraModUseFromDecl (isMeta := false) declName pure shortName | _ => Elab.throwUnsupportedSyntax } /-- Returns true if `decl` should be checked using `linter`, i.e., if there is no `nolint` attribute. -/ def shouldBeLinted [Monad m] [MonadEnv m] (linter : Name) (decl : Name) : m Bool := return !((nolintAttr.getParam? (← getEnv) decl).getD #[]).contains linter ================================================ FILE: Batteries/Tactic/Lint/Frontend.lean ================================================ /- Copyright (c) 2020 Floris van Doorn. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner -/ module public meta import Lean.Elab.Command public meta import Batteries.Tactic.Lint.Basic public meta section /-! # Linter frontend and commands This file defines the linter commands which spot common mistakes in the code. * `#lint`: check all declarations in the current file * `#lint in Pkg`: check all declarations in the package `Pkg` (so excluding core or other projects, and also excluding the current file) * `#lint in all`: check all declarations in the environment (the current file and all imported files) For a list of default / non-default linters, see the "Linting Commands" user command doc entry. The command `#list_linters` prints a list of the names of all available linters. You can append a `*` to any command (e.g. `#lint* in Batteries`) to omit the slow tests. You can append a `-` to any command (e.g. `#lint- in Batteries`) to run a silent lint that suppresses the output if all checks pass. A silent lint will fail if any test fails. You can append a `+` to any command (e.g. `#lint+ in Batteries`) to run a verbose lint that reports the result of each linter, including the successes. You can append a sequence of linter names to any command to run extra tests, in addition to the default ones. e.g. `#lint doc_blame_thm` will run all default tests and `doc_blame_thm`. You can append `only name1 name2 ...` to any command to run a subset of linters, e.g. `#lint only unused_arguments in Batteries` You can add custom linters by defining a term of type `Linter` with the `@[env_linter]` attribute. A linter defined with the name `Batteries.Tactic.Lint.myNewCheck` can be run with `#lint myNewCheck` or `#lint only myNewCheck`. If you add the attribute `@[env_linter disabled]` to `linter.myNewCheck` it will be registered, but not run by default. Adding the attribute `@[nolint doc_blame unused_arguments]` to a declaration omits it from only the specified linter checks. ## Tags sanity check, lint, cleanup, command, tactic -/ namespace Batteries.Tactic.Lint open Lean Elab Command /-- Verbosity for the linter output. -/ inductive LintVerbosity /-- `low`: only print failing checks, print nothing on success. -/ | low /-- `medium`: only print failing checks, print confirmation on success. -/ | medium /-- `high`: print output of every check. -/ | high deriving Inhabited, DecidableEq, Repr /-- `getChecks slow runOnly runAlways` produces a list of linters. `runOnly` is an optional list of names that should resolve to declarations with type `NamedLinter`. If populated, only these linters are run (regardless of the default configuration). `runAlways` is an optional list of names that should resolve to declarations with type `NamedLinter`. If populated, these linters are always run (regardless of their configuration). Specifying a linter in `runAlways` but not `runOnly` is an error. Otherwise, it uses all enabled linters in the environment tagged with `@[env_linter]`. If `slow` is false, it only uses the fast default tests. -/ def getChecks (slow : Bool) (runOnly : Option (List Name)) (runAlways : Option (List Name)) : CoreM (Array NamedLinter) := do let mut result := #[] for (name, declName, default) in batteriesLinterExt.getState (← getEnv) do let shouldRun := match (runOnly, runAlways) with | (some only, some always) => only.contains name && (always.contains name || default) | (some only, none) => only.contains name | (none, some always) => default || always.contains name | _ => default if shouldRun then let linter ← getLinter name declName if slow || linter.isFast then let _ := Inhabited.mk linter result := result.binInsert (·.name.lt ·.name) linter pure result /-- Traces via `IO.println` if `inIO` is `true`, and via `trace[...]` otherwise. It seems that `trace` messages in a running `CoreM` are not propagated through to `IO` in the current setup. We use `IO.println` directly instead of running `printTraces` at the end of our `CoreM` action so that trace messages are printed to stdout immediately, and are not lost if any part of the action hangs. This declaration is `macro_inline`, so it should have the same thunky behavior as `trace[...]`. -/ @[macro_inline, expose] def traceLintCore (msg : String) (inIO : Bool) : CoreM Unit := do if inIO then if ← getBoolOption `trace.Batteries.Lint then IO.println msg else trace[Batteries.Lint] msg /-- Traces via `IO.println` if `inIO` is `true`, and via `trace[...]` otherwise. Prepends `currentModule` and `linter` (if present). This declaration is `macro_inline`, so it should have the same thunky behavior as `trace[...]`. -/ @[macro_inline, expose] def traceLint (msg : String) (inIO : Bool) (currentModule linterName : Option Name := none) : CoreM Unit := traceLintCore (inIO := inIO) s!"{if let some m := currentModule then s!"[{m}] " else ""}\ {if let some l := linterName then s!"- {l}: " else ""}\ {msg}" /-- Runs all the specified linters on all the specified declarations in parallel, producing a list of results. -/ def lintCore (decls : Array Name) (linters : Array NamedLinter) -- For tracing: (currentModule : Option Name := none) (inIO : Bool := false) : CoreM (Array (NamedLinter × Std.HashMap Name MessageData)) := do traceLint s!"Running linters:\n {"\n ".intercalate <| linters.map (s!"{·.name}") |>.toList}" inIO currentModule let tasks : Array (NamedLinter × Array (Name × Task (Except Exception <| Option MessageData))) ← linters.mapM fun linter => do traceLint "(0/2) Starting..." inIO currentModule linter.name let decls ← decls.filterM (shouldBeLinted linter.name) (linter, ·) <$> decls.mapM fun decl => (decl, ·) <$> do let act : MetaM (Option MessageData) := do let result ← linter.test decl if inIO then -- Ensure any trace messages are propagated to stdout printTraces return result EIO.asTask <| (← Core.wrapAsync (fun _ => act |>.run' mkMetaContext -- We use the context used by `Command.liftTermElabM` ) (cancelTk? := none)) () let result ← tasks.mapM fun (linter, decls) => do traceLint "(1/2) Getting..." inIO currentModule linter.name let mut msgs : Std.HashMap Name MessageData := {} for (declName, msgTask) in decls do let msg? ← match msgTask.get with | Except.ok msg? => pure msg? | Except.error err => pure m!"LINTER FAILED:\n{err.toMessageData}" if let .some msg := msg? then msgs := msgs.insert declName msg traceLint s!"(2/2) {if msgs.isEmpty then "Passed!" else s!"Failed with {msgs.size} messages\ {if inIO then ", but these may include declarations in `nolints.json`" else ""}."}" inIO currentModule linter.name pure (linter, msgs) traceLint "Completed linting!" inIO currentModule return result /-- Sorts a map with declaration keys as names by line number. -/ def sortResults (results : Std.HashMap Name α) : CoreM <| Array (Name × α) := do let mut key : Std.HashMap Name Nat := {} for (n, _) in results.toArray do if let some range ← findDeclarationRanges? n then key := key.insert n <| range.range.pos.line pure $ results.toArray.qsort fun (a, _) (b, _) => key.getD a 0 < key.getD b 0 /-- Formats a linter warning as `#check` command with comment. -/ def printWarning (declName : Name) (warning : MessageData) (useErrorFormat : Bool := false) (filePath : System.FilePath := default) : CoreM MessageData := do if useErrorFormat then if let some range ← findDeclarationRanges? declName then let msg ← addMessageContextPartial m!"{filePath}:{range.range.pos.line}:{range.range.pos.column + 1}: error: { ← mkConstWithLevelParams declName} {warning}" return msg addMessageContextPartial m!"#check {← mkConstWithLevelParams declName} /- {warning} -/" /-- Formats a map of linter warnings using `print_warning`, sorted by line number. -/ def printWarnings (results : Std.HashMap Name MessageData) (filePath : System.FilePath := default) (useErrorFormat : Bool := false) : CoreM MessageData := do (MessageData.joinSep ·.toList Format.line) <$> (← sortResults results).mapM fun (declName, warning) => printWarning declName warning (useErrorFormat := useErrorFormat) (filePath := filePath) /-- Formats a map of linter warnings grouped by filename with `-- filename` comments. The first `drop_fn_chars` characters are stripped from the filename. -/ def groupedByFilename (results : Std.HashMap Name MessageData) (useErrorFormat : Bool := false) : CoreM MessageData := do let sp ← if useErrorFormat then getSrcSearchPath else pure {} let grouped : Std.HashMap Name (System.FilePath × Std.HashMap Name MessageData) ← results.foldM (init := {}) fun grouped declName msg => do let mod ← findModuleOf? declName let mod := mod.getD (← getEnv).mainModule grouped.insert mod <$> match grouped[mod]? with | some (fp, msgs) => pure (fp, msgs.insert declName msg) | none => do let fp ← if useErrorFormat then pure <| (← sp.findWithExt "lean" mod).getD (modToFilePath "." mod "lean") else pure default pure (fp, .insert {} declName msg) let grouped' := grouped.toArray.qsort fun (a, _) (b, _) => toString a < toString b (MessageData.joinSep · (Format.line ++ Format.line)) <$> grouped'.toList.mapM fun (mod, fp, msgs) => do pure m!"-- {mod}\n{← printWarnings msgs (filePath := fp) (useErrorFormat := useErrorFormat)}" /-- Formats the linter results as Lean code with comments and `#check` commands. -/ def formatLinterResults (results : Array (NamedLinter × Std.HashMap Name MessageData)) (decls : Array Name) (groupByFilename : Bool) (whereDesc : String) (runSlowLinters : Bool) (verbose : LintVerbosity) (numLinters : Nat) (useErrorFormat : Bool := false) : CoreM MessageData := do let formattedResults ← results.filterMapM fun (linter, results) => do if !results.isEmpty then let warnings ← if groupByFilename || useErrorFormat then groupedByFilename results (useErrorFormat := useErrorFormat) else printWarnings results pure $ some m!"/- The `{linter.name}` linter reports:\n{linter.errorsFound} -/\n{warnings}\n" else if verbose = LintVerbosity.high then pure $ some m!"/- OK: {linter.noErrorsFound} -/" else pure none let mut s := MessageData.joinSep formattedResults.toList Format.line let numAutoDecls := (← decls.filterM isAutoDecl).size let failed := results.map (·.2.size) |>.foldl (·+·) 0 unless verbose matches LintVerbosity.low do s := m!"-- Found {failed} error{if failed == 1 then "" else "s" } in {decls.size - numAutoDecls} declarations (plus { numAutoDecls} automatically generated ones) {whereDesc } with {numLinters} linters\n\n{s}" unless runSlowLinters do s := m!"{s}-- (slow linters skipped)\n" pure s /-- Get the list of declarations in the current module. -/ def getDeclsInCurrModule : CoreM (Array Name) := do pure $ (← getEnv).constants.map₂.foldl (init := #[]) fun r k _ => r.push k /-- Get the list of all declarations in the environment. -/ def getAllDecls : CoreM (Array Name) := do pure $ (← getEnv).constants.map₁.fold (init := ← getDeclsInCurrModule) fun r k _ => r.push k /-- Get the list of all declarations in the specified package. -/ def getDeclsInPackage (pkg : Name) : CoreM (Array Name) := do let env ← getEnv let mut decls ← getDeclsInCurrModule let modules := env.header.moduleNames.map (pkg.isPrefixOf ·) return env.constants.map₁.fold (init := decls) fun decls declName _ => if modules[env.const2ModIdx[declName]?.get!]! then decls.push declName else decls /-- The `in foo` config argument allows running the linter on a specified project. -/ syntax inProject := " in " ident open Elab Command in /-- The command `#lint` runs the linters on the current file (by default). `#lint only someLinter` can be used to run only a single linter. -/ elab tk:"#lint" verbosity:("+" <|> "-")? fast:"*"? only:(&" only")? linters:(ppSpace ident)* project:(inProject)? : command => do let (decls, whereDesc, groupByFilename) ← match project with | none => do pure (← liftCoreM getDeclsInCurrModule, "in the current file", false) | some cfg => match cfg with | `(inProject| in $id) => let id := id.getId.eraseMacroScopes if id == `all then pure (← liftCoreM getAllDecls, "in all files", true) else pure (← liftCoreM (getDeclsInPackage id), s!"in {id}", true) | _ => throwUnsupportedSyntax let verbosity : LintVerbosity ← match verbosity with | none => pure .medium | some ⟨.node _ `token.«+» _⟩ => pure .high | some ⟨.node _ `token.«-» _⟩ => pure .low | _ => throwUnsupportedSyntax let fast := fast.isSome let onlyNames : Option (List Name) := match only.isSome with | true => some (linters.map fun l => l.getId).toList | false => none let linters ← liftCoreM do let mut result ← getChecks (slow := !fast) (runOnly := onlyNames) none let linterState := batteriesLinterExt.getState (← getEnv) for id in linters do let name := id.getId.eraseMacroScopes let some (declName, _) := linterState.find? name | throwErrorAt id "not a linter: {name}" Elab.addConstInfo id declName let linter ← getLinter name declName result := result.binInsert (·.name.lt ·.name) linter pure result let results ← liftCoreM <| lintCore decls linters let failed := results.any (!·.2.isEmpty) let mut fmtResults ← liftCoreM <| formatLinterResults results decls (groupByFilename := groupByFilename) whereDesc (runSlowLinters := !fast) verbosity linters.size if failed then logError fmtResults else if verbosity != LintVerbosity.low then logInfoAt tk m!"{fmtResults}\n-- All linting checks passed!" open Elab Command in /-- The command `#list_linters` prints a list of all available linters. -/ elab "#list_linters" : command => do let mut result := #[] for (name, _, dflt) in batteriesLinterExt.getState (← getEnv) do result := result.binInsert (·.1.lt ·.1) (name, dflt) let mut msg := m!"Available linters (linters marked with (*) are in the default lint set):" for (name, dflt) in result do msg := msg ++ m!"\n{name}{if dflt then " (*)" else ""}" logInfo msg initialize registerTraceClass `Batteries.Lint ================================================ FILE: Batteries/Tactic/Lint/Misc.lean ================================================ /- Copyright (c) 2020 Floris van Doorn. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Floris van Doorn, Robert Y. Lewis, Arthur Paulino, Gabriel Ebner -/ module public meta import Lean.Util.CollectLevelParams public meta import Lean.Util.ForEachExpr public meta import Lean.Meta.Check public meta import Lean.Meta.Instances public meta import Lean.Util.Recognizers public meta import Lean.DocString public meta import Batteries.Tactic.Lint.Basic public meta section open Lean Meta Std namespace Batteries.Tactic.Lint /-! # Various linters This file defines several small linters. -/ /-- A linter for checking whether a declaration has a namespace twice consecutively in its name. -/ @[env_linter] def dupNamespace : Linter where noErrorsFound := "No declarations have a duplicate namespace." errorsFound := "DUPLICATED NAMESPACES IN NAME:" test declName := do if ← isAutoDecl declName then return none if ← isImplicitReducible declName then return none let nm := declName.components let some (dup, _) := nm.zip nm.tail! |>.find? fun (x, y) => x == y | return none return m!"The namespace {dup} is duplicated in the name" /-- A linter for checking for unused arguments. We skip all declarations that contain `sorry` in their value. -/ @[env_linter] def unusedArguments : Linter where noErrorsFound := "No unused arguments." errorsFound := "UNUSED ARGUMENTS." test declName := do if ← isAutoDecl declName then return none if ← isProjectionFn declName then return none let info ← getConstInfo declName let ty := info.type let some val := info.value? | return none if val.hasSorry || ty.hasSorry then return none forallTelescope ty fun args ty => do let mut e := (mkAppN val args).headBeta e := mkApp e ty for arg in args do let ldecl ← getFVarLocalDecl arg e := mkApp e ldecl.type if let some val := ldecl.value? then e := mkApp e val let unused := args.zip (.range args.size) |>.filter fun (arg, _) => !e.containsFVar arg.fvarId! if unused.isEmpty then return none addMessageContextFull <| .joinSep (← unused.toList.mapM fun (arg, i) => return m!"argument {i+1} {arg} : {← inferType arg}") m!", " /-- A linter for checking definition doc strings. -/ @[env_linter] def docBlame : Linter where noErrorsFound := "No definitions are missing documentation." errorsFound := "DEFINITIONS ARE MISSING DOCUMENTATION STRINGS:" test declName := do -- leanprover/lean4#12263: isGlobalInstance was removed, use isInstance instead if (← isAutoDecl declName) || (← isInstance declName) then return none -- FIXME: scoped/local instances should also not be linted if let .str p _ := declName then if ← isInstance p then -- auxillary functions for instances should not be linted return none if let .str _ s := declName then if s == "parenthesizer" || s == "formatter" || s == "delaborator" || s == "quot" then return none let kind ← match ← getConstInfo declName with | .axiomInfo .. => pure "axiom" | .opaqueInfo .. => pure "constant" | .defnInfo info => -- leanprover/lean4#2575: Prop projections are generated as `def`s if ← isProjectionFn declName <&&> isProp info.type then return none pure "definition" | .inductInfo .. => pure "inductive" | _ => return none let (none) ← findDocString? (← getEnv) declName | return none return m!"{kind} missing documentation string" /-- A linter for checking theorem doc strings. -/ @[env_linter disabled] def docBlameThm : Linter where noErrorsFound := "No theorems are missing documentation." errorsFound := "THEOREMS ARE MISSING DOCUMENTATION STRINGS:" test declName := do if ← isAutoDecl declName then return none let kind ← match ← getConstInfo declName with | .thmInfo .. => pure "theorem" | .defnInfo info => -- leanprover/lean4#2575: -- projections are generated as `def`s even when they should be `theorem`s if ← isProjectionFn declName <&&> isProp info.type then pure "Prop projection" else return none | _ => return none let (none) ← findDocString? (← getEnv) declName | return none return m!"{kind} missing documentation string" /-- A linter for checking whether the correct declaration constructor (definition or theorem) has been used. -/ @[env_linter] def defLemma : Linter where noErrorsFound := "All declarations correctly marked as def/lemma." errorsFound := "INCORRECT DEF/LEMMA:" test declName := do if (← isAutoDecl declName) || (← isImplicitReducible declName) then return none -- leanprover/lean4#2575: -- projections are generated as `def`s even when they should be `theorem`s if ← isProjectionFn declName then return none let info ← getConstInfo declName let isThm ← match info with | .defnInfo .. => pure false | .thmInfo .. => pure true | _ => return none match isThm, ← isProp info.type with | true, false => pure "is a lemma/theorem, should be a def" | false, true => pure "is a def, should be lemma/theorem" | _, _ => return none /-- A linter for checking whether statements of declarations are well-typed. This linter is disabled by default: declarations are already type-checked when added to the environment, so re-checking every statement is redundant in normal use. As an alternative defence-in-depth measure for catching kernel/elaborator bugs, prefer running an external checker such as `lean4checker` or `trepplein`. -/ @[env_linter disabled] def checkType : Linter where noErrorsFound := "The statements of all declarations type-check with default reducibility settings." errorsFound := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS DO NOT TYPE-CHECK." isFast := true test declName := do if ← isAutoDecl declName then return none if ← isTypeCorrect (← getConstInfo declName).type then return none return m!"the statement doesn't type check." /-- `univParamsGrouped e` computes for each `level` `u` of `e` the parameters that occur in `u`, and returns the corresponding set of lists of parameters. In pseudo-mathematical form, this returns `{{p : parameter | p ∈ u} | (u : level) ∈ e}` FIXME: We use `Array Name` instead of `HashSet Name`, since `HashSet` does not have an equality instance. It will ignore `nm₀.proof_i` declarations. -/ private def univParamsGrouped (e : Expr) (nm₀ : Name) : Std.HashSet (Array Name) := runST fun σ => do let res ← ST.mkRef (σ := σ) {} e.forEach fun | .sort u => res.modify (·.insert (CollectLevelParams.visitLevel u {}).params) | .const n us => do if let .str n s .. := n then if n == nm₀ && s.startsWith "proof_" then return res.modify <| us.foldl (·.insert <| CollectLevelParams.visitLevel · {} |>.params) | _ => pure () res.get /-- The good parameters are the parameters that occur somewhere in the set as a singleton or (recursively) with only other good parameters. All other parameters in the set are bad. -/ private partial def badParams (l : Array (Array Name)) : Array Name := let goodLevels := l.filterMap fun | #[u] => some u | _ => none if goodLevels.isEmpty then l.flatten.toList.eraseDups.toArray else badParams <| l.map (·.filter (!goodLevels.contains ·)) /-- A linter for checking that there are no bad `max u v` universe levels. Checks whether all universe levels `u` in the type of `d` are "good". This means that `u` either occurs in a `level` of `d` by itself, or (recursively) with only other good levels. When this fails, usually this means that there is a level `max u v`, where neither `u` nor `v` occur by themselves in a level. It is ok if *one* of `u` or `v` never occurs alone. For example, `(α : Type u) (β : Type (max u v))` is a occasionally useful method of saying that `β` lives in a higher universe level than `α`. -/ @[env_linter] def checkUnivs : Linter where noErrorsFound := "All declarations have good universe levels." errorsFound := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS HAVE BAD UNIVERSE LEVELS. \ This usually means that there is a `max u v` in the type where neither `u` nor `v` \ occur by themselves. Solution: Find the type (or type bundled with data) that has this \ universe argument and provide the universe level explicitly. If this happens in an implicit \ argument of the declaration, a better solution is to move this argument to a `variables` \ command (then it's not necessary to provide the universe level).\n\n\ It is possible that this linter gives a false positive on definitions where the value of the \ definition has the universes occur separately, and the definition will usually be used with \ explicit universe arguments. In this case, feel free to add `@[nolint checkUnivs]`." isFast := true test declName := do if ← isAutoDecl declName then return none let bad := badParams (univParamsGrouped (← getConstInfo declName).type declName).toArray if bad.isEmpty then return none return m!"universes {bad} only occur together." /-- A linter for checking that declarations aren't syntactic tautologies. Checks whether a lemma is a declaration of the form `∀ a b ... z, e₁ = e₂` where `e₁` and `e₂` are identical exprs. We call declarations of this form syntactic tautologies. Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving basic facts with rfl when elaboration results in a different term than the user intended. -/ @[env_linter] def synTaut : Linter where noErrorsFound := "No declarations are syntactic tautologies." errorsFound := "THE FOLLOWING DECLARATIONS ARE SYNTACTIC TAUTOLOGIES. \ This usually means that they are of the form `∀ a b ... z, e₁ = e₂` where `e₁` and `e₂` are \ identical expressions. We call declarations of this form syntactic tautologies. \ Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving \ basic facts using `rfl`, when elaboration results in a different term than the user intended. \ You should check that the declaration really says what you think it does." isFast := true test declName := do if ← isAutoDecl declName then return none forallTelescope (← getConstInfo declName).type fun _ ty => do let some (lhs, rhs) := ty.eq?.map (fun (_, l, r) => (l, r)) <|> ty.iff? | return none if lhs == rhs then return m!"LHS equals RHS syntactically" return none /-- Return a list of unused `let_fun` terms in an expression that introduce proofs. -/ @[nolint unusedArguments] def findUnusedHaves (_ : Expr) : MetaM (Array MessageData) := do -- adaptation note: kmill 2025-06-29. `Expr.letFun?` is deprecated. -- This linter needs to be updated for `Expr.letE (nondep := true)`, but it has false -- positives, so I am disabling it for now. return #[] /- let res ← IO.mkRef #[] forEachExpr e fun e => do match e.letFun? with | some (n, t, _, b) => if n.isInternal then return if b.hasLooseBVars then return unless ← Meta.isProp t do return let msg ← addMessageContextFull m!"unnecessary have {n.eraseMacroScopes} : {t}" res.modify (·.push msg) | _ => return res.get -/ /-- A linter for checking that declarations don't have unused term mode have statements. -/ @[env_linter] def unusedHavesSuffices : Linter where noErrorsFound := "No declarations have unused term mode have statements." errorsFound := "THE FOLLOWING DECLARATIONS HAVE INEFFECTUAL TERM MODE HAVE/SUFFICES BLOCKS. \ In the case of `have` this is a term of the form `have h := foo, bar` where `bar` does not \ refer to `foo`. Such statements have no effect on the generated proof, and can just be \ replaced by `bar`, in addition to being ineffectual, they may make unnecessary assumptions \ in proofs appear as if they are used. \ For `suffices` this is a term of the form `suffices h : foo, proof_of_goal, proof_of_foo` \ where `proof_of_goal` does not refer to `foo`. \ Such statements have no effect on the generated proof, and can just be replaced by \ `proof_of_goal`, in addition to being ineffectual, they may make unnecessary assumptions \ in proofs appear as if they are used." test declName := do if ← isAutoDecl declName then return none let info ← getConstInfo declName let mut unused ← findUnusedHaves info.type if let some value := info.value? then unused := unused ++ (← findUnusedHaves value) unless unused.isEmpty do return some <| .joinSep unused.toList ", " return none /-- A linter for checking if variables appearing on both sides of an iff are explicit. Ideally, such variables should be implicit instead. -/ @[env_linter disabled] def explicitVarsOfIff : Linter where noErrorsFound := "No explicit variables on both sides of iff" errorsFound := "EXPLICIT VARIABLES ON BOTH SIDES OF IFF" test declName := do if ← isAutoDecl declName then return none forallTelescope (← getConstInfo declName).type fun args ty => do let some (lhs, rhs) := ty.iff? | return none let explicit ← args.filterM fun arg => return (← getFVarLocalDecl arg).binderInfo.isExplicit && lhs.containsFVar arg.fvarId! && rhs.containsFVar arg.fvarId! if explicit.isEmpty then return none addMessageContextFull m!"should be made implicit: { MessageData.joinSep (explicit.toList.map (m!"{·}")) ", "}" ================================================ FILE: Batteries/Tactic/Lint/Simp.lean ================================================ /- Copyright (c) 2020 Gabriel Ebner. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public meta import Lean.Meta.Tactic.Simp.Main public meta import Batteries.Tactic.Lint.Basic public meta import Batteries.Tactic.OpenPrivate public meta import Batteries.Util.LibraryNote import all Lean.Meta.Tactic.Simp.SimpTheorems public meta section open Lean Meta namespace Batteries.Tactic.Lint /-! # Linter for simplification lemmas This files defines several linters that prevent common mistakes when declaring simp lemmas: * `simpNF` checks that the left-hand side of a simp lemma is not simplified by a different lemma. * `simpVarHead` checks that the head symbol of the left-hand side is not a variable. * `simpComm` checks that commutativity lemmas are not marked as simplification lemmas. -/ /-- The data associated to a simp theorem. -/ structure SimpTheoremInfo where /-- The hypotheses of the theorem -/ hyps : Array Expr /-- The thing to replace -/ lhs : Expr /-- The result of replacement -/ rhs : Expr /-- Is this hypothesis a condition that might turn into a `simp` side-goal? i.e. is it a proposition that isn't marked as instance implicit? -/ def isCondition (h : Expr) : MetaM Bool := do let ldecl ← h.fvarId!.getDecl if ldecl.binderInfo.isInstImplicit then return false isProp ldecl.type /-- Runs the continuation on all the simp theorems encoded in the given type. -/ def withSimpTheoremInfos (ty : Expr) (k : SimpTheoremInfo → MetaM α) : MetaM (Array α) := withReducible do let e ← preprocess (← mkSorry ty true) ty (inv := false) (isGlobal := true) e.toArray.mapM fun (_, ty') => do forallTelescopeReducing ty' fun hyps eq => do let some (_, lhs, rhs) := eq.eq? | throwError "not an equality {eq}" k { hyps, lhs, rhs } /-- When true, the `simpNF` linter sets `backward.isDefEq.respectTransparency true` when comparing expressions in `isSimpEq`. This is stricter and will flag more simp lemmas as not in simp-normal form, in particular those where the left-hand side is not in normal form up to reducible defeq (e.g. lemmas involving type synonyms or bundled carrier types). Defaults to `false` to preserve the historical linter behavior, which uses `backward.isDefEq.respectTransparency false` to avoid false positives when `simp`/`dsimp` changes implicit arguments by unfolding carrier types in bundled structures. To find simp lemmas that fail with the stricter check, use: ``` set_option linter.simpNF.respectTransparency true in #lint only simpNF ``` -/ register_option linter.simpNF.respectTransparency : Bool := { defValue := false descr := "if true, the simpNF linter uses backward.isDefEq.respectTransparency when \ comparing expressions (catches more defeq abuse, but may produce false positives)" } /-- Checks whether two expressions are equal for the simplifier. That is, they are reducibly-definitional equal, and they have the same head symbol. -/ def isSimpEq (a b : Expr) (whnfFirst := true) : MetaM Bool := withReducible do let a ← if whnfFirst then whnf a else pure a let b ← if whnfFirst then whnf b else pure b if a.getAppFn.constName? != b.getAppFn.constName? then return false -- By default we use the old `isDefEq` behavior that does not respect transparency when -- checking implicit arguments. Without this, `simp`/`dsimp` changes to implicit arguments -- (e.g. unfolding carrier types) would cause false positives. -- Set `linter.simpNF.respectTransparency` to `true` to use the stricter behavior, -- which catches simp lemmas that rely on defeq abuse through type synonyms. let rt := linter.simpNF.respectTransparency.get (← getOptions) withOptions (fun opts => opts.setBool `backward.isDefEq.respectTransparency rt) do isDefEq a b /-- Constructs a message from all the simp theorems encoded in the given type. -/ def checkAllSimpTheoremInfos (ty : Expr) (k : SimpTheoremInfo → MetaM (Option MessageData)) : MetaM (Option MessageData) := do let errors := (← withSimpTheoremInfos ty fun i => do (← k i).mapM addMessageContextFull).filterMap id if errors.isEmpty then return none return MessageData.joinSep errors.toList Format.line /-- Returns true if this is a `@[simp]` declaration. -/ def isSimpTheorem (declName : Name) : MetaM Bool := do pure $ (← getSimpTheorems).lemmaNames.contains (.decl declName) open Lean.Meta.DiscrTree in /-- Returns the list of elements in the discrimination tree. -/ partial def _root_.Lean.Meta.DiscrTree.elements (d : DiscrTree α) : Array α := d.root.foldl (init := #[]) fun arr _ => trieElements arr where /-- Returns the list of elements in the trie. -/ trieElements (arr) | Trie.node vs children => children.foldl (init := arr ++ vs) fun arr (_, child) => trieElements arr child /-- Add message `msg` to any errors thrown inside `k`. -/ def decorateError (msg : MessageData) (k : MetaM α) : MetaM α := do try k catch e => throw (.error e.getRef m!"{msg}\n{e.toMessageData}") /-- Render the list of simp lemmas. -/ def formatLemmas (usedSimps : Simp.UsedSimps) (simpName : String) (higherOrder : Option Bool) : MetaM MessageData := do let mut args := if higherOrder == none then #[] else #[m!"*"] let env ← getEnv for (thm, _) in usedSimps.map.toArray.qsort (·.2 < ·.2) do if let .decl declName := thm then if env.contains declName && declName != ``eq_self then args := args.push m! "{← mkConstWithFreshMVarLevels declName}" let contextual? := if higherOrder == some true then " +contextual" else "" return m!"{simpName}{contextual?} only {args.toList}" /-- A linter for simp lemmas whose lhs is not in simp-normal form, and which hence never fire. -/ @[env_linter] def simpNF : Linter where noErrorsFound := "All left-hand sides of simp lemmas are in simp-normal form." errorsFound := "SOME SIMP LEMMAS ARE NOT IN SIMP-NORMAL FORM. Please change the lemma to make sure their left-hand sides are in simp normal form. To learn about simp normal forms, see https://leanprover-community.github.io/extras/simp.html#simp-normal-form and https://lean-lang.org/doc/reference/latest/The-Simplifier/Simp-Normal-Forms/." test := fun declName => do unless ← isSimpTheorem declName do return none withConfig Elab.Term.setElabConfig do checkAllSimpTheoremInfos (← getConstInfo declName).type fun { lhs, rhs, hyps, .. } => do -- we use `simp [*]` so that simp lemmas with hypotheses apply to themselves -- higher order simp lemmas need `simp +contextual [*]` to be able to apply to themselves let mut simpTheorems ← getSimpTheorems let mut higherOrder := false for h in hyps do if ← isCondition h then simpTheorems ← simpTheorems.add (.fvar h.fvarId!) #[] h if !higherOrder then higherOrder ← forallTelescope (← inferType h) fun hyps _ => hyps.anyM isCondition let ctx ← Simp.mkContext (config := { contextual := higherOrder }) (simpTheorems := #[simpTheorems]) (congrTheorems := ← getSimpCongrTheorems) let isRfl ← isRflTheorem declName let simplify (e : Expr) (ctx : Simp.Context) (stats : Simp.Stats := {}) : MetaM (Simp.Result × Simp.Stats) := do if !isRfl then simp e ctx (stats := stats) else let (e, s) ← dsimp e ctx (stats := stats) return (Simp.Result.mk e .none .true, s) let ({ expr := lhs', proof? := prf1, .. }, prf1Stats) ← decorateError "simplify fails on left-hand side:" <| simplify lhs ctx if prf1Stats.usedTheorems.map.contains (.decl declName) then return none let ({ expr := rhs', .. }, stats) ← decorateError "simplify fails on right-hand side:" <| simplify rhs ctx prf1Stats let lhs'EqRhs' ← isSimpEq lhs' rhs' (whnfFirst := false) let lhsInNF ← isSimpEq lhs' lhs let simpName := if !isRfl then "simp" else "dsimp" if lhs'EqRhs' then if prf1.isNone then return none -- TODO: FP rewriting foo.eq_2 using `simp only [foo]` return m!"\ {simpName} can prove this:\ \n by {← formatLemmas stats.usedTheorems simpName higherOrder}\ \nOne of the lemmas above could be a duplicate.\ \nIf that's not the case try reordering lemmas or adding @[priority]." else if ¬ lhsInNF then return m!"\ Left-hand side simplifies from\ \n {lhs}\ \nto\ \n {lhs'}\ \nusing\ \n {← formatLemmas prf1Stats.usedTheorems simpName higherOrder}\ \nTry to change the left-hand side to the simplified term!" else if lhs == lhs' then let lhsType ← inferType lhs let mut hints := m!"" for h in hyps do let ldecl ← h.fvarId!.getDecl let mut name := ldecl.userName if name.hasMacroScopes then name := sanitizeName name |>.run' { options := ← getOptions } if ← isProp ldecl.type then -- improve the error message if the hypothesis isn't in `simp` normal form let ({ expr := hType', .. }, stats) ← decorateError m!"simplify fails on hypothesis ({name} : {ldecl.type}):" <| simplify ldecl.type (← Simp.Context.mkDefault) unless ← isSimpEq hType' ldecl.type do hints := hints ++ m!"\ \nThe simp lemma may be invalid because hypothesis {name} simplifies from\ \n {ldecl.type}\ \nto\ \n {hType'}\ \nusing\ \n {← formatLemmas stats.usedTheorems simpName none}\ \nTry to change the hypothesis to the simplified term!" else -- improve the error message if the argument can't be filled in by `simp` if !ldecl.binderInfo.isInstImplicit && !lhs.containsFVar h.fvarId! && !lhsType.containsFVar h.fvarId! then hints := hints ++ m!"\ \nThe simp lemma is invalid because the value of argument\ \n {name} : {ldecl.type}\ \ncannot be inferred by `simp`." return m!"\ Left-hand side does not simplify, when using the simp lemma on itself. \nThis usually means that it will never apply.{hints}\n" else return none library_note «simp-normal form» /-- This note gives you some tips to debug any errors that the simp-normal form linter raises. The reason that a lemma was considered faulty is because its left-hand side is not in simp-normal form. These lemmas are hence never used by the simplifier. This linter gives you a list of other simp lemmas: look at them! Here are some tips depending on the error raised by the linter: 1. 'the left-hand side reduces to XYZ': you should probably use XYZ as the left-hand side. 2. 'simp can prove this': This typically means that lemma is a duplicate, or is shadowed by another lemma: 2a. Always put more general lemmas after specific ones: ``` @[simp] lemma zero_add_zero : 0 + 0 = 0 := rfl @[simp] lemma add_zero : x + 0 = x := rfl ``` And not the other way around! The simplifier always picks the last matching lemma. 2b. You can also use `@[priority]` instead of moving simp-lemmas around in the file. Tip: the default priority is 1000. Use `@[priority 1100]` instead of moving a lemma down, and `@[priority 900]` instead of moving a lemma up. 2c. Conditional simp lemmas are tried last. If they are shadowed just remove the `simp` attribute. 2d. If two lemmas are duplicates, the linter will complain about the first one. Try to fix the second one instead! (You can find it among the other simp lemmas the linter prints out!) 3. 'try_for tactic failed, timeout': This typically means that there is a loop of simp lemmas. Try to apply squeeze_simp to the right-hand side (removing this lemma from the simp set) to see what lemmas might be causing the loop. Another trick is to `set_option trace.simplify.rewrite true` and then apply `try_for 10000 { simp }` to the right-hand side. You will see a periodic sequence of lemma applications in the trace message. -/ /-- A linter for simp lemmas whose lhs has a variable as head symbol, and which hence never fire. -/ @[env_linter] def simpVarHead : Linter where noErrorsFound := "No left-hand sides of a simp lemma has a variable as head symbol." errorsFound := "LEFT-HAND SIDE HAS VARIABLE AS HEAD SYMBOL. Some simp lemmas have a variable as head symbol of the left-hand side (after whnfR):" test := fun declName => do unless ← isSimpTheorem declName do return none checkAllSimpTheoremInfos (← getConstInfo declName).type fun {lhs, ..} => do let lhs ← whnfR lhs let headSym := lhs.getAppFn unless headSym.isFVar do return none return m!"Left-hand side has variable as head symbol: {headSym}" private def Expr.eqOrIff? : Expr → Option (Expr × Expr) | .app (.app (.app (.const ``Eq _) _) lhs) rhs | .app (.app (.const ``Iff _) lhs) rhs => (lhs, rhs) | _ => none /-- A linter for commutativity lemmas that are marked simp. -/ @[env_linter] def simpComm : Linter where noErrorsFound := "No commutativity lemma is marked simp." errorsFound := "COMMUTATIVITY LEMMA IS SIMP. Some commutativity lemmas are simp lemmas:" test := fun declName => withSimpGlobalConfig do withReducible do unless ← isSimpTheorem declName do return none let ty := (← getConstInfo declName).type forallTelescopeReducing ty fun _ ty' => do let some (lhs, rhs) := ty'.eqOrIff? | return none unless lhs.getAppFn.constName? == rhs.getAppFn.constName? do return none let (_, _, ty') ← forallMetaTelescopeReducing ty let some (lhs', rhs') := ty'.eqOrIff? | return none unless ← isDefEq rhs lhs' do return none unless ← withNewMCtxDepth (isDefEq rhs lhs') do return none -- make sure that the discrimination tree will actually find this match (see #69) if (← (← DiscrTree.empty.insert rhs ()).getMatch lhs').isEmpty then return none -- ensure that the second application makes progress: if ← isDefEq lhs' rhs' then return none pure m!"should not be marked simp" ================================================ FILE: Batteries/Tactic/Lint/TypeClass.lean ================================================ /- Copyright (c) 2022 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public meta import Lean.Meta.Instances public meta import Batteries.Tactic.Lint.Basic public meta section namespace Batteries.Tactic.Lint open Lean Meta /-- Lints for instances with arguments that cannot be filled in, like ``` instance {α β : Type} [Group α] : Mul α where ... ``` -/ @[env_linter] def impossibleInstance : Linter where noErrorsFound := "No instance has arguments that are impossible to infer" errorsFound := "SOME INSTANCES HAVE ARGUMENTS THAT ARE IMPOSSIBLE TO INFER These are arguments that are not instance-implicit and do not appear in another instance-implicit argument or the return type." test declName := do unless ← isInstance declName do return none forallTelescopeReducing (← inferType (← mkConstWithLevelParams declName)) fun args ty => do let argTys ← args.mapM inferType let impossibleArgs ← args.zipIdx.filterMapM fun (arg, i) => do let fv := arg.fvarId! if (← fv.getDecl).binderInfo.isInstImplicit then return none if ty.containsFVar fv then return none if argTys[i+1:].any (·.containsFVar fv) then return none return some m!"argument {i+1} {arg} : {← inferType arg}" if impossibleArgs.isEmpty then return none addMessageContextFull <| .joinSep impossibleArgs.toList ", " /-- A linter for checking if any declaration whose type is not a class is marked as an instance. -/ @[env_linter] def nonClassInstance : Linter where noErrorsFound := "No instances of non-classes" errorsFound := "INSTANCES OF NON-CLASSES" test declName := do if !(← isInstance declName) then return none let info ← getConstInfo declName if !(← isClass? info.type).isSome then return "should not be an instance" return none ================================================ FILE: Batteries/Tactic/Lint.lean ================================================ module public import Batteries.Tactic.Lint.Basic public import Batteries.Tactic.Lint.Misc public import Batteries.Tactic.Lint.Simp public import Batteries.Tactic.Lint.TypeClass public import Batteries.Tactic.Lint.Frontend ================================================ FILE: Batteries/Tactic/NoMatch.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.DocString public meta import Lean.Elab.Tactic.Basic public meta section /-! Deprecation warnings for `match ⋯ with.`, `fun.`, `λ.`, and `intro.`. -/ namespace Batteries.Tactic open Lean Elab Term Tactic Parser.Term /-- The syntax `match ⋯ with.` has been deprecated in favor of `nomatch ⋯`. Both now support multiple discriminants. -/ elab (name := matchWithDot) (priority := low) tk:"match " t:term,* " with" "." : term <= expectedType? => do logWarningAt tk (← findDocString? (← getEnv) ``matchWithDot).get! elabTerm (← `(nomatch%$tk $[$t],*)) expectedType? /-- The syntax `fun.` has been deprecated in favor of `nofun`. -/ elab (name := funDot) (priority := low) tk:"fun" "." : term <= expectedType? => do logWarningAt tk (← findDocString? (← getEnv) ``funDot).get! elabTerm (← `(nofun)) expectedType? /-- The syntax `λ.` has been deprecated in favor of `nofun`. -/ elab (name := lambdaDot) (priority := low) tk:"λ" "." : term <= expectedType? => do logWarningAt tk (← findDocString? (← getEnv) ``lambdaDot).get! elabTerm (← `(nofun)) expectedType? @[inherit_doc matchWithDot] macro (priority := low) "match " discrs:term,* " with" "." : tactic => `(tactic| exact match $discrs,* with.) /-- The syntax `intro.` is deprecated in favor of `nofun`. -/ elab (name := introDot) tk:"intro" "." : tactic => do logWarningAt tk (← findDocString? (← getEnv) ``introDot).get! evalTactic (← `(tactic| nofun)) ================================================ FILE: Batteries/Tactic/OpenPrivate.lean ================================================ /- Copyright (c) 2021 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Command public meta import Lean.Util.FoldConsts public meta import Lean.Parser.Module public meta section open Lean Parser.Tactic Elab Command namespace Lean /-- Collects the names of private declarations referenced in definition `n`. -/ def Meta.collectPrivateIn [Monad m] [MonadEnv m] [MonadError m] (n : Name) (set := NameSet.empty) : m NameSet := do let c ← getConstInfo n let traverse value := Expr.foldConsts value set fun c a => if isPrivateName c then a.insert c else a if let some value := c.value? then return traverse value if let some c := (← getEnv).find? (n ++ `_cstage1) then if let some value := c.value? then return traverse value return traverse c.type /-- Get the module index given a module name. -/ def Environment.moduleIdxForModule? (env : Environment) (mod : Name) : Option ModuleIdx := (env.allImportedModuleNames.idxOf? mod).map fun idx => idx instance : DecidableEq ModuleIdx := instDecidableEqNat /-- Get the list of declarations in a module (referenced by index). -/ def Environment.declsInModuleIdx (env : Environment) (idx : ModuleIdx) : List Name := env.const2ModIdx.fold (fun acc n i => if i = idx then n :: acc else acc) [] /-- Add info to the info tree corresponding to a module name. -/ def Elab.addModuleInfo [Monad m] [MonadInfoTree m] (stx : Ident) : m Unit := do -- HACK: The server looks specifically for ofCommandInfo nodes on `import` syntax -- to do go-to-def for modules, so we have to add something that looks like an import -- to the info tree. (Ideally this would be an `.ofModuleInfo` node instead.) pushInfoLeaf <| .ofCommandInfo { elaborator := `import stx := Unhygienic.run `(Parser.Module.import| import $stx) |>.raw.copyHeadTailInfoFrom stx } namespace Elab.Command /-- Core elaborator for `open private` and `export private`. -/ def elabOpenPrivateLike (ids : Array Ident) (tgts mods : Option (Array Ident)) (f : (priv full user : Name) → CommandElabM Name) : CommandElabM Unit := do let mut names := NameSet.empty for tgt in tgts.getD #[] do let n ← liftCoreM <| realizeGlobalConstNoOverloadWithInfo tgt names ← Meta.collectPrivateIn n names let env ← getEnv for mod in mods.getD #[] do let some modIdx := env.moduleIdxForModule? mod.getId | throwError "unknown module {mod}" addModuleInfo mod for declName in env.declsInModuleIdx modIdx do if isPrivateName declName then names := names.insert declName let appendNames (msg : MessageData) : MessageData := Id.run do let mut msg := msg for c in names do if let some info := env.findConstVal? c then msg := msg ++ m!"{mkConst c (info.levelParams.map mkLevelParam)}\n" else if let some name := privateToUserName? c then msg := msg ++ s!"{name}\n" msg if ids.isEmpty && !names.isEmpty then logInfo (appendNames "found private declarations:\n") let mut decls := #[] for id in ids do let n := id.getId let rec /-- finds private declarations `n ++ suff` where `n` resolves and `n ++ suff` realizes -/ findAll n suff := do let mut found := [] for c in names do if n.isSuffixOf c then let (c', ok) ← if suff.isAnonymous then pure (c, true) else let c' := c ++ suff if (← getEnv).contains c' then pure (c', true) else try liftCoreM (executeReservedNameAction c') pure (c', (← getEnv).containsOnBranch c') catch _ => pure (c', false) if ok then addConstInfo id c' found := c'::found unless found = [] do return found match n with | .str p s => findAll p (Name.mkSimple s ++ suff) | _ => pure [] match ← findAll n .anonymous with | [] => throwError appendNames m!"'{n}' not found in the provided declarations:\n" | [c] => if let some name := privateToUserName? c then let new ← f c name n decls := decls.push (.explicit n new) else unreachable! | found => throwError s!"provided name is ambiguous: found {found.map privateToUserName?}" modifyScope fun scope => Id.run do let mut openDecls := scope.openDecls for decl in decls do openDecls := decl::openDecls { scope with openDecls := openDecls } /-- The command `open private a b c in foo bar` will look for private definitions named `a`, `b`, `c` in declarations `foo` and `bar` and open them in the current scope. This does not make the definitions public, but rather makes them accessible in the current section by the short name `a` instead of the (unnameable) internal name for the private declaration, something like `_private.Other.Module.0.Other.Namespace.foo.a`, which cannot be typed directly because of the `0` name component. It is also possible to specify the module instead with `open private a b c from Other.Module`. -/ syntax (name := openPrivate) "open" ppSpace "private" (ppSpace ident)* (" in" (ppSpace ident)*)? (" from" (ppSpace ident)*)? : command /-- Elaborator for `open private`. -/ @[command_elab openPrivate] def elabOpenPrivate : CommandElab | `(open private $ids* $[in $tgts*]? $[from $mods*]?) => elabOpenPrivateLike ids tgts mods fun c _ _ => pure c | _ => throwUnsupportedSyntax /-- The command `export private a b c in foo bar` is similar to `open private`, but instead of opening them in the current scope it will create public aliases to the private definition. The definition will exist at exactly the original location and name, as if the `private` keyword was not used originally. It will also open the newly created alias definition under the provided short name, like `open private`. It is also possible to specify the module instead with `export private a b c from Other.Module`. -/ syntax (name := exportPrivate) "export" ppSpace "private" (ppSpace ident)* (" in" (ppSpace ident)*)? (" from" (ppSpace ident)*)? : command /-- Elaborator for `export private`. -/ @[command_elab exportPrivate] def elabExportPrivate : CommandElab | `(export private $ids* $[in $tgts*]? $[from $mods*]?) => elabOpenPrivateLike ids tgts mods fun c name _ => liftCoreM do let cinfo ← getConstInfo c if (← getEnv).contains name then throwError s!"'{name}' has already been declared" let decl := Declaration.defnDecl { name := name, levelParams := cinfo.levelParams, type := cinfo.type, value := mkConst c (cinfo.levelParams.map mkLevelParam), hints := ReducibilityHints.abbrev, safety := if cinfo.isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe } addDecl decl compileDecl decl pure name | _ => throwUnsupportedSyntax ================================================ FILE: Batteries/Tactic/PermuteGoals.lean ================================================ /- Copyright (c) 2022 Arthur Paulino. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Arthur Paulino, Mario Carneiro -/ module public meta import Lean.Elab.Tactic.Basic public meta section /-! # The `on_goal`, `pick_goal`, and `swap` tactics. `pick_goal n` moves the `n`-th goal to the front. If `n` is negative this is counted from the back. `on_goal n => tacSeq` focuses on the `n`-th goal and runs a tactic block `tacSeq`. If `tacSeq` does not close the goal any resulting subgoals are inserted back into the list of goals. If `n` is negative this is counted from the back. `swap` is a shortcut for `pick_goal 2`, which interchanges the 1st and 2nd goals. -/ namespace Batteries.Tactic open Lean Elab.Tactic /-- If the current goals are `g₁ ⋯ gᵢ ⋯ gₙ`, `splitGoalsAndGetNth i` returns `(gᵢ, [g₁, ⋯, gᵢ₋₁], [gᵢ₊₁, ⋯, gₙ])`. If `reverse` is passed as `true`, the `i`-th goal is picked by counting backwards. For instance, `splitGoalsAndGetNth 1 true` puts the last goal in the first component of the returned term. -/ def splitGoalsAndGetNth (nth : Nat) (reverse : Bool := false) : TacticM (MVarId × List MVarId × List MVarId) := do if nth = 0 then throwError "goals are 1-indexed" let goals ← getGoals let nGoals := goals.length if nth > nGoals then throwError "goal index out of bounds" let n := if ¬reverse then nth - 1 else nGoals - nth let (gl, g :: gr) := goals.splitAt n | throwNoGoalsToBeSolved pure (g, gl, gr) /-- `pick_goal n` will move the `n`-th goal to the front. `pick_goal -n` will move the `n`-th goal (counting from the bottom) to the front. See also `Tactic.rotate_goals`, which moves goals from the front to the back and vice-versa. -/ elab "pick_goal " reverse:"-"? n:num : tactic => do let (g, gl, gr) ← splitGoalsAndGetNth n.1.toNat !reverse.isNone setGoals $ g :: (gl ++ gr) /-- `swap` is a shortcut for `pick_goal 2`, which interchanges the 1st and 2nd goals. -/ macro "swap" : tactic => `(tactic| pick_goal 2) /-- `on_goal n => tacSeq` creates a block scope for the `n`-th goal and tries the sequence of tactics `tacSeq` on it. `on_goal -n => tacSeq` does the same, but the `n`-th goal is chosen by counting from the bottom. The goal is not required to be solved and any resulting subgoals are inserted back into the list of goals, replacing the chosen goal. -/ elab "on_goal " reverse:"-"? n:num " => " seq:tacticSeq : tactic => do let (g, gl, gr) ← splitGoalsAndGetNth n.1.toNat !reverse.isNone setGoals [g] evalTactic seq setGoals $ gl ++ (← getUnsolvedGoals) ++ gr ================================================ FILE: Batteries/Tactic/PrintDependents.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Command public meta import Lean.Util.FoldConsts public meta section /-! # `#print dependents` command This is a variation on `#print axioms` where one instead specifies the axioms to avoid, and it prints a list of all the theorems in the file that depend on that axiom, and the list of all theorems directly referenced that are "to blame" for this dependency. Useful for debugging unexpected dependencies. -/ namespace Batteries.Tactic open Lean Elab Command namespace CollectDependents /-- Collects the result of a `CollectDependents` query. -/ structure State where /-- If true, an axiom not in the initial list will be considered as marked. -/ otherAxiom : Bool := true /-- The cached results on visited constants. -/ result : NameMap Bool := {} /-- The monad used by `CollectDependents`. -/ abbrev M := ReaderT Environment $ StateM State /-- Constructs the initial state, marking the constants in `cs`. The result of `collect` will say whether a given declaration depends transitively on one of these constants. If `otherAxiom` is true, any axiom not specified in `cs` will also be tracked. -/ def mkState (cs : Array (Name × Bool)) (otherAxiom := true) : State := { otherAxiom, result := cs.foldl (fun r (c, b) => r.insert c b) {} } /-- Collect the results for a given constant. -/ partial def collect (c : Name) : M Bool := do let collectExpr (e : Expr) : M Bool := e.getUsedConstants.anyM collect let s ← get if let some b := s.result.find? c then return b modify fun s => { s with result := s.result.insert c false } let env ← read let r ← match env.find? c with | some (ConstantInfo.axiomInfo _) => pure s.otherAxiom | some (ConstantInfo.defnInfo v) => collectExpr v.type <||> collectExpr v.value | some (ConstantInfo.thmInfo v) => collectExpr v.type <||> collectExpr v.value | some (ConstantInfo.opaqueInfo v) => collectExpr v.type <||> collectExpr v.value | some (ConstantInfo.quotInfo _) => pure false | some (ConstantInfo.ctorInfo v) => collectExpr v.type | some (ConstantInfo.recInfo v) => collectExpr v.type | some (ConstantInfo.inductInfo v) => collectExpr v.type <||> v.ctors.anyM collect | none => pure false modify fun s => { s with result := s.result.insert c r } pure r end CollectDependents /-- The command `#print dependents X Y` prints a list of all the declarations in the file that transitively depend on `X` or `Y`. After each declaration, it shows the list of all declarations referred to directly in the body which also depend on `X` or `Y`. For example, `#print axioms bar'` below shows that `bar'` depends on `Classical.choice`, but not why. `#print dependents Classical.choice` says that `bar'` depends on `Classical.choice` because it uses `foo` and `foo` uses `Classical.em`. `bar` is not listed because it is proved without using `Classical.choice`. ``` import Batteries.Tactic.PrintDependents theorem foo : x = y ∨ x ≠ y := Classical.em _ theorem bar : 1 = 1 ∨ 1 ≠ 1 := by simp theorem bar' : 1 = 1 ∨ 1 ≠ 1 := foo #print axioms bar' -- 'bar'' depends on axioms: [Classical.choice, Quot.sound, propext] #print dependents Classical.choice -- foo: Classical.em -- bar': foo ``` -/ elab tk:"#print" &"dependents" ids:(ppSpace colGt ident)* : command => do let env ← getEnv let ids ← ids.mapM fun c => return (← liftCoreM <| realizeGlobalConstNoOverloadWithInfo c, true) let init := CollectDependents.mkState ids false let mut state := init let mut out := #[] for (c, _) in env.constants.map₂ do let (b, state') := CollectDependents.collect c |>.run env |>.run state state := state' if b then if let some ranges ← findDeclarationRanges? c then out := out.push (c, ranges.range.pos.1) let msg ← out.qsort (·.2 < ·.2) |>.mapM fun (c, _) => do let mut msg := m!"{MessageData.ofConst (← mkConstWithLevelParams c)}: " if init.result.contains c then msg := msg ++ m!"" else let consts := match env.find? c with | some (ConstantInfo.defnInfo v) => v.type.getUsedConstants ++ v.value.getUsedConstants | some (ConstantInfo.thmInfo v) => v.type.getUsedConstants ++ v.value.getUsedConstants | some (ConstantInfo.opaqueInfo v) => v.type.getUsedConstants ++ v.value.getUsedConstants | some (ConstantInfo.ctorInfo v) => v.type.getUsedConstants | some (ConstantInfo.recInfo v) => v.type.getUsedConstants | some (ConstantInfo.inductInfo v) => v.type.getUsedConstants ++ v.ctors | _ => #[] for c in Std.TreeSet.ofArray consts Name.cmp do if state.result.find? c = some true then msg := msg ++ m!"{MessageData.ofConst (← mkConstWithLevelParams c)} " return msg logInfoAt tk (.joinSep msg.toList "\n") ================================================ FILE: Batteries/Tactic/PrintOpaques.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Command public meta import Lean.Util.FoldConsts public meta section open Lean Elab Command namespace Batteries.Tactic.CollectOpaques /-- Collects the result of a `CollectOpaques` query. -/ structure State where /-- The set visited constants. -/ visited : NameSet := {} /-- The collected opaque defs. -/ opaques : Array Name := #[] /-- The monad used by `CollectOpaques`. -/ abbrev M := ReaderT Environment <| StateT State MetaM /-- Collect the results for a given constant. -/ partial def collect (c : Name) : M Unit := do let collectExpr (e : Expr) : M Unit := e.getUsedConstants.forM collect let s ← get unless s.visited.contains c do modify fun s => { s with visited := s.visited.insert c } let env ← read match env.find? c with | some (ConstantInfo.ctorInfo _) | some (ConstantInfo.recInfo _) | some (ConstantInfo.inductInfo _) | some (ConstantInfo.quotInfo _) => pure () | some (ConstantInfo.defnInfo v) | some (ConstantInfo.thmInfo v) => unless ← Meta.isProp v.type do collectExpr v.value | some (ConstantInfo.axiomInfo v) | some (ConstantInfo.opaqueInfo v) => unless ← Meta.isProp v.type do modify fun s => { s with opaques := s.opaques.push c } | none => throwUnknownConstant c end CollectOpaques /-- The command `#print opaques X` prints all opaque definitions that `X` depends on. Opaque definitions include partial definitions and axioms. Only dependencies that occur in a computationally relevant context are listed, occurrences within proof terms are omitted. This is useful to determine whether and how a definition is possibly platform dependent, possibly partial, or possibly noncomputable. The command `#print opaques Std.HashMap.insert` shows that `Std.HashMap.insert` depends on the opaque definitions: `System.Platform.getNumBits` and `UInt64.toUSize`. Thus `Std.HashMap.insert` may have different behavior when compiled on a 32 bit or 64 bit platform. The command `#print opaques Stream.forIn` shows that `Stream.forIn` is possibly partial since it depends on the partial definition `Stream.forIn.visit`. Indeed, `Stream.forIn` may not terminate when the input stream is unbounded. The command `#print opaques Classical.choice` shows that `Classical.choice` is itself an opaque definition: it is an axiom. However, `#print opaques Classical.axiomOfChoice` returns nothing since it is a proposition, hence not computationally relevant. (The command `#print axioms` does reveal that `Classical.axiomOfChoice` depends on the `Classical.choice` axiom.) -/ elab "#print" &"opaques" name:ident : command => do let constName ← liftCoreM <| realizeGlobalConstNoOverloadWithInfo name let env ← getEnv let (_, s) ← liftTermElabM <| ((CollectOpaques.collect constName).run env).run {} if s.opaques.isEmpty then logInfo m!"'{constName}' does not use any opaque or partial definitions" else logInfo m!"'{constName}' depends on opaque or partial definitions: {s.opaques.toList}" ================================================ FILE: Batteries/Tactic/PrintPrefix.lean ================================================ /- Copyright (c) 2021 Shing Tak Lam. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Shing Tak Lam, Daniel Selsam, Mario Carneiro -/ module public meta import Batteries.Lean.Util.EnvSearch public meta import Lean.Elab.Tactic.Config public meta import Lean.Elab.Command public meta section namespace Batteries.Tactic open Lean Elab Command /-- Options to control `#print prefix` command and `getMatchingConstants`. -/ structure PrintPrefixConfig where /-- Include declarations in imported environment. -/ imported : Bool := true /-- Include declarations whose types are propositions. -/ propositions : Bool := true /-- Exclude declarations whose types are not propositions. -/ propositionsOnly : Bool := false /-- Print the type of a declaration. -/ showTypes : Bool := true /-- Include internal declarations (names starting with `_`, `match_` or `proof_`) -/ internals : Bool := false /-- Function elaborating `Config`. -/ declare_command_config_elab elabPrintPrefixConfig PrintPrefixConfig /-- `reverseName name` reverses the components of a name. -/ private def reverseName : Name → (pre : Name := .anonymous) → Name | .anonymous, p => p | .str q s, p => reverseName q (.str p s) | .num q n, p => reverseName q (.num p n) /-- `takeNameSuffix n name` returns a pair `(pre, suf)` where `suf` contains the last `n` components of the name and `pre` contains the rest. -/ private def takeNameSuffix (cnt : Nat) (name : Name) (pre : Name := .anonymous) : Name × Name := match cnt, name with | .succ cnt, .str q s => takeNameSuffix cnt q (.str pre s) | .succ cnt, .num q n => takeNameSuffix cnt q (.num pre n) | _, name => (name, reverseName pre) /-- `matchName opts pre cinfo` returns true if the search options should include the constant. -/ private def matchName (opts : PrintPrefixConfig) (pre : Name) (cinfo : ConstantInfo) : MetaM Bool := do let name := cinfo.name unless (← hasConst name) do -- some compiler decls are not known to the elab env, ignore them return false let preCnt := pre.getNumParts let nameCnt := name.getNumParts if preCnt > nameCnt then return false let (root, post) := takeNameSuffix (nameCnt - preCnt) name if root ≠ pre then return false if !opts.internals && post.isInternalDetail then return false if opts.propositions != opts.propositionsOnly then return opts.propositions let isProp := (Expr.isProp <$> Lean.Meta.inferType cinfo.type) <|> pure false pure <| opts.propositionsOnly == (← isProp) private def lexNameLt : Name -> Name -> Bool | _, .anonymous => false | .anonymous, _ => true | .num p m, .num q n => m < n || m == n && lexNameLt p q | .num _ _, .str _ _ => true | .str _ _, .num _ _ => false | .str p m, .str q n => m < n || m == n && lexNameLt p q private def matchingConstants (opts : PrintPrefixConfig) (pre : Name) : MetaM (Array MessageData) := do let cinfos ← getMatchingConstants (matchName opts pre) opts.imported let cinfos := cinfos.qsort fun p q => lexNameLt (reverseName p.name) (reverseName q.name) cinfos.mapM fun cinfo => do if opts.showTypes then pure <| MessageData.signature cinfo.name ++ "\n" else pure m!"{MessageData.ofConst (← mkConstWithLevelParams cinfo.name)}\n" /-- The command `#print prefix foo` will print all definitions that start with the namespace `foo`. For example, the command below will print out definitions in the `List` namespace: ```lean #print prefix List ``` `#print prefix` can be controlled by flags in `PrintPrefixConfig`. These provide options for filtering names and formatting. For example, `#print prefix` by default excludes internal names, but this can be controlled via config: ```lean #print prefix (config := {internals := true}) List ``` By default, `#print prefix` prints the type after each name. This can be controlled by setting `showTypes` to `false`: ```lean #print prefix (config := {showTypes := false}) List ``` The complete set of flags can be seen in the documentation for `Lean.Elab.Command.PrintPrefixConfig`. -/ elab (name := printPrefix) tk:"#print " colGt "prefix" cfg:Lean.Parser.Tactic.optConfig name:(ident)? : command => do if let some name := name then let opts ← elabPrintPrefixConfig cfg liftTermElabM do let mut msgs ← matchingConstants opts name.getId if msgs.isEmpty then if let [name] ← resolveGlobalConst name then msgs ← matchingConstants opts name logInfoAt tk (.joinSep msgs.toList "") ================================================ FILE: Batteries/Tactic/SeqFocus.lean ================================================ /- Copyright (c) 2022 Jeremy Avigad. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Jeremy Avigad -/ module public meta import Lean.Elab.Tactic.Basic public meta section open Lean Elab Meta Tactic namespace Batteries.Tactic /-- Assuming there are `n` goals, `map_tacs [t1; t2; ...; tn]` applies each `ti` to the respective goal and leaves the resulting subgoals. -/ elab "map_tacs " "[" ts:sepBy(tactic, "; ") "]" : tactic => do let goals ← getUnsolvedGoals let tacs := ts.getElems let length := tacs.size if length < goals.length then throwError "not enough tactics" else if length > goals.length then throwError "too many tactics" let mut goalsNew := #[] for tac in tacs, goal in goals do if ← goal.isAssigned then continue setGoals [goal] try evalTactic tac goalsNew := goalsNew ++ (← getUnsolvedGoals) catch ex => if (← read).recover then logException ex goalsNew := goalsNew.push goal else throw ex setGoals goalsNew.toList /-- `t <;> [t1; t2; ...; tn]` focuses on the first goal and applies `t`, which should result in `n` subgoals. It then applies each `ti` to the corresponding goal and collects the resulting subgoals. -/ macro:1 (name := seq_focus) t:tactic " <;> " "[" ts:sepBy(tactic, "; ") "]" : tactic => `(tactic| focus ( $t:tactic; map_tacs [$ts;*]) ) ================================================ FILE: Batteries/Tactic/ShowUnused.lean ================================================ /- Copyright (c) 2024 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Util.FoldConsts public meta import Lean.Linter.UnusedVariables public meta section /-! # The `#show_unused` command `#show_unused decl1 decl2 ..` will highlight every theorem or definition in the current file not involved in the definition of declarations `decl1`, `decl2`, etc. The result is shown both in the message on `#show_unused`, as well as on the declarations themselves. -/ namespace Batteries.Tactic.ShowUnused open Lean Elab Command variable (env : Environment) in private partial def visit (n : Name) : StateM NameSet Unit := do if (← get).contains n then modify (·.erase n) let rec visitExpr (e : Expr) : StateM NameSet Unit := e.getUsedConstants.forM visit match env.find? n with | some (ConstantInfo.axiomInfo v) => visitExpr v.type | some (ConstantInfo.defnInfo v) => visitExpr v.type *> visitExpr v.value | some (ConstantInfo.thmInfo v) => visitExpr v.type *> visitExpr v.value | some (ConstantInfo.opaqueInfo v) => visitExpr v.type *> visitExpr v.value | some (ConstantInfo.quotInfo _) => pure () | some (ConstantInfo.ctorInfo v) => visitExpr v.type | some (ConstantInfo.recInfo v) => visitExpr v.type | some (ConstantInfo.inductInfo v) => visitExpr v.type *> v.ctors.forM visit | none => pure () /-- `#show_unused decl1 decl2 ..` will highlight every theorem or definition in the current file not involved in the definition of declarations `decl1`, `decl2`, etc. The result is shown both in the message on `#show_unused`, as well as on the declarations themselves. ``` def foo := 1 def baz := 2 def bar := foo #show_unused bar -- highlights `baz` ``` -/ elab tk:"#show_unused" ids:(ppSpace colGt ident)* : command => do let ns ← ids.mapM fun s => liftCoreM <| realizeGlobalConstNoOverloadWithInfo s let env ← getEnv let decls := env.constants.map₂.foldl (fun m n _ => m.insert n) {} let mut unused := #[] let fileMap ← getFileMap for c in ((ns.forM (visit env)).run decls).2 do if let some { selectionRange := range, .. } := declRangeExt.find? env c then unused := unused.push (c, { start := fileMap.ofPosition range.pos stop := fileMap.ofPosition range.endPos }) unused := unused.qsort (·.2.start < ·.2.start) let pos := fileMap.toPosition <| (tk.getPos? <|> (← getRef).getPos?).getD 0 let pfx := m!"#show_unused (line {pos.line}) says:\n" let post := m!" is not used transitively by \ {← ns.mapM (MessageData.ofConst <$> mkConstWithLevelParams ·)}" for (c, range) in unused do logWarningAt (Syntax.ofRange range) <| .tagged Linter.linter.unusedVariables.name <| m!"{pfx}{MessageData.ofConst (← mkConstWithLevelParams c)}{post}" if unused.isEmpty then logInfoAt tk "No unused definitions" else logWarningAt tk <| m!"unused definitions in this file:\n" ++ m!"\n".joinSep (← unused.toList.mapM (toMessageData <$> mkConstWithLevelParams ·.1)) ================================================ FILE: Batteries/Tactic/SqueezeScope.lean ================================================ /- Copyright (c) 2022 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Tactic.SimpTrace public meta section /-! # `squeeze_scope` tactic The `squeeze_scope` tactic allows aggregating multiple calls to `simp` coming from the same syntax but in different branches of execution, such as in `cases x <;> simp`. The reported `simp` call covers all simp lemmas used by this syntax. -/ namespace Batteries.Tactic open Lean Elab Parser Tactic Meta.Tactic /-- `squeeze_scope a => tacs` is part of the implementation of `squeeze_scope`. Inside `tacs`, invocations of `simp` wrapped with `squeeze_wrap a _ => ...` will contribute to the accounting associated to scope `a`. -/ local syntax (name := squeezeScopeIn) "squeeze_scope " ident " => " tacticSeq : tactic /-- `squeeze_wrap a x => tac` is part of the implementation of `squeeze_scope`. Here `tac` will be a `simp` or `dsimp` syntax, and `squeeze_wrap` will run the tactic and contribute the generated `usedSimps` to the `squeezeScopes[a][x]` variable. -/ local syntax (name := squeezeWrap) "squeeze_wrap " ident ppSpace ident " => " tactic : tactic open TSyntax.Compat in /-- The `squeeze_scope` tactic allows aggregating multiple calls to `simp` coming from the same syntax but in different branches of execution, such as in `cases x <;> simp`. The reported `simp` call covers all simp lemmas used by this syntax. ``` @[simp] def bar (z : Nat) := 1 + z @[simp] def baz (z : Nat) := 1 + z @[simp] def foo : Nat → Nat → Nat | 0, z => bar z | _+1, z => baz z example : foo x y = 1 + y := by cases x <;> simp? -- two printouts: -- "Try this: simp only [foo, bar]" -- "Try this: simp only [foo, baz]" example : foo x y = 1 + y := by squeeze_scope cases x <;> simp -- only one printout: "Try this: simp only [foo, baz, bar]" ``` -/ macro (name := squeezeScope) "squeeze_scope " seq:tacticSeq : tactic => do let a ← withFreshMacroScope `(a) let seq ← seq.raw.rewriteBottomUpM fun stx => match stx.getKind with | ``dsimp | ``simpAll | ``simp | ``dsimpTrace | ``simpAllTrace | ``simpTrace => do withFreshMacroScope `(tactic| squeeze_wrap $a x => $stx) | _ => pure stx `(tactic| squeeze_scope $a => $seq) open Meta /-- We implement `squeeze_scope` using a global variable that tracks all `squeeze_scope` invocations in flight. It is a map `a => (x => (stx, simps))` where `a` is a unique identifier for the `squeeze_scope` invocation which is shared with all contained simps, and `x` is a unique identifier for a particular piece of simp syntax (which can be called multiple times). Within that, `stx` is the simp syntax itself, and `simps` is the aggregated list of simps used so far. -/ initialize squeezeScopes : IO.Ref (NameMap (NameMap (Syntax × List Simp.UsedSimps))) ← IO.mkRef {} elab_rules : tactic | `(tactic| squeeze_scope $a => $tac) => do let a := a.getId let old ← squeezeScopes.modifyGet fun map => (map.find? a, map.insert a {}) let reset map := match old with | some old => map.insert a old | none => map.erase a let new ← try Elab.Tactic.evalTactic tac squeezeScopes.modifyGet fun map => (map.find? a, reset map) catch e => squeezeScopes.modify reset throw e if let some new := new then for (_, stx, usedSimps) in new do let usedSimps := usedSimps.reverse.foldl (fun s usedSimps => usedSimps.toArray.foldl .insert s) {} let stx' ← mkSimpCallStx stx usedSimps TryThis.addSuggestion stx[0] stx' (origSpan? := stx) elab_rules : tactic | `(tactic| squeeze_wrap $a $x => $tac) => do let stx := tac.raw -- Returns (stats, syntaxToStore) where syntaxToStore is the non-trace syntax for mkSimpCallStx let (stats, stxToStore) ← match stx.getKind with | ``Parser.Tactic.simp => do let { ctx, simprocs, dischargeWrapper, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) let stats ← dischargeWrapper.with fun discharge? => simpLocation ctx simprocs discharge? (expandOptLocation stx[5]) pure (stats, stx) | ``Parser.Tactic.simpAll => do let { ctx, simprocs, .. } ← mkSimpContext stx (eraseLocal := true) (kind := .simpAll) (ignoreStarArg := true) let (result?, stats) ← simpAll (← getMainGoal) ctx simprocs match result? with | none => replaceMainGoal [] | some mvarId => replaceMainGoal [mvarId] pure (stats, stx) | ``Parser.Tactic.dsimp => do let { ctx, simprocs, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp) let stats ← dsimpLocation' ctx simprocs (expandOptLocation stx[5]) pure (stats, stx) | ``simpTrace => do -- Convert simp? to simp and run match tac with | `(tactic| simp?%$tk $[!%$bang]? $cfg:optConfig $(discharger)? $[only%$o]? $[[$args,*]]? $(loc)?) => let simpStx ← if bang.isSome then `(tactic| simp!%$tk $cfg:optConfig $[$discharger]? $[only%$o]? $[[$args,*]]? $[$loc]?) else `(tactic| simp%$tk $cfg:optConfig $[$discharger]? $[only%$o]? $[[$args,*]]? $[$loc]?) let { ctx, simprocs, dischargeWrapper, .. } ← withMainContext <| mkSimpContext simpStx.raw (eraseLocal := false) let stats ← dischargeWrapper.with fun discharge? => simpLocation ctx simprocs discharge? (expandOptLocation simpStx.raw[5]) pure (stats, simpStx.raw) | _ => Elab.throwUnsupportedSyntax | ``simpAllTrace => do -- Convert simp_all? to simp_all and run match tac with | `(tactic| simp_all?%$tk $[!%$bang]? $cfg:optConfig $(discharger)? $[only%$o]? $[[$args,*]]?) => let simpStx ← if bang.isSome then `(tactic| simp_all!%$tk $cfg:optConfig $[$discharger]? $[only%$o]? $[[$args,*]]?) else `(tactic| simp_all%$tk $cfg:optConfig $[$discharger]? $[only%$o]? $[[$args,*]]?) let { ctx, simprocs, .. } ← mkSimpContext simpStx.raw (eraseLocal := true) (kind := .simpAll) (ignoreStarArg := true) let (result?, stats) ← simpAll (← getMainGoal) ctx simprocs match result? with | none => replaceMainGoal [] | some mvarId => replaceMainGoal [mvarId] pure (stats, simpStx.raw) | _ => Elab.throwUnsupportedSyntax | ``dsimpTrace => do -- Convert dsimp? to dsimp and run match tac with | `(tactic| dsimp?%$tk $[!%$bang]? $cfg:optConfig $[only%$o]? $[[$args,*]]? $(loc)?) => let simpStx ← if bang.isSome then `(tactic| dsimp!%$tk $cfg:optConfig $[only%$o]? $[[$args,*]]? $[$loc]?) else `(tactic| dsimp%$tk $cfg:optConfig $[only%$o]? $[[$args,*]]? $[$loc]?) let { ctx, simprocs, .. } ← withMainContext <| mkSimpContext simpStx.raw (eraseLocal := false) (kind := .dsimp) let stats ← dsimpLocation' ctx simprocs (expandOptLocation simpStx.raw[5]) pure (stats, simpStx.raw) | _ => Elab.throwUnsupportedSyntax | _ => Elab.throwUnsupportedSyntax let a := a.getId; let x := x.getId squeezeScopes.modify fun map => Id.run do let some map1 := map.find? a | return map let newSimps := match map1.find? x with | some (stx, oldSimps) => (stx, stats.usedTheorems :: oldSimps) | none => (stxToStore, [stats.usedTheorems]) map.insert a (map1.insert x newSimps) ================================================ FILE: Batteries/Tactic/Trans.lean ================================================ /- Copyright (c) 2022 Siddhartha Gadgil. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Siddhartha Gadgil, Mario Carneiro -/ module public meta import Lean.Elab.Tactic.ElabTerm public meta section /-! # `trans` tactic This implements the `trans` tactic, which can apply transitivity theorems with an optional middle variable argument. -/ /-- Compose using transitivity, homogeneous case. -/ @[expose] def Trans.simple {r : α → α → Sort _} [Trans r r r] : r a b → r b c → r a c := trans namespace Batteries.Tactic open Lean Meta Elab initialize registerTraceClass `Tactic.trans /-- Environment extension storing transitivity lemmas -/ initialize transExt : SimpleScopedEnvExtension (Name × Array DiscrTree.Key) (DiscrTree Name) ← registerSimpleScopedEnvExtension { addEntry := fun dt (n, ks) => dt.insertKeyValue ks n initial := {} } initialize registerBuiltinAttribute { name := `trans descr := "transitive relation" add := fun decl _ kind => MetaM.run' do let declTy := (← getConstInfo decl).type let (xs, _, targetTy) ← withReducible <| forallMetaTelescopeReducing declTy let fail := throwError "@[trans] attribute only applies to lemmas proving x ∼ y → y ∼ z → x ∼ z, got {indentExpr declTy} with target {indentExpr targetTy}" let .app (.app rel _) _ := targetTy | fail let some yzHyp := xs.back? | fail let some xyHyp := xs.pop.back? | fail let .app (.app _ _) _ ← inferType yzHyp | fail let .app (.app _ _) _ ← inferType xyHyp | fail let key ← withReducible <| DiscrTree.mkPath rel transExt.add (decl, key) kind } open Lean.Elab.Tactic /-- solving `e ← mkAppM' f #[x]` -/ def getExplicitFuncArg? (e : Expr) : MetaM (Option <| Expr × Expr) := do match e with | Expr.app f a => do if ← isDefEq (← mkAppM' f #[a]) e then return some (f, a) else getExplicitFuncArg? f | _ => return none /-- solving `tgt ← mkAppM' rel #[x, z]` given `tgt = f z` -/ def getExplicitRelArg? (tgt f z : Expr) : MetaM (Option <| Expr × Expr) := do match f with | Expr.app rel x => do let check: Bool ← do try let folded ← mkAppM' rel #[x, z] isDefEq folded tgt catch _ => pure false if check then return some (rel, x) else getExplicitRelArg? tgt rel z | _ => return none /-- refining `tgt ← mkAppM' rel #[x, z]` dropping more arguments if possible -/ def getExplicitRelArgCore (tgt rel x z : Expr) : MetaM (Expr × Expr) := do match rel with | Expr.app rel' _ => do let check: Bool ← do try let folded ← mkAppM' rel' #[x, z] isDefEq folded tgt catch _ => pure false if !check then return (rel, x) else getExplicitRelArgCore tgt rel' x z | _ => return (rel ,x) /-- Internal definition for `trans` tactic. Either a binary relation or a non-dependent arrow. -/ inductive TransRelation /-- Expression for transitive relation. -/ | app (rel : Expr) /-- Constant name for transitive relation. -/ | implies (name : Name) (bi : BinderInfo) /-- Finds an explicit binary relation in the argument, if possible. -/ def getRel (tgt : Expr) : MetaM (Option (TransRelation × Expr × Expr)) := do match tgt with | .forallE name binderType body info => return .some (.implies name info, binderType, body) | .app f z => match (← getExplicitRelArg? tgt f z) with | some (rel, x) => let (rel, x) ← getExplicitRelArgCore tgt rel x z return some (.app rel, x, z) | none => return none | _ => return none /-- `trans` applies to a goal whose target has the form `t ~ u` where `~` is a transitive relation, that is, a relation which has a transitivity lemma tagged with the attribute [trans]. * `trans s` replaces the goal with the two subgoals `t ~ s` and `s ~ u`. * If `s` is omitted, then a metavariable is used instead. Additionally, `trans` also applies to a goal whose target has the form `t → u`, in which case it replaces the goal with `t → s` and `s → u`. -/ elab "trans" t?:(ppSpace colGt term)? : tactic => withMainContext do let tgt := (← instantiateMVars (← (← getMainGoal).getType)).cleanupAnnotations let .some (rel, x, z) ← getRel tgt | throwError (m!"transitivity lemmas only apply to binary relations and " ++ m!"non-dependent arrows, not {indentExpr tgt}") match rel with | .implies name info => -- only consider non-dependent arrows if z.hasLooseBVars then throwError "`trans` is not implemented for dependent arrows{indentExpr tgt}" -- parse the intermeditate term let middleType ← mkFreshExprMVar none let t'? ← t?.mapM (elabTermWithHoles · middleType (← getMainTag)) let middle ← (t'?.map (pure ·.1)).getD (mkFreshExprMVar middleType) liftMetaTactic fun goal => do -- create two new goals let g₁ ← mkFreshExprMVar (some <| .forallE name x middle info) .synthetic let g₂ ← mkFreshExprMVar (some <| .forallE name middle z info) .synthetic -- close the original goal with `fun x => g₂ (g₁ x)` goal.assign (.lam name x (.app g₂ (.app g₁ (.bvar 0))) .default) pure <| [g₁.mvarId!, g₂.mvarId!] ++ if let some (_, gs') := t'? then gs' else [middle.mvarId!] return | .app rel => trace[Tactic.trans]"goal decomposed" trace[Tactic.trans]"rel: {indentExpr rel}" trace[Tactic.trans]"x: {indentExpr x}" trace[Tactic.trans]"z: {indentExpr z}" -- first trying the homogeneous case try let ty ← inferType x let t'? ← t?.mapM (elabTermWithHoles · ty (← getMainTag)) let s ← saveState trace[Tactic.trans]"trying homogeneous case" let lemmas := (← (transExt.getState (← getEnv)).getUnify rel).push ``Trans.simple for lem in lemmas do trace[Tactic.trans]"trying lemma {lem}" try liftMetaTactic fun g => do let lemTy ← inferType (← mkConstWithLevelParams lem) let arity ← withReducible <| forallTelescopeReducing lemTy fun es _ => pure es.size let y ← (t'?.map (pure ·.1)).getD (mkFreshExprMVar ty) let g₁ ← mkFreshExprMVar (some <| ← mkAppM' rel #[x, y]) .synthetic let g₂ ← mkFreshExprMVar (some <| ← mkAppM' rel #[y, z]) .synthetic g.assign (← mkAppOptM lem (.replicate (arity - 2) none ++ #[some g₁, some g₂])) pure <| [g₁.mvarId!, g₂.mvarId!] ++ if let some (_, gs') := t'? then gs' else [y.mvarId!] return catch _ => s.restore pure () catch _ => trace[Tactic.trans]"trying heterogeneous case" let t'? ← t?.mapM (elabTermWithHoles · none (← getMainTag)) let s ← saveState for lem in (← (transExt.getState (← getEnv)).getUnify rel).push ``HEq.trans |>.push ``Trans.trans do try liftMetaTactic fun g => do trace[Tactic.trans]"trying lemma {lem}" let lemTy ← inferType (← mkConstWithLevelParams lem) let arity ← withReducible <| forallTelescopeReducing lemTy fun es _ => pure es.size trace[Tactic.trans]"arity: {arity}" trace[Tactic.trans]"lemma-type: {lemTy}" let y ← (t'?.map (pure ·.1)).getD (mkFreshExprMVar none) trace[Tactic.trans]"obtained y: {y}" trace[Tactic.trans]"rel: {indentExpr rel}" trace[Tactic.trans]"x:{indentExpr x}" trace[Tactic.trans]"z: {indentExpr z}" let g₂ ← mkFreshExprMVar (some <| ← mkAppM' rel #[y, z]) .synthetic trace[Tactic.trans]"obtained g₂: {g₂}" let g₁ ← mkFreshExprMVar (some <| ← mkAppM' rel #[x, y]) .synthetic trace[Tactic.trans]"obtained g₁: {g₁}" g.assign (← mkAppOptM lem (.replicate (arity - 2) none ++ #[some g₁, some g₂])) pure <| [g₁.mvarId!, g₂.mvarId!] ++ if let some (_, gs') := t'? then gs' else [y.mvarId!] return catch e => trace[Tactic.trans]"failed: {e.toMessageData}" s.restore throwError m!"no applicable transitivity lemma found for {indentExpr tgt}" /-- Synonym for `trans` tactic. -/ syntax "transitivity" (ppSpace colGt term)? : tactic set_option hygiene false in macro_rules | `(tactic| transitivity) => `(tactic| trans) | `(tactic| transitivity $e) => `(tactic| trans $e) end Batteries.Tactic ================================================ FILE: Batteries/Tactic/Unreachable.lean ================================================ /- Copyright (c) 2021 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public meta import Lean.Elab.Tactic.Basic public meta section namespace Batteries.Tactic /-- This tactic causes a panic when run (at compile time). (This is distinct from `exact unreachable!`, which inserts code which will panic at run time.) It is intended for tests to assert that a tactic will never be executed, which is otherwise an unusual thing to do (and the `unreachableTactic` linter will give a warning if you do). The `unreachableTactic` linter has a special exception for uses of `unreachable!`. ``` example : True := by trivial <;> unreachable! ``` -/ elab (name := unreachable) "unreachable!" : tactic => do panic! "unreachable tactic has been reached" -- Note that `panic!` does not actually halt execution or early exit, -- so we still have to throw an error after panicking. throwError "unreachable tactic has been reached" @[inherit_doc unreachable] macro (name := unreachableConv) "unreachable!" : conv => `(conv| tactic' => unreachable!) ================================================ FILE: Batteries/Util/Cache.lean ================================================ /- Copyright (c) 2021 Gabriel Ebner. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public import Lean.Meta.DiscrTree @[expose] public section /-! # Once-per-file cache for tactics This file defines cache data structures for tactics that are initialized the first time they are accessed. Since Lean 4 starts one process per file, these caches are once-per-file and can for example be used to cache information about the imported modules. The `Cache α` data structure is the most generic version we define. It is created using `Cache.mk f` where `f : MetaM α` performs the initialization of the cache: ``` initialize numberOfImports : Cache Nat ← Cache.mk do (← getEnv).imports.size -- (does not work in the same module where the cache is defined) #eval show MetaM Nat from numberOfImports.get ``` The `DeclCache α` data structure computes a fold over the environment's constants: `DeclCache.mk empty f` constructs such a cache where `empty : α` and `f : Name → ConstantInfo → α → MetaM α`. The result of the constants in the imports is cached between tactic invocations, while for constants defined in the same file `f` is evaluated again every time. This kind of cache can be used e.g. to populate discrimination trees. -/ open Lean Meta namespace Batteries.Tactic /-- Once-per-file cache. -/ def Cache (α : Type) := IO.Ref <| MetaM α ⊕ Task (Except Exception α) -- This instance is required as we use `Cache` with `initialize`. -- One might expect an `Inhabited` instance here, -- but there is no way to construct such without using choice anyway. instance : Nonempty (Cache α) := inferInstanceAs <| Nonempty (IO.Ref _) /-- Creates a cache with an initialization function. -/ def Cache.mk (init : MetaM α) : IO (Cache α) := IO.mkRef <| Sum.inl init @[inherit_doc Core.wrapAsync] def _root_.Lean.Meta.wrapAsync {α : Type} (act : α → MetaM β) (cancelTk? : Option IO.CancelToken) : MetaM (α → EIO Exception β) := do let metaCtx ← readThe Meta.Context let metaSt ← getThe Meta.State Core.wrapAsync (fun a => act a |>.run' metaCtx metaSt) cancelTk? /-- Access the cache. Calling this function for the first time will initialize the cache with the function provided in the constructor. -/ def Cache.get (cache : Cache α) : MetaM α := do let t ← match ← ST.Ref.get (m := BaseIO) cache with | .inr t => pure t | .inl init => let res ← EIO.asTask <| (← Meta.wrapAsync (fun _ => init) (cancelTk? := none)) () cache.set (m := BaseIO) (.inr res) pure res match t.get with | Except.ok res => pure res | Except.error err => throw err /-- Cached fold over the environment's declarations, where a given function is applied to `α` for every constant. -/ structure DeclCache (α : Type) where mk' :: /-- The cached data. -/ cache : Cache α /-- Function for adding a declaration from the current file to the cache. -/ addDecl : Name → ConstantInfo → α → MetaM α /-- Function for adding a declaration from the library to the cache. Defaults to the same behaviour as adding a declaration from the current file. -/ addLibraryDecl : Name → ConstantInfo → α → MetaM α := addDecl deriving Nonempty /-- Creates a `DeclCache`. First, if `pre` is nonempty, run that for a value, and if successful populate the cache with that value. If `pre` is empty, or it fails, the cached structure `α` is initialized with `empty`, and then `addLibraryDecl` is called for every imported constant. After all imported constants have been added, we run `post`. Finally, the result is cached. When `get` is called, `addDecl` is also called for every constant in the current file. -/ def DeclCache.mk (profilingName : String) (pre : MetaM α := failure) (empty : α) (addDecl : Name → ConstantInfo → α → MetaM α) (addLibraryDecl : Name → ConstantInfo → α → MetaM α := addDecl) (post : α → MetaM α := fun a => pure a) : IO (DeclCache α) := do let cache ← Cache.mk do try -- We allow arbitrary failures in the `pre` tactic, -- and fall back on folding over the entire environment. -- In practice the `pre` tactic may be unpickling an `.olean`, -- and may fail after leanprover/lean4#2766 because the embedded hash is incorrect. pre catch _ => profileitM Exception profilingName (← getOptions) do post <|← (← getEnv).constants.map₁.foldM (init := empty) fun a n c => addLibraryDecl n c a pure { cache, addDecl } /-- Access the cache. Calling this function for the first time will initialize the cache with the function provided in the constructor. -/ def DeclCache.get (cache : DeclCache α) : MetaM α := do (← getEnv).constants.map₂.foldlM (init := ← cache.cache.get) fun a n c => cache.addDecl n c a /-- A type synonym for a `DeclCache` containing a pair of discrimination trees. The first will store declarations in the current file, the second will store declarations from imports (and will hopefully be "read-only" after creation). -/ @[reducible] def DiscrTreeCache (α : Type) : Type := DeclCache (DiscrTree α × DiscrTree α) /-- Build a `DiscrTreeCache`, from a function that returns a collection of keys and values for each declaration. -/ def DiscrTreeCache.mk [BEq α] (profilingName : String) (processDecl : Name → ConstantInfo → MetaM (Array (Array DiscrTree.Key × α))) (post? : Option (Array α → Array α) := none) (init : MetaM (DiscrTree α) := failure) : IO (DiscrTreeCache α) := let updateTree := fun name constInfo tree => do return (← processDecl name constInfo).foldl (init := tree) fun t (k, v) => t.insertKeyValue k v let addDecl := fun name constInfo (tree₁, tree₂) => return (← updateTree name constInfo tree₁, tree₂) let addLibraryDecl := fun name constInfo (tree₁, tree₂) => return (tree₁, ← updateTree name constInfo tree₂) let post := match post? with | some f => fun (T₁, T₂) => return (T₁, T₂.mapArrays f) | none => fun T => pure T let init' := return ({}, ← init) DeclCache.mk profilingName init' ({}, {}) addDecl addLibraryDecl (post := post) /-- Get matches from both the discrimination tree for declarations in the current file, and for the imports. Note that if you are calling this multiple times with the same environment, it will rebuild the discrimination tree for the current file multiple times, and it would be more efficient to call `c.get` once, and then call `DiscrTree.getMatch` multiple times. -/ def DiscrTreeCache.getMatch (c : DiscrTreeCache α) (e : Expr) : MetaM (Array α) := do let (locals, imports) ← c.get -- `DiscrTree.getMatch` returns results in batches, with more specific lemmas coming later. -- Hence we reverse this list, so we try out more specific lemmas earlier. return (← locals.getMatch e).reverse ++ (← imports.getMatch e).reverse ================================================ FILE: Batteries/Util/ExtendedBinder.lean ================================================ /- Copyright (c) 2021 Microsoft Corporation. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module @[expose] public section /-! Defines an extended binder syntax supporting `∀ ε > 0, ...` etc. -/ namespace Batteries.ExtendedBinder open Lean -- We also provide special versions of ∀/∃ that take a list of extended binders. -- The built-in binders are not reused because that results in overloaded syntax. /-- An extended binder has the form `x`, `x : ty`, or `x pred` where `pred` is a `binderPred` like `< 2`. -/ syntax extBinder := binderIdent ((" : " term) <|> binderPred)? /-- A extended binder in parentheses -/ syntax extBinderParenthesized := " (" extBinder ")" -- TODO: inlining this definition breaks /-- A list of parenthesized binders -/ syntax extBinderCollection := extBinderParenthesized* /-- A single (unparenthesized) binder, or a list of parenthesized binders -/ syntax extBinders := (ppSpace extBinder) <|> extBinderCollection /-- The syntax `∃ᵉ (x < 2) (y < 3), p x y` is shorthand for `∃ x < 2, ∃ y < 3, p x y`. -/ syntax "∃ᵉ" extBinders ", " term : term macro_rules | `(∃ᵉ, $b) => pure b | `(∃ᵉ ($p:extBinder) $[($ps:extBinder)]*, $b) => `(∃ᵉ $p:extBinder, ∃ᵉ $[($ps:extBinder)]*, $b) macro_rules -- TODO: merging the two macro_rules breaks expansion | `(∃ᵉ $x:binderIdent, $b) => `(∃ $x:binderIdent, $b) | `(∃ᵉ $x:binderIdent : $ty:term, $b) => `(∃ $x:binderIdent : $ty:term, $b) | `(∃ᵉ $x:binderIdent $p:binderPred, $b) => `(∃ $x:binderIdent $p:binderPred, $b) /-- The syntax `∀ᵉ (x < 2) (y < 3), p x y` is shorthand for `∀ x < 2, ∀ y < 3, p x y`. -/ syntax "∀ᵉ" extBinders ", " term : term macro_rules | `(∀ᵉ, $b) => pure b | `(∀ᵉ ($p:extBinder) $[($ps:extBinder)]*, $b) => `(∀ᵉ $p:extBinder, ∀ᵉ $[($ps:extBinder)]*, $b) macro_rules -- TODO: merging the two macro_rules breaks expansion | `(∀ᵉ _, $b) => `(∀ _, $b) | `(∀ᵉ $x:ident, $b) => `(∀ $x:ident, $b) | `(∀ᵉ _ : $ty:term, $b) => `(∀ _ : $ty:term, $b) | `(∀ᵉ $x:ident : $ty:term, $b) => `(∀ $x:ident : $ty:term, $b) | `(∀ᵉ $x:binderIdent $p:binderPred, $b) => `(∀ $x:binderIdent $p:binderPred, $b) ================================================ FILE: Batteries/Util/LibraryNote.lean ================================================ /- Copyright (c) 2022 Gabriel Ebner. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Gabriel Ebner -/ module public meta import Lean.Elab.Command public meta section /-! # Define the `library_note` command. -/ namespace Batteries.Util open Lean /-- A library note is identified by the name of its declaration, and its content should be contained in its doc-string. -/ @[expose] def LibraryNote := Unit deriving Inhabited namespace LibraryNote /-- Entry for library notes in the environment extension. We only store the name, and look up the constant's docstring to find its contents. -/ @[expose] def LibraryNoteEntry := Name deriving Inhabited /-- Encode a name to be safe for the Lean export format. The current export format (used by `lean4export` and consumed by external type checkers like `nanoda_lib`) does not support whitespace in declaration names. Library notes often have human-readable names with spaces like `«my library note»`, which would produce declarations like `LibraryNote.«my library note»` that cannot be exported. This function replaces spaces with underscores to produce export-safe names like `LibraryNote.my_library_note`. -/ def encodeNameForExport (n : Name) : Name := n.componentsRev.foldl (init := .anonymous) fun acc c => match c with | .str _ s => .str acc (s.replace " " "_") | .num _ k => .num acc k | .anonymous => acc /-- Environment extension supporting `library_note`. -/ initialize libraryNoteExt : SimplePersistentEnvExtension LibraryNoteEntry (Array LibraryNoteEntry) ← registerSimplePersistentEnvExtension { addEntryFn := Array.push addImportedFn := Array.flatMap id } open Elab Command in /-- `library_note «my note» /-- documentation -/` creates a library note named `my note` in the `LibraryNote` namespace, whose content is `/-- documentation -/`. This can then be cross-referenced using ``` -- See note [some tag] ``` in doc-comments. You can access the contents using, for example, `#print LibraryNote.my_note`. (Note: spaces in the name are converted to underscores in the declaration name for compatibility with the Lean export format.) Use `#help note "some tag"` to display all notes with the tag `"some tag"` in the infoview. This command can be imported from Batteries.Tactic.HelpCmd . -/ elab "library_note " name:ident ppSpace dc:docComment : command => do let origName := name.getId -- Store original name (with spaces) for lookup via `#help note` modifyEnv (libraryNoteExt.addEntry · origName) -- Use encoded name (spaces → underscores) for declaration, for export format compatibility let safeName := encodeNameForExport origName let stx ← `( $dc:docComment meta def $(mkIdent (`_root_.LibraryNote ++ safeName)) : LibraryNote := default) elabCommandTopLevel stx open Elab Command in /-- Support the old `library_note "foo"` syntax, with a deprecation warning. -/ elab "library_note " name:str ppSpace dc:docComment : command => do let name' := Name.mkSimple name.getString let stx ← `(library_note $(mkIdent name'):ident $dc:docComment) elabCommandTopLevel stx logWarningAt name <| "deprecation warning: library_note now takes an identifier instead of a string.\n" ++ "Hint: replace the double quotes with «french quotes»." open Elab Command in /-- Support the old `library_note2 «foo»` syntax, with a deprecation warning. -/ elab "library_note2 " name:ident ppSpace dc:docComment : command => do let stx ← `(library_note $name:ident $dc:docComment) elabCommandTopLevel stx logWarningAt name <| "deprecation warning: library_note2 has been replaced with library_note." open Elab Command in /-- Support the old `library_note2 "foo"` syntax, with a deprecation warning. -/ elab "library_note2 " name:str ppSpace dc:docComment : command => do let stx ← `(library_note name $dc:docComment) elabCommandTopLevel stx logWarningAt name <| "deprecation warning: library_note2 has been replaced with library_note." ================================================ FILE: Batteries/Util/Panic.lean ================================================ /- Copyright (c) 2024 François G. Dorais. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: François G. Dorais -/ module @[expose] public section namespace Batteries /-- Panic with a specific default value `v`. -/ def panicWith (v : α) (msg : String) : α := @panic α ⟨v⟩ msg @[simp] theorem panicWith_eq (v : α) (msg) : panicWith v msg = v := rfl ================================================ FILE: Batteries/Util/Pickle.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ module public import Lean.Environment @[expose] public section /-! # Pickling and unpickling objects By abusing `saveModuleData` and `readModuleData` we can pickle and unpickle objects to disk. -/ open Lean System /-- Save an object to disk. If you need to write multiple objects from within a single declaration, you will need to provide a unique `key` for each. -/ def pickle {α : Type} (path : FilePath) (x : α) (key : Name := by exact decl_name%) : IO Unit := saveModuleData path key (unsafe unsafeCast x) /-- Load an object from disk. Note: The returned `CompactedRegion` can be used to free the memory behind the value of type `α`, using `CompactedRegion.free` (which is only safe once all references to the `α` are released). Ignoring the `CompactedRegion` results in the data being leaked. Use `withUnpickle` to call `CompactedRegion.free` automatically. This function is unsafe because the data being loaded may not actually have type `α`, and this may cause crashes or other bad behavior. -/ unsafe def unpickle (α : Type) (path : FilePath) : IO (α × CompactedRegion) := do let (x, region) ← readModuleData path pure (unsafeCast x, region) /-- Load an object from disk and run some continuation on it, freeing memory afterwards. -/ unsafe def withUnpickle [Monad m] [MonadLiftT IO m] {α β : Type} (path : FilePath) (f : α → m β) : m β := do let (x, region) ← unpickle α path let r ← f x region.free pure r ================================================ FILE: Batteries/Util/ProofWanted.lean ================================================ /- Copyright (c) 2023 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: David Thrane Christiansen -/ module public meta import Lean.Elab.Exception public meta import Lean.Elab.Command public meta section open Lean Parser Elab Command /-- This proof would be a welcome contribution to the library! The syntax of `proof_wanted` declarations is just like that of `theorem`, but without `:=` or the proof. Lean checks that `proof_wanted` declarations are well-formed (e.g. it ensures that all the mentioned names are in scope, and that the theorem statement is a valid proposition), but they are discarded afterwards. This means that they cannot be used as axioms. Typical usage: ``` @[simp] proof_wanted empty_find? [BEq α] [Hashable α] {a : α} : (∅ : HashMap α β).find? a = none ``` -/ @[command_parser] def «proof_wanted» := leading_parser declModifiers false >> "proof_wanted" >> declId >> ppIndent declSig /-- Elaborate a `proof_wanted` declaration. The declaration is translated to an axiom during elaboration, but it's then removed from the environment. -/ @[command_elab «proof_wanted»] def elabProofWanted : CommandElab | `($mods:declModifiers proof_wanted $name $args* : $res) => withoutModifyingEnv do -- The helper axiom is used instead of `sorry` to avoid spurious warnings elabCommand <| ← `( section set_option linter.unusedVariables false axiom helper {α : Sort _} : α $mods:declModifiers theorem $name $args* : $res := helper end) | _ => throwUnsupportedSyntax ================================================ FILE: Batteries.lean ================================================ module public import Batteries.Classes.Cast public import Batteries.Classes.Deprecated public import Batteries.Classes.Order public import Batteries.Classes.RatCast public import Batteries.Classes.SatisfiesM public import Batteries.CodeAction public import Batteries.CodeAction.Attr public import Batteries.CodeAction.Basic public import Batteries.CodeAction.Deprecated public import Batteries.CodeAction.Match public import Batteries.CodeAction.Misc public import Batteries.Control.AlternativeMonad public import Batteries.Control.ForInStep public import Batteries.Control.ForInStep.Basic public import Batteries.Control.ForInStep.Lemmas public import Batteries.Control.LawfulMonadState public import Batteries.Control.Lemmas public import Batteries.Control.Monad public import Batteries.Control.Nondet.Basic public import Batteries.Control.OptionT public import Batteries.Data.Array public import Batteries.Data.AssocList public import Batteries.Data.Bool public import Batteries.Data.BinaryHeap public import Batteries.Data.BinomialHeap public import Batteries.Data.BitVec public import Batteries.Data.ByteArray public import Batteries.Data.ByteSlice public import Batteries.Data.Char public import Batteries.Data.DList public import Batteries.Data.Fin public import Batteries.Data.FloatArray public import Batteries.Data.HashMap public import Batteries.Data.Int public import Batteries.Data.List public import Batteries.Data.MLList public import Batteries.Data.NameSet public import Batteries.Data.Nat public import Batteries.Data.PairingHeap public import Batteries.Data.RBMap public import Batteries.Data.Random public import Batteries.Data.Range public import Batteries.Data.Rat public import Batteries.Data.RunningStats public import Batteries.Data.Stream public import Batteries.Data.String public import Batteries.Data.UInt public import Batteries.Data.UnionFind public import Batteries.Data.Vector public import Batteries.Lean.AttributeExtra public import Batteries.Lean.EStateM public import Batteries.Lean.Except public import Batteries.Lean.Expr public import Batteries.Lean.Float public import Batteries.Lean.HashMap public import Batteries.Lean.HashSet public import Batteries.Lean.IO.Process public import Batteries.Lean.Json public import Batteries.Lean.LawfulMonad public import Batteries.Lean.LawfulMonadLift public import Batteries.Lean.Meta.Basic public import Batteries.Lean.Meta.DiscrTree public import Batteries.Lean.Meta.Expr public import Batteries.Lean.Meta.Inaccessible public import Batteries.Lean.Meta.InstantiateMVars public import Batteries.Lean.Meta.SavedState public import Batteries.Lean.Meta.Simp public import Batteries.Lean.Meta.UnusedNames public import Batteries.Lean.MonadBacktrack public import Batteries.Lean.NameMapAttribute public import Batteries.Lean.PersistentHashMap public import Batteries.Lean.PersistentHashSet public import Batteries.Lean.Position public import Batteries.Lean.SatisfiesM public import Batteries.Lean.Syntax public import Batteries.Lean.System.IO public import Batteries.Lean.TagAttribute public import Batteries.Lean.Util.EnvSearch public import Batteries.Linter public import Batteries.Linter.UnnecessarySeqFocus public import Batteries.Linter.UnreachableTactic public import Batteries.Logic public import Batteries.Tactic.Alias public import Batteries.Tactic.Basic public import Batteries.Tactic.Case public import Batteries.Tactic.Congr public import Batteries.Tactic.Exact public import Batteries.Tactic.GeneralizeProofs public import Batteries.Tactic.HelpCmd public import Batteries.Tactic.Init public import Batteries.Tactic.Instances public import Batteries.Tactic.Lemma public import Batteries.Tactic.Lint public import Batteries.Tactic.Lint.Basic public import Batteries.Tactic.Lint.Frontend public import Batteries.Tactic.Lint.Misc public import Batteries.Tactic.Lint.Simp public import Batteries.Tactic.Lint.TypeClass public import Batteries.Tactic.NoMatch public import Batteries.Tactic.OpenPrivate public import Batteries.Tactic.PermuteGoals public import Batteries.Tactic.PrintDependents public import Batteries.Tactic.PrintOpaques public import Batteries.Tactic.PrintPrefix public import Batteries.Tactic.SeqFocus public import Batteries.Tactic.ShowUnused public import Batteries.Tactic.SqueezeScope public import Batteries.Tactic.Trans public import Batteries.Tactic.Unreachable public import Batteries.Util.Cache public import Batteries.Util.ExtendedBinder public import Batteries.Util.LibraryNote public import Batteries.Util.Panic public import Batteries.Util.Pickle public import Batteries.Util.ProofWanted ================================================ FILE: BatteriesTest/ArrayMap.lean ================================================ import Batteries.Data.List.ArrayMap open List /-- info: #[3, 4, 5, 6] -/ #guard_msgs in #eval List.toArrayMap [0, 1, 2, 3] (fun n => n + 3) /-- info: #[7, 9, 15, 25] -/ #guard_msgs in #eval toArrayMap [0, 1, 2, 3] (fun n => 2 * n ^ 2 + 7) ================================================ FILE: BatteriesTest/Char.lean ================================================ import Batteries.Data.Char /- Failing on nightly-2025-12-18 #guard Char.caseFoldAsciiOnly 'A' == 'a' #guard Char.caseFoldAsciiOnly 'a' == 'a' #guard Char.caseFoldAsciiOnly 'À' == 'À' #guard Char.caseFoldAsciiOnly 'à' == 'à' #guard Char.caseFoldAsciiOnly '$' == '$' #guard Char.beqCaseInsensitiveAsciiOnly 'a' 'A' == true #guard Char.beqCaseInsensitiveAsciiOnly 'a' 'a' == true #guard Char.beqCaseInsensitiveAsciiOnly '$' '$' == true #guard Char.beqCaseInsensitiveAsciiOnly 'a' 'b' == false #guard Char.beqCaseInsensitiveAsciiOnly 'γ' 'Γ' == false #guard Char.beqCaseInsensitiveAsciiOnly 'ä' 'Ä' == false #guard Char.cmpCaseInsensitiveAsciiOnly 'a' 'A' == .eq #guard Char.cmpCaseInsensitiveAsciiOnly 'a' 'a' == .eq #guard Char.cmpCaseInsensitiveAsciiOnly '$' '$' == .eq #guard Char.cmpCaseInsensitiveAsciiOnly 'a' 'b' == .lt #guard Char.cmpCaseInsensitiveAsciiOnly 'γ' 'Γ' == .gt #guard Char.cmpCaseInsensitiveAsciiOnly 'ä' 'Ä' == .gt -/ ================================================ FILE: BatteriesTest/GeneralizeProofs.lean ================================================ import Batteries.Tactic.GeneralizeProofs private axiom test_sorry : ∀ {α}, α set_option autoImplicit true noncomputable def List.nthLe (l : List α) (n) (_h : n < l.length) : α := test_sorry -- For debugging `generalize_proofs` -- set_option trace.Tactic.generalize_proofs true example : List.nthLe [1, 2] 1 (by simp) = 2 := by generalize_proofs h guard_hyp h :ₛ 1 < List.length [1, 2] guard_target =ₛ [1, 2].nthLe 1 h = 2 exact test_sorry example (x : Nat) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2 := by generalize_proofs a guard_hyp a :ₛ ∃ x, x < 2 guard_target =ₛ Classical.choose a < 2 exact Classical.choose_spec a example (x : Nat) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, h⟩ : ∃ x, x < 2) := by generalize_proofs a guard_hyp a :ₛ ∃ x, x < 2 guard_target =ₛ Classical.choose a = Classical.choose a rfl example (x : Nat) (h : x < 2) (h' : x < 1) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, (by clear h; omega)⟩ : ∃ x, x < 2) := by generalize_proofs a guard_hyp a :ₛ ∃ x, x < 2 guard_target =ₛ Classical.choose a = Classical.choose a rfl example (x : Nat) (h h' : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, h'⟩ : ∃ x, x < 2) := by change _ at h' fail_if_success guard_target =ₛ Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, h⟩ : ∃ x, x < 2) generalize_proofs at h' fail_if_success change _ at h' guard_target =ₛ Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, h⟩ : ∃ x, x < 2) generalize_proofs a guard_target =ₛ Classical.choose a = Classical.choose a rfl example (x : Nat) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) := by generalize_proofs a a' guard_hyp a :ₛ ∃ x, x < 2 guard_hyp a' :ₛ ∃ x, x < 3 guard_target =ₛ Classical.choose a = Classical.choose a' exact test_sorry example (x : Nat) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) := by generalize_proofs guard_target = Classical.choose _ = Classical.choose _ exact test_sorry example (x : Nat) (h : x < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) = Classical.choose (⟨x, Nat.lt_succ_of_lt h⟩ : ∃ x, x < 3) := by generalize_proofs _ a guard_hyp a : ∃ x, x < 3 guard_target = Classical.choose _ = Classical.choose a exact test_sorry example (a : ∃ x, x < 2) : Classical.choose a < 2 := by generalize_proofs guard_target =ₛ Classical.choose a < 2 exact Classical.choose_spec a example (a : ∃ x, x < 2) : Classical.choose a < 2 := by generalize_proofs t guard_target =ₛ Classical.choose a < 2 exact Classical.choose_spec a example (x : Nat) (h : x < 2) (H : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2) : Classical.choose (⟨x, h⟩ : ∃ x, x < 2) < 2 := by generalize_proofs a at H ⊢ guard_hyp a :ₛ ∃ x, x < 2 guard_hyp H :ₛ Classical.choose a < 2 guard_target =ₛ Classical.choose a < 2 exact H example (H : ∀ y, ∃ (x : Nat) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y) : ∀ y, ∃ (x : Nat) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y := by generalize_proofs -abstract guard_target =ₛ ∀ y, ∃ (x : Nat) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y generalize_proofs a at H ⊢ guard_hyp a :ₛ ∀ (y w : Nat), w < y → ∃ x, x < y guard_hyp H :ₛ ∀ (y : Nat), ∃ x h, Classical.choose (a y x h) < y guard_target =ₛ ∀ (y : Nat), ∃ x h, Classical.choose (a y x h) < y exact H example (H : ∀ y, ∃ (x : Nat) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y) : ∀ y, ∃ (x : Nat) (h : x < y), Classical.choose (⟨x, h⟩ : ∃ x, x < y) < y := by generalize_proofs a at * guard_hyp a :ₛ ∀ (y w : Nat), w < y → ∃ x, x < y guard_hyp H :ₛ ∀ (y : Nat), ∃ x h, Classical.choose (a y x h) < y guard_target =ₛ ∀ (y : Nat), ∃ x h, Classical.choose (a y x h) < y exact H namespace zulip1 /-! https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/.60generalize_proofs.60.20sometimes.20silently.20has.20no.20effect/near/407162574 -/ theorem t (x : Option Unit) : x.isSome = true := test_sorry def p : Unit → Prop := test_sorry theorem good (x : Option Unit) : p (Option.get x test_sorry) → x.isSome = true := by generalize_proofs h exact fun _ => h theorem was_bad (x : Option Unit) : p (Option.get x (t x)) → x.isSome = true := by generalize_proofs h exact fun _ => h end zulip1 section attribute [local instance] Classical.propDecidable example (H : ∀ x, x = 1) : (if h : ∃ (k : Nat), k = 1 then Classical.choose h else 0) = 1 := by rw [dif_pos ?hc] case hc => exact ⟨1, rfl⟩ generalize_proofs h guard_hyp h :ₛ ∃ x, x = 1 guard_target =ₛ Classical.choose h = 1 apply H end section -- make sure it handles `let` declarations well -- this was https://github.com/leanprover-community/mathlib4/issues/24222 example : True := by let n : Fin 1 := ⟨0, id Nat.zero_lt_one⟩ generalize_proofs h at * guard_hyp h :ₛ 0 < 1 guard_hyp n :=ₛ ⟨0, h⟩ trivial example : True := by have h := Nat.zero_lt_one let n : Fin 1 := ⟨0, id Nat.zero_lt_one⟩ generalize_proofs at * guard_hyp h :ₛ 0 < 1 guard_hyp n :=ₛ ⟨0, h⟩ trivial example : True := by let p := id Nat.zero_lt_one generalize_proofs at * guard_hyp p :ₛ 0 < 1 trivial example : True := by let p := Nat.zero_lt_one generalize_proofs at * guard_hyp p :ₛ 0 < 1 let q := id Nat.zero_lt_one generalize_proofs at * fail_if_success change _ at q guard_hyp p :ₛ 0 < 1 trivial example (P : Sort _) (p : P) : True := by let p' : P := p generalize_proofs at * guard_hyp p :ₛ P guard_hyp p' :=ₛ p trivial example (P : True → Sort _) (p : True → P (by decide)) : True := by let p' := p (by decide) generalize_proofs h at * guard_hyp h :ₛ True guard_hyp p :ₛ True → P h guard_hyp p' :=ₛ p h exact h end /-! Extracting proofs from under let bindings -/ /-- trace: pf✝ : ∀ (n : Nat), 0 < n + 1 ⊢ have n := 0; ↑⟨0, ⋯⟩ = 0 -/ #guard_msgs in example : have n := 0; (⟨0, id (by simp)⟩ : Fin (n + 1)).val = 0 := by generalize_proofs trace_state rfl /-- trace: pf✝ : ∀ (n : Nat), 0 < n + 1 ⊢ have n := 0; ↑⟨0, ⋯⟩ = 0 -/ #guard_msgs in example : have n := 0; (⟨0, id (by simp)⟩ : Fin (n + 1)).val = 0 := by generalize_proofs trace_state rfl ================================================ FILE: BatteriesTest/Internal/DummyLabelAttr.lean ================================================ /- Copyright (c) 2023 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ import Lean.LabelAttribute /-- A dummy label attribute, which can be used for testing. -/ -- This can't live in `Batteries.Tactic.LabelAttr` -- (because we can't use the extension in the same file it is initialized) -- and it can't live in `test/`, because files there can not import other files in `test/`. register_label_attr dummy_label_attr ================================================ FILE: BatteriesTest/Internal/DummyLibraryNote.lean ================================================ import Batteries.Util.LibraryNote library_note «test1» /-- 1: This is a testnote for testing the library note feature of batteries. The `#help note` command should be able to find this note when imported. -/ library_note «test2» /-- 2: This is a second testnote for testing the library note feature of batteries. -/ library_note «temporary note» /-- 1: This is a testnote whose label also starts with "te", but gets sorted before "test" -/ ================================================ FILE: BatteriesTest/Internal/DummyLibraryNote2.lean ================================================ import BatteriesTest.Internal.DummyLibraryNote library_note «test3» /-- 3: this is a note in a different file importing the above testnotes, but still imported by the actual testfile. -/ library_note «Test» /-- 1: this is a testnote with a label starting with "Te" -/ library_note «Other» /-- 1: this is a testnote with a label not starting with "te", so it shouldn't appear when looking for notes with label starting with "te". -/ ================================================ FILE: BatteriesTest/MLList.lean ================================================ import Lean.Meta.Basic import Batteries.Data.MLList.IO import Batteries.Data.List.Basic set_option linter.missingDocs false /-! ### Test fix to performance problem in `asArray`. -/ def g (n : Nat) : MLList Lean.Meta.MetaM Nat := do for _ in [:n] do if true then continue return n /-- info: #[3000] -/ -- This used to fail before add the `uncons?` field to the implementation of `MLList`. #guard_msgs in #eval MLList.asArray $ (g 3000) /-! ### Test `MLList.ofTaskList`. We generate three tasks which sleep for `100`, `50`, and `1` milliseconds respectively, and then verify that `MLList.ofTaskList` return their results in the order they complete. -/ /- This test is very flaky, so it's disabled for now. def sleep (n : UInt32) : BaseIO (Task UInt32) := IO.asTask (do IO.sleep n; return n) |>.map fun t => t.map fun | .ok n => n | .error _ => 0 def sleeps : MLList BaseIO UInt32 := .squash fun _ => do let r ← [100,50,1].map sleep |>.traverse id return .ofTaskList r /-- info: [1, 50, 100] -/ #guard_msgs in #eval sleeps.force -/ ================================================ FILE: BatteriesTest/OpenPrivateDefs.lean ================================================ /-! This file contains a private declaration. It's tested in `openPrivate.lean`. -/ private def secretNumber : Nat := 2 ================================================ FILE: BatteriesTest/String.lean ================================================ /- Failing on nightly-2025-12-18 import Batteries.Data.String.AsciiCasing #guard "ABC".caseFoldAsciiOnly == "abc" #guard "x".caseFoldAsciiOnly != "y" #guard "Àà".caseFoldAsciiOnly == "Àà" #guard "1$#!".caseFoldAsciiOnly == "1$#!" #guard "abc".beqCaseInsensitiveAsciiOnly "ABC" == true #guard "cba".beqCaseInsensitiveAsciiOnly "ABC" == false #guard "a".beqCaseInsensitiveAsciiOnly "a" == true #guard "$".beqCaseInsensitiveAsciiOnly "$" == true #guard "a".beqCaseInsensitiveAsciiOnly "b" == false #guard "γ".beqCaseInsensitiveAsciiOnly "Γ" == false #guard "ä".beqCaseInsensitiveAsciiOnly "Ä" == false #guard "abc".cmpCaseInsensitiveAsciiOnly "ABC" == .eq #guard "abc".cmpCaseInsensitiveAsciiOnly "xyz" == .lt #guard "a".cmpCaseInsensitiveAsciiOnly "a" == .eq #guard "$".cmpCaseInsensitiveAsciiOnly "$" == .eq #guard "a__".cmpCaseInsensitiveAsciiOnly "b__" == .lt #guard "γ".cmpCaseInsensitiveAsciiOnly "Γ" == .gt #guard "ä".cmpCaseInsensitiveAsciiOnly "Ä" == .gt #guard [ ("", ""), (" ", " "), ("a", "A"), ("abc", "ABC"), ("aBc", "AbC"), ("123", "123"), ("国际化与本地化", "国际化与本地化"), ("ABC😂🔰🍑xyz", "abc😂🔰🍑XYZ") ].all (fun (a, b) => a.beqCaseInsensitiveAsciiOnly b && a.cmpCaseInsensitiveAsciiOnly b = .eq) #guard [ ("国际化", "国际化与本地化"), ("", " "), ("a", "b"), ("ab", "ba"), ("123", "124"), ("😂", "🍑"), ("🔰🍑", "😂🔰🍑aaa") ] |>.all fun (a, b) => a ≠ b && !(a.beqCaseInsensitiveAsciiOnly b) && a.cmpCaseInsensitiveAsciiOnly b != .eq -/ ================================================ FILE: BatteriesTest/absurd.lean ================================================ import Batteries.Tactic.Basic /-! Tests for `absurd` tactic -/ -- Basic example /-- error: unsolved goals p : Prop h : p ⊢ ¬p -/ #guard_msgs in example {p : Prop} (h : p) : 0 = 0 := by absurd h -- Negative example /-- error: unsolved goals p : Prop h : ¬p ⊢ p -/ #guard_msgs in example {p : Prop} (h : ¬p) : 0 = 1 := by absurd h -- Inequality example /-- error: unsolved goals n : Nat h : n ≠ 0 ⊢ n = 0 -/ #guard_msgs in example (h : n ≠ 0) : 0 = 2 := by absurd h -- Example with implies false /-- error: unsolved goals p : Prop h : p → False ⊢ p -/ #guard_msgs in example {p : Prop} (h : p → False) : 0 = 3 := by absurd h /-- error: unsolved goals p : Prop h : p ⊢ ¬p -/ #guard_msgs in example {p : Prop} {h : p} : ∀ {x : True}, 0 = 0 := by absurd h -- `·` should not be legal /-- error: invalid occurrence of `·` notation, it must be surrounded by parentheses (e.g. `(· + 1)`) --- error: unsolved goals p : Prop h : p ⊢ ∀ {x : True}, 0 = 0 -/ #guard_msgs in example {p : Prop} {h : p} : ∀ {_ : True}, 0 = 0 := by absurd · ================================================ FILE: BatteriesTest/alias.lean ================================================ import Batteries.Tactic.Alias set_option linter.unusedVariables false set_option linter.missingDocs false open Lean Meta namespace A /-- doc string for foo -/ theorem foo : 1 + 1 = 2 := rfl /-- doc string for `alias foo` -/ alias foo1 := foo @[deprecated (since := "2038-01-20")] alias foo2 := foo @[deprecated foo2 (since := "2038-01-20")] alias _root_.B.foo3 := foo @[deprecated foo2 "it was never a good idea anyway" (since := "last thursday")] alias foo4 := foo example : 1 + 1 = 2 := foo1 /-- warning: `A.foo2` has been deprecated: Use `A.foo` instead -/ #guard_msgs in example : 1 + 1 = 2 := foo2 /-- warning: `B.foo3` has been deprecated: Use `A.foo2` instead Note: The updated constant is in a different namespace. Dot notation may need to be changed (e.g., from `x.foo3` to `foo2 x`). -/ #guard_msgs in example : 1 + 1 = 2 := B.foo3 /-- warning: `A.foo4` has been deprecated: it was never a good idea anyway -/ #guard_msgs in example : 1 + 1 = 2 := foo4 /-- doc string for bar -/ def bar : Nat := 5 alias bar1 := bar alias _root_.B.bar2 := bar example : bar1 = 5 := rfl example : B.bar2 = 5 := rfl theorem baz (x : Nat) : x = x := rfl alias baz1 := baz example : 3 = 3 := baz1 3 /-- doc string for foobar -/ def foobar : Nat → Nat := id @[inherit_doc foobar] alias foobar1 := foobar @[simp] alias foobar2 := foobar /-- doc string for foobar2 -/ def foobar3 (n : Nat) := foobar1 n /-- error: `simp` made no progress -/ #guard_msgs in example : foobar1 x = foobar x := by simp example : foobar2 x = foobar x := by simp /- Test protected -/ /-- doc string for Foo.barbaz -/ protected alias Foo.barbaz := trivial /-- error: Unknown identifier `barbaz` -/ #guard_msgs in example : True := barbaz example : True := Foo.barbaz /- Test noncomputable -/ /-- doc string for foobaz -/ noncomputable def foobaz : Nat → Nat := id alias foobaz1 := foobaz /-- error: Failed to find LCNF signature for A.foobaz1 -/ #guard_msgs in def foobaz2 (n : Nat) := foobaz1 n noncomputable alias foobaz3 := id /-- error: Failed to find LCNF signature for A.foobaz3 -/ #guard_msgs in def foobaz4 (n : Nat) := foobaz3 n /- Test unsafe -/ /-- doc string for barbaz -/ unsafe def barbaz : Nat → Nat := id alias barbaz1 := barbaz /-- error: (kernel) invalid declaration, it uses unsafe declaration 'A.barbaz1' -/ #guard_msgs in def barbaz2 (n : Nat) := barbaz1 n unsafe alias barbaz3 := id /-- error: (kernel) invalid declaration, it uses unsafe declaration 'A.barbaz3' -/ #guard_msgs in def barbaz4 (n : Nat) := barbaz3 n /- iff version -/ @[deprecated (since := "2038-01-20")] alias ⟨mpId, mprId⟩ := Iff.rfl /-- info: A.mpId {a : Prop} : a → a -/ #guard_msgs in #check mpId /-- info: A.mprId {a : Prop} : a → a -/ #guard_msgs in #check mprId /-- warning: `A.mpId` has been deprecated: Use `Iff.rfl` instead Note: The updated constant has a different type: ∀ {a : Prop}, a ↔ a instead of ∀ {a : Prop}, a → a Note: The updated constant is in a different namespace. Dot notation may need to be changed (e.g., from `x.mpId` to `Iff.rfl x`). --- warning: `A.mprId` has been deprecated: Use `Iff.rfl` instead Note: The updated constant has a different type: ∀ {a : Prop}, a ↔ a instead of ∀ {a : Prop}, a → a Note: The updated constant is in a different namespace. Dot notation may need to be changed (e.g., from `x.mprId` to `Iff.rfl x`). -/ #guard_msgs in example := And.intro @mpId @mprId /- Test environment extension -/ /-- info: **Alias** of `A.foo`. -/ #guard_msgs in #eval show MetaM _ from do match ← Batteries.Tactic.Alias.getAliasInfo `A.foo1 with | some i => IO.println i.toString | none => IO.println "alias not found" ================================================ FILE: BatteriesTest/array.lean ================================================ import Batteries.Data.Array section variable {α : Type _} variable [Inhabited α] variable (a : Array α) variable (i j : Nat) variable (v d : α) variable (g : i < (a.set! i v).size) variable (j_lt : j < (a.set! i v).size) #check_simp (a.set! i v)[i] ~> v #check_simp (a.set! i v)[i]! ~> (a.setIfInBounds i v)[i]! #check_simp (a.set! i v).getD i d ~> if i < a.size then v else d #check_simp (a.set! i v)[i] ~> v -- Checks with different index values. #check_simp (a.set! i v)[j]'j_lt ~> (a.setIfInBounds i v)[j]'_ #check_simp (a.setIfInBounds i v)[j]'j_lt !~> -- This doesn't work currently. -- It will be address in the comprehensive overhaul of array lemmas. -- #check_simp (a.set! i v)[i]? ~> .some v end ================================================ FILE: BatteriesTest/array_scan.lean ================================================ import Batteries.Data.Array.Basic open Array /- Docstring examples for `Array.scan{l,r,lM,rM}` -/ example [Monad m] (f : α → β → m α) : Array.scanlM f x₀ #[a, b, c] = (do let x₁ ← f x₀ a let x₂ ← f x₁ b let x₃ ← f x₂ c pure #[x₀, x₁, x₂, x₃]) := by simp [scanlM, scanlM.loop] example [Monad m] (f : α → β → m α) : Array.scanlM f x₀ #[a, b, c] (start := 1) (stop := 3) = (do let x₁ ← f x₀ b let x₂ ← f x₁ c pure #[x₀, x₁, x₂]) := by simp [scanlM, scanlM.loop] example [Monad m] (f : α → β → m β) : Array.scanrM f x₀ #[a, b, c] = (do let x₁ ← f c x₀ let x₂ ← f b x₁ let x₃ ← f a x₂ pure #[x₃, x₂, x₁, x₀]) := by simp [scanrM, scanrM.loop] example [Monad m] (f : α → β → m β) : Array.scanrM f x₀ #[a, b, c] (start := 3) (stop := 1) = (do let x₁ ← f c x₀ let x₂ ← f b x₁ pure #[x₂, x₁, x₀]) := by simp [scanrM, scanrM.loop] #guard scanl (· + ·) 0 #[1, 2, 3] == #[0, 1, 3, 6] #guard scanr (· + ·) 0 #[1, 2, 3] == #[6, 5, 3, 0] ================================================ FILE: BatteriesTest/by_contra.lean ================================================ import Batteries.Tactic.Basic private def nonDecid (P : Prop) (x : P) : P := by by_contra h guard_hyp h : ¬P guard_target = False exact h x private def decid (P : Prop) [Decidable P] (x : P) : P := by by_contra h guard_hyp h : ¬P guard_target = False exact h x example (P : Prop) [Decidable P] : nonDecid P = decid P := by delta nonDecid decid guard_target =ₛ (fun x : P => Classical.byContradiction fun h => h x) = (fun x : P => Decidable.byContradiction fun h => h x) rfl example (P : Prop) : P → P := by by_contra guard_hyp this : ¬(P → P) exact ‹¬(P → P)› id example (P : Prop) : {_ : P} → P := by by_contra guard_hyp this : ¬(P → P) exact ‹¬(P → P)› id /-! https://github.com/leanprover-community/batteries/issues/1196: Previously the second error had a `Decidable True` subgoal, which only appeared in the presence of the first unclosed goal. -/ /-- error: unsolved goals case left ⊢ True --- error: unsolved goals case right this : ¬True ⊢ False -/ #guard_msgs in example : True ∧ True := by constructor · skip · by_contra example (n : Nat) (h : n ≠ 0) : n ≠ 0 := by by_contra rfl simp only [Ne, not_true_eq_false] at h example (p q : Prop) (hnp : ¬ p) : ¬ (p ∧ q) := by by_contra ⟨hp, _⟩ exact hnp hp example (p q : Prop) (hnp : ¬ p) (hnq : ¬ q) : ¬ (p ∨ q) := by by_contra hp | hq · exact hnp hp · exact hnq hq /-- error: unsolved goals n : Nat this : n ≠ 0 ⊢ False -/ #guard_msgs in example (n : Nat) : n = 0 := by by_contra : n ≠ 0 /-- error: unsolved goals n : Nat h_ne : n ≠ 0 ⊢ False -/ #guard_msgs in example (n : Nat) : n = 0 := by by_contra h_ne : n ≠ 0 ================================================ FILE: BatteriesTest/case.lean ================================================ import Batteries.Tactic.Case set_option linter.missingDocs false example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor fail_if_success show z = z case _ : z = _ · exact h' exact h example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor case _ : z = _ => exact h' case left => exact h example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor case _ : z = _ | left => assumption example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor case _ : _ | _ : _ => assumption example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor case left | _ : z = _ => assumption example (h : x = y) (h' : z = w) : x = y ∧ z = w := by constructor case _ : z = _ => ?foo case foo := h' case left := h example (h : x = y) (h' : z = w) : x = y ∧ z + 0 = w := by constructor case right : z = _ => guard_target =ₛ z = w exact h' case _ : x = y := h example (h : x = y) : x = y ∧ x = y := by constructor case _ : x = y | _ : x = y => ?foo -- Closes both case foo => exact h example (h : x = y) : x = y ∧ x = y ∧ x = y := by refine ⟨?foo, ?_, ?_⟩ · exact h case _ : x = y | _ : x = y => ?foo -- This metavariable was already assigned, so no more goals. /-- error: 'case' tactic failed, value ?left depends on the main goal metavariable '?left' -/ #guard_msgs in example : False ∧ True := by constructor case _ : False => ?left /-- error: Type mismatch ?right has type True but is expected to have type False -/ #guard_msgs in example : False ∧ True := by constructor case _ : False => ?right /-- error: 'case' tactic failed, value ?right depends on the main goal metavariable '?right' -/ #guard_msgs in example : False ∧ False := by constructor case left => ?right case right => ?left example (h : x = y) (h' : z = w) : x = y ∧ z + 0 = w := by constructor case _ : z = _ => guard_target =ₛ z = w exact h' case left => exact h example (x y z : α) (h : x = y) (h' : y = z) : x = z := by apply Eq.trans case _ : id α := y -- Note: `case` inserts a `let_fun` since `id α` and `α` aren't defeq with reducible transparency · guard_target =ₛ x = show id α from y exact h · guard_target = y = z exact h' example (x y z : α) (h : x = y) (h' : y = z) : x = z := by apply Eq.trans case _ : α := y -- Note: `case` detects defeq with reducible transparency, so doesn't insert type hint · guard_target =ₛ x = y exact h · guard_target = y = z exact h' def Injective (f : α → β) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂ theorem cancel_injective (h : Injective f) : f x = f y ↔ x = y := by refine ⟨fun e => h e, ?_⟩ intro h cases h rfl example (h : Injective f) (h' : f x = f y) : x = y := by rw [cancel_injective] at h' case _ : Injective f := h exact h' example (h : Injective f) (h' : f x = f y) : x = y := by rw [cancel_injective] at h' case _ : Injective f · exact h exact h' example (hf : Injective f) (hg : Injective g) (h : g (f x) = g (f y)) : x = y := by rw [cancel_injective, cancel_injective] at h case _ : Injective f | _ : Injective g => assumption exact h example (hf : Injective f) (hg : Injective g) (h : g (f x) = g (f y)) : x = y := by rw [cancel_injective, cancel_injective] at h repeat case _ : Injective _ => assumption exact h example (hf : Injective f) (hg : Injective g) (h : g (f x) = g (f y)) : x = y := by rw [cancel_injective, cancel_injective] at h case _ : Injective f | _ : Injective g · guard_target = Injective f assumption · guard_target = Injective g assumption exact h example (hf : Injective f) (hg : Injective g) (h : g (f x) = g (f y)) : x = y := by rw [cancel_injective, cancel_injective] at h case _ : Injective f | _ : Injective g => _ · guard_target = Injective f assumption · guard_target = Injective g assumption exact h example (a : Nat) : 0 + a = a := by induction a case _ n ih : 0 + (n + 1) = n + 1 => guard_target =ₛ 0 + (n + 1) = n + 1 rw [← Nat.add_assoc, ih] case _ : 0 + 0 = 0 := rfl example (a : Nat) : 0 + a = a := by induction a case _ n ih : 0 + (n + 1) = n + 1 | _ : 0 + 0 = 0 · rw [← Nat.add_assoc, ih] · rfl example : True ∧ ∀ x : Nat, x = x := by constructor case' _ : ∀ _, _ => intro z case left => trivial guard_target =ₛ z = z rfl -- Test focusing by full match, suffix match, and prefix match #guard_msgs in example : True := by have x : Bool := ?a have y : Nat := ?a.b.c have z : String := ?c.b.a case a : Bool := true case a : Nat := 0 case a : String := "" trivial -- Test priorities when focusing by full match, suffix match, and prefix match example : True := by let x : Nat := ?a let y : Nat := ?c.b.a let z : Nat := ?c'.b.a let w : Nat := ?a.b.c case a : Nat := 0 case a : Nat := 1 case a : Nat := 2 case a : Nat := 3 guard_hyp x : Nat := 0 guard_hyp y : Nat := 2 guard_hyp z : Nat := 1 guard_hyp w : Nat := 3 trivial -- Test renaming when not pattern matching example (n : Nat) : 0 ≤ n := by induction n case _ : 0 ≤ 0 | succ n ih · guard_target =ₛ 0 ≤ 0 constructor · guard_target =ₛ 0 ≤ n + 1 guard_hyp ih : 0 ≤ n simp ================================================ FILE: BatteriesTest/congr.lean ================================================ import Batteries.Tactic.Congr section congr example (c : Prop → Prop → Prop → Prop) (x x' y z z' : Prop) (h₀ : x ↔ x') (h₁ : z ↔ z') : c x y z ↔ c x' y z' := by apply Iff.of_eq -- FIXME: not needed in lean 3 congr · guard_target =ₐ x = x' apply_ext_theorem assumption · guard_target =ₐ z = z' ext assumption example {α β γ δ} {F : ∀ {α β}, (α → β) → γ → δ} {f g : α → β} {s : γ} (h : ∀ x : α, f x = g x) : F f s = F g s := by congr with x -- apply_assumption -- FIXME apply h example {α β : Type _} {f : _ → β} {x y : { x : { x : α // x = x } // x = x }} (h : x.1 = y.1) : f x = f y := by congr with : 1 exact h example {α β : Type _} {F : _ → β} {f g : { f : α → β // f = f }} (h : ∀ x : α, (f : α → β) x = (g : α → β) x) : F f = F g := by rcongr x revert x guard_target = type_of% h exact h section -- Adaptation note: the next two examples have always failed if `List.ext` was in scope, -- but until nightly-2024-04-24 (when `List.ext` was upstreamed), it wasn't in scope. -- In order to preserve the test behaviour we locally remove the `ext` attribute. attribute [-ext] List.ext_getElem? example {ls : List Nat} : (ls.map fun _ => (ls.map fun y => 1 + y).sum + 1) = (ls.map fun _ => (ls.map fun y => Nat.succ y).sum + 1) := by rcongr (_x y) guard_target =ₐ 1 + y = y.succ rw [Nat.add_comm] example {ls : List Nat} {f g : Nat → Nat} {h : ∀ x, f x = g x} : (ls.map fun x => f x + 3) = ls.map fun x => g x + 3 := by rcongr x exact h x end -- succeed when either `ext` or `congr` can close the goal example : () = () := by rcongr example : 0 = 0 := by rcongr example {α} (a : α) : a = a := by congr example : { f : Nat → Nat // f = id } := ⟨_, by congr (config := { closePre := false, closePost := false }) with x exact Nat.zero_add x⟩ -- FIXME(?): congr doesn't fail -- example {α} (a b : α) (h : False) : a = b := by -- fail_if_success congr -- cases h end congr ================================================ FILE: BatteriesTest/conv_equals.lean ================================================ /- Copyright (c) 2023 Joachim Breitner. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Joachim Breitner -/ import Batteries.Tactic.Basic -- The example from the doc string, for quick comparision -- and keeping the doc up-to-date -- (only `guard_target` added) /-- warning: declaration uses `sorry` -/ #guard_msgs in example (P : (Nat → Nat) → Prop) : P (fun n => n - n) := by conv in (_ - _) => equals 0 => -- current goal: ⊢ n - n = 0 guard_target =ₛ n - n = 0 apply Nat.sub_self guard_target =ₛ P (fun n => 0) -- current goal: P (fun n => 0) sorry -- This tests that the goal created by equals must be closed -- Using #guard_msgs below triggers this linter set_option linter.unreachableTactic false /-- error: unsolved goals P : (Nat → Nat) → Prop n : Nat ⊢ n - n = 0 --- error: No goals to be solved -/ #guard_msgs in example (P : (Nat → Nat) → Prop) : P (fun n => n - n) := by conv in (_ - _) => equals 0 => skip -- this should complain -- and at this point, there should be no goal left tactic => sorry sorry /-- warning: declaration uses `sorry` -/ #guard_msgs in example (P : Nat → Prop) : P 12 := by conv => enter [1] equals (12 : Fin 37) => guard_target =ₛ (12 : Nat) = (12 : Fin 37) rfl guard_target =ₛ P (12 : Fin 37) sorry /-- error: Type mismatch 12 has type Nat but is expected to have type Fin 37 --- error: unsolved goals P : Fin 37 → Prop ⊢ 12 = sorry -/ #guard_msgs in example (P : Fin 37 → Prop) : P 12 := by conv => enter [1] equals (12 : Nat) => skip sorry ================================================ FILE: BatteriesTest/except.lean ================================================ -- Test: core does not currently provide DecidableEq for Except. -- If this test fails, it means core now provides DecidableEq for Except -- and the Batteries instance in Batteries.Lean.Except should be removed. /-- error: failed to synthesize instance of type class DecidableEq (Except ?m.1 ?m.2) Hint: Type class instance resolution failures can be inspected with the `set_option trace.Meta.synthInstance true` command. -/ #guard_msgs in #check (inferInstance : DecidableEq (Except _ _)) ================================================ FILE: BatteriesTest/exfalso.lean ================================================ import Batteries.Tactic.Basic private axiom test_sorry : ∀ {α}, α example {A} (h : False) : A := by exfalso exact h example {A} : False → A := by exfalso show False -- exfalso is not supposed to close the goal yet exact test_sorry ================================================ FILE: BatteriesTest/float.lean ================================================ import Batteries.Lean.Float #guard 0.0.toRatParts == some (0, -53) #guard (2^(-1000):Float).toRatParts == some (4503599627370496, -1052) #guard (2^(-30):Float).toRatParts == some (4503599627370496, -82) #guard 0.1.toRatParts == some (7205759403792794, -56) #guard 0.5.toRatParts == some (4503599627370496, -53) #guard 5.0.toRatParts == some (5629499534213120, -50) #guard (-5.0).toRatParts == some (-5629499534213120, -50) #guard 5.5.toRatParts == some (6192449487634432, -50) #guard 500000000000000.5.toRatParts == some (8000000000000008, -4) #guard 5000000000000000.5.toRatParts == some (5000000000000000, 0) #guard 1e1000.toRatParts == none #guard (-1e1000).toRatParts == none #guard (-0/0:Float).toRatParts == none #guard 0.0.toRatParts' == some (0, 0) #guard (2^(-1000):Float).toRatParts' == some (1, -1000) #guard (2^(-30):Float).toRatParts' == some (1, -30) #guard 0.1.toRatParts' == some (3602879701896397, -55) #guard 0.5.toRatParts' == some (1, -1) #guard 5.0.toRatParts' == some (5, 0) #guard (-5.0).toRatParts' == some (-5, 0) #guard 5.5.toRatParts' == some (11, -1) #guard 500000000000000.5.toRatParts' == some (1000000000000001, -1) #guard 5000000000000000.5.toRatParts' == some (152587890625, 15) #guard 1e1000.toRatParts' == none #guard (-1e1000).toRatParts' == none #guard (-0/0:Float).toRatParts' == none #guard 0.0.toStringFull == "0" #guard (2^(-1000):Float).toStringFull.length == 1002 #guard (2^(-30):Float).toStringFull == "0.000000000931322574615478515625" #guard 0.1.toStringFull == "0.1000000000000000055511151231257827021181583404541015625" #guard 0.5.toStringFull == "0.5" #guard 5.0.toStringFull == "5" #guard (-5.0).toStringFull == "-5" #guard 5.5.toStringFull == "5.5" #guard 500000000000000.5.toStringFull == "500000000000000.5" #guard 5000000000000000.5.toStringFull == "5000000000000000" #guard 1e1000.toStringFull == "inf" #guard (-1e1000).toStringFull == "-inf" #guard (-0/0:Float).toStringFull == "NaN" #guard Nat.divFloat 1 0 == Float.inf #guard Nat.divFloat 50 0 == Float.inf #guard (Nat.divFloat 0 0).isNaN #guard Nat.divFloat 1 3 == (1 / 3 : Float) #guard Nat.divFloat 1 6 == (1 / 6 : Float) #guard Nat.divFloat 2 3 == (2 / 3 : Float) #guard Nat.divFloat 100 17 == (100 / 17 : Float) #guard Nat.divFloat 5000000000000000 1 == (5000000000000000 : Float) #guard [0,0,0,1,1,1,2,2,2,2,2,3,3,3,4,4,4].zipIdx.all fun p => Nat.divFloat (5000000000000000*4+p.2) 4 == (5000000000000000+p.1).toFloat #guard Nat.divFloat ((2^53-1)*(2^(1024-53))) 1 == ((2^53-1)*(2^(1024-53))) #guard Nat.divFloat (((2^53-1)*4+1)*(2^(1024-53))) 4 == ((2^53-1)*(2^(1024-53))) #guard Nat.divFloat (((2^53-1)*4+2)*(2^(1024-53))) 4 == Float.inf #guard Nat.divFloat (((2^53-1)*4+3)*(2^(1024-53))) 4 == Float.inf #guard Nat.divFloat (((2^53-1)*4+4)*(2^(1024-53))) 4 == Float.inf #guard Int.divFloat 1 3 == (1 / 3 : Float) #guard Int.divFloat (-1) 3 == (-1 / 3 : Float) #guard Int.divFloat 1 (-3) == (1 / -3 : Float) #guard Int.divFloat (-1) (-3) == (-1 / -3 : Float) #guard Int.divFloat (-1) 0 == -Float.inf #guard (Int.divFloat 0 0).isNaN #guard (Int.divFloat 0 1).toString == "0.000000" #guard (Int.divFloat 0 (-1)).toString == "-0.000000" ================================================ FILE: BatteriesTest/help_cmd.lean ================================================ import Batteries.Tactic.HelpCmd /-! The `#help` command The `#help` command family currently contains these subcommands: * `#help attr` / `#help attribute` * `#help cat` * `#help cats` * `#help command` (abbrev for `#help cat command`) * `#help conv` (abbrev for `#help cat conv`) * `#help option` * `#help tactic` (abbrev for `#help cat tactic`) * `#help term` (abbrev for `#help cat term`) All forms take an optional identifier prefix to narrow the search. The `#help cat` command has a variant `#help cat+` that displays additional information, similarly for commands derived from `#help cat`. WARNING: Some of these tests will need occasional updates when new features are added and even when some documentation is edited. This type of break will be unexpected but the fix will not be unexpected! Just update the guard text to match the output after your addition. -/ /-! `#help attr` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help attr /-- error: no attributes start with foobarbaz -/ #guard_msgs in #help attr foobarbaz /-- info: [inline]: mark definition to be inlined Changes the inlining behavior. This attribute comes in several variants: - `@[inline]`: marks the definition to be inlined when it is appropriate. - `@[inline_if_reduce]`: marks the definition to be inlined if an application of it after inlining and applying reduction isn't a `match` expression. This attribute can be used for inlining structurally recursive functions. - `@[noinline]`: marks the definition to never be inlined. - `@[always_inline]`: marks the definition to always be inlined. - `@[macro_inline]`: marks the definition to always be inlined at the beginning of compilation. This makes it possible to define functions that evaluate some of their parameters lazily. Example: ``` @[macro_inline] def test (x y : Nat) : Nat := if x = 42 then x else y ⏎ #eval test 42 (2^1000000000000) -- doesn't compute 2^1000000000000 ``` Only non-recursive functions may be marked `@[macro_inline]`. [inline_if_reduce]: mark definition to be inlined when resultant term after reduction is not a `cases_on` application Changes the inlining behavior. This attribute comes in several variants: - `@[inline]`: marks the definition to be inlined when it is appropriate. - `@[inline_if_reduce]`: marks the definition to be inlined if an application of it after inlining and applying reduction isn't a `match` expression. This attribute can be used for inlining structurally recursive functions. - `@[noinline]`: marks the definition to never be inlined. - `@[always_inline]`: marks the definition to always be inlined. - `@[macro_inline]`: marks the definition to always be inlined at the beginning of compilation. This makes it possible to define functions that evaluate some of their parameters lazily. Example: ``` @[macro_inline] def test (x y : Nat) : Nat := if x = 42 then x else y ⏎ #eval test 42 (2^1000000000000) -- doesn't compute 2^1000000000000 ``` Only non-recursive functions may be marked `@[macro_inline]`. -/ #guard_msgs in #help attr inl /-! `#help cat` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help cat term /-- error: foobarbaz is not a syntax category -/ #guard_msgs in #help cat foobarbaz /-- info: syntax "("... [«prec(_)»] Parentheses are used for grouping precedence expressions. syntax ..."+"... [Lean.Parser.Syntax.addPrec] Addition of precedences. This is normally used only for offsetting, e.g. `max + 1`. syntax ..."-"... [Lean.Parser.Syntax.subPrec] Subtraction of precedences. This is normally used only for offsetting, e.g. `max - 1`. syntax "arg"... [precArg] Precedence used for application arguments (`do`, `by`, ...). syntax "lead"... [precLead] Precedence used for terms not supposed to be used as arguments (`let`, `have`, ...). syntax "max"... [precMax] Maximum precedence used in term parsers, in particular for terms in function position (`ident`, `paren`, ...) syntax "min"... [precMin] Minimum precedence used in term parsers. syntax "min1"... [precMin1] `(min+1)` (we can only write `min+1` after `Meta.lean`) syntax "num"... [Lean.Parser.Syntax.numPrec] -/ #guard_msgs in #help cat prec /-- info: syntax "("... [«prec(_)»] Parentheses are used for grouping precedence expressions. + macro «_aux_Init_Notation___macroRules_prec(_)_1» Parentheses are used for grouping precedence expressions. syntax ..."+"... [Lean.Parser.Syntax.addPrec] Addition of precedences. This is normally used only for offsetting, e.g. `max + 1`. + macro Lean._aux_Init_Meta___macroRules_Lean_Parser_Syntax_addPrec_1 syntax ..."-"... [Lean.Parser.Syntax.subPrec] Subtraction of precedences. This is normally used only for offsetting, e.g. `max - 1`. + macro Lean._aux_Init_Meta___macroRules_Lean_Parser_Syntax_subPrec_1 syntax "arg"... [precArg] Precedence used for application arguments (`do`, `by`, ...). + macro _aux_Init_Notation___macroRules_precArg_1 Precedence used for application arguments (`do`, `by`, ...). syntax "lead"... [precLead] Precedence used for terms not supposed to be used as arguments (`let`, `have`, ...). + macro _aux_Init_Notation___macroRules_precLead_1 Precedence used for terms not supposed to be used as arguments (`let`, `have`, ...). syntax "max"... [precMax] Maximum precedence used in term parsers, in particular for terms in function position (`ident`, `paren`, ...) + macro _aux_Init_Notation___macroRules_precMax_1 Maximum precedence used in term parsers, in particular for terms in function position (`ident`, `paren`, ...) syntax "min"... [precMin] Minimum precedence used in term parsers. + macro _aux_Init_Notation___macroRules_precMin_1 Minimum precedence used in term parsers. syntax "min1"... [precMin1] `(min+1)` (we can only write `min+1` after `Meta.lean`) + macro _aux_Init_Notation___macroRules_precMin1_1 `(min+1)` (we can only write `min+1` after `Meta.lean`) syntax "num"... [Lean.Parser.Syntax.numPrec] -/ #guard_msgs in #help cat+ prec /-! `#help cats` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help cats /-- error: no syntax categories start with foobarbaz -/ #guard_msgs in #help cats foobarbaz /-- info: category prec [Lean.Parser.Category.prec] `prec` is a builtin syntax category for precedences. A precedence is a value that expresses how tightly a piece of syntax binds: for example `1 + 2 * 3` is parsed as `1 + (2 * 3)` because `*` has a higher precedence than `+`. Higher numbers denote higher precedence. In addition to literals like `37`, there are some special named precedence levels: * `arg` for the precedence of function arguments * `max` for the highest precedence used in term parsers (not actually the maximum possible value) * `lead` for the precedence of terms not supposed to be used as arguments and you can also add and subtract precedences. category prio [Lean.Parser.Category.prio] `prio` is a builtin syntax category for priorities. Priorities are used in many different attributes. Higher numbers denote higher priority, and for example typeclass search will try high priority instances before low priority. In addition to literals like `37`, you can also use `low`, `mid`, `high`, as well as add and subtract priorities. -/ #guard_msgs in #help cats pr /-! `#help command` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help command /-- error: no command declarations start with foobarbaz -/ #guard_msgs in #help command foobarbaz /-- info: syntax "#eval"... [Lean.Parser.Command.eval] `#eval e` evaluates the expression `e` by compiling and evaluating it. ⏎ * The command attempts to use `ToExpr`, `Repr`, or `ToString` instances to print the result. * If `e` is a monadic value of type `m ty`, then the command tries to adapt the monad `m` to one of the monads that `#eval` supports, which include `IO`, `CoreM`, `MetaM`, `TermElabM`, and `CommandElabM`. Users can define `MonadEval` instances to extend the list of supported monads. ⏎ The `#eval` command gracefully degrades in capability depending on what is imported. Importing the `Lean.Elab.Command` module provides full capabilities. ⏎ Due to unsoundness, `#eval` refuses to evaluate expressions that depend on `sorry`, even indirectly, since the presence of `sorry` can lead to runtime instability and crashes. This check can be overridden with the `#eval! e` command. ⏎ Options: * If `eval.pp` is true (default: true) then tries to use `ToExpr` instances to make use of the usual pretty printer. Otherwise, only tries using `Repr` and `ToString` instances. * If `eval.type` is true (default: false) then pretty prints the type of the evaluated value. * If `eval.derive.repr` is true (default: true) then attempts to auto-derive a `Repr` instance when there is no other way to print the result. ⏎ See also: `#reduce e` for evaluation by term reduction. syntax "#eval!"... [Lean.Parser.Command.evalBang] `#eval e` evaluates the expression `e` by compiling and evaluating it. ⏎ * The command attempts to use `ToExpr`, `Repr`, or `ToString` instances to print the result. * If `e` is a monadic value of type `m ty`, then the command tries to adapt the monad `m` to one of the monads that `#eval` supports, which include `IO`, `CoreM`, `MetaM`, `TermElabM`, and `CommandElabM`. Users can define `MonadEval` instances to extend the list of supported monads. ⏎ The `#eval` command gracefully degrades in capability depending on what is imported. Importing the `Lean.Elab.Command` module provides full capabilities. ⏎ Due to unsoundness, `#eval` refuses to evaluate expressions that depend on `sorry`, even indirectly, since the presence of `sorry` can lead to runtime instability and crashes. This check can be overridden with the `#eval! e` command. ⏎ Options: * If `eval.pp` is true (default: true) then tries to use `ToExpr` instances to make use of the usual pretty printer. Otherwise, only tries using `Repr` and `ToString` instances. * If `eval.type` is true (default: false) then pretty prints the type of the evaluated value. * If `eval.derive.repr` is true (default: true) then attempts to auto-derive a `Repr` instance when there is no other way to print the result. ⏎ See also: `#reduce e` for evaluation by term reduction. syntax "#exit"... [Lean.Parser.Command.exit] -/ #guard_msgs in #help command "#e" -- Notably, we don't show a generic `"/--"` in the following test: /-- info: syntax "abbrev"... [Lean.Parser.Command.declaration] -/ #guard_msgs in #help command def /-- info: syntax "#eval"... [Lean.Parser.Command.eval] `#eval e` evaluates the expression `e` by compiling and evaluating it. ⏎ * The command attempts to use `ToExpr`, `Repr`, or `ToString` instances to print the result. * If `e` is a monadic value of type `m ty`, then the command tries to adapt the monad `m` to one of the monads that `#eval` supports, which include `IO`, `CoreM`, `MetaM`, `TermElabM`, and `CommandElabM`. Users can define `MonadEval` instances to extend the list of supported monads. ⏎ The `#eval` command gracefully degrades in capability depending on what is imported. Importing the `Lean.Elab.Command` module provides full capabilities. ⏎ Due to unsoundness, `#eval` refuses to evaluate expressions that depend on `sorry`, even indirectly, since the presence of `sorry` can lead to runtime instability and crashes. This check can be overridden with the `#eval! e` command. ⏎ Options: * If `eval.pp` is true (default: true) then tries to use `ToExpr` instances to make use of the usual pretty printer. Otherwise, only tries using `Repr` and `ToString` instances. * If `eval.type` is true (default: false) then pretty prints the type of the evaluated value. * If `eval.derive.repr` is true (default: true) then attempts to auto-derive a `Repr` instance when there is no other way to print the result. ⏎ See also: `#reduce e` for evaluation by term reduction. + command elab Lean.Elab.Command.elabEval syntax "#eval!"... [Lean.Parser.Command.evalBang] `#eval e` evaluates the expression `e` by compiling and evaluating it. ⏎ * The command attempts to use `ToExpr`, `Repr`, or `ToString` instances to print the result. * If `e` is a monadic value of type `m ty`, then the command tries to adapt the monad `m` to one of the monads that `#eval` supports, which include `IO`, `CoreM`, `MetaM`, `TermElabM`, and `CommandElabM`. Users can define `MonadEval` instances to extend the list of supported monads. ⏎ The `#eval` command gracefully degrades in capability depending on what is imported. Importing the `Lean.Elab.Command` module provides full capabilities. ⏎ Due to unsoundness, `#eval` refuses to evaluate expressions that depend on `sorry`, even indirectly, since the presence of `sorry` can lead to runtime instability and crashes. This check can be overridden with the `#eval! e` command. ⏎ Options: * If `eval.pp` is true (default: true) then tries to use `ToExpr` instances to make use of the usual pretty printer. Otherwise, only tries using `Repr` and `ToString` instances. * If `eval.type` is true (default: false) then pretty prints the type of the evaluated value. * If `eval.derive.repr` is true (default: true) then attempts to auto-derive a `Repr` instance when there is no other way to print the result. ⏎ See also: `#reduce e` for evaluation by term reduction. + command elab Lean.Elab.Command.elabEvalBang syntax "#exit"... [Lean.Parser.Command.exit] + command elab Lean.Elab.Command.elabExit -/ #guard_msgs in #help command+ "#e" /-! #help conv -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help conv /-- error: no conv declarations start with foobarbaz -/ #guard_msgs in #help conv foobarbaz /-- info: syntax "reduce"... [Lean.Parser.Tactic.Conv.reduce] Puts term in normal form, this tactic is meant for debugging purposes only. syntax "repeat"... [Lean.Parser.Tactic.Conv.convRepeat_] `repeat convs` runs the sequence `convs` repeatedly until it fails to apply. syntax "rewrite"... [Lean.Parser.Tactic.Conv.rewrite] `rw [thm]` rewrites the target using `thm`. See the `rw` tactic for more information. -/ #guard_msgs in #help conv "re" /-- info: syntax "reduce"... [Lean.Parser.Tactic.Conv.reduce] Puts term in normal form, this tactic is meant for debugging purposes only. + tactic elab Lean.Elab.Tactic.Conv.evalReduce syntax "repeat"... [Lean.Parser.Tactic.Conv.convRepeat_] `repeat convs` runs the sequence `convs` repeatedly until it fails to apply. + macro Lean.Parser.Tactic.Conv._aux_Init_Conv___macroRules_Lean_Parser_Tactic_Conv_convRepeat__1 syntax "rewrite"... [Lean.Parser.Tactic.Conv.rewrite] `rw [thm]` rewrites the target using `thm`. See the `rw` tactic for more information. + tactic elab Lean.Elab.Tactic.Conv.evalRewrite -/ #guard_msgs in #help conv+ "re" /-! `#help option` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help option /-- error: no options start with foobarbaz -/ #guard_msgs in #help option foobarbaz /-- info: option pp.instanceTypes : Bool := false (pretty printer) when printing explicit applications, show the types of inst-implicit arguments option pp.instances : Bool := true (pretty printer) if set to false, replace inst-implicit arguments to explicit applications with placeholders option pp.instantiateMVars : Bool := true (pretty printer) instantiate mvars before delaborating -/ #guard_msgs in #help option pp.ins /-! `#help tactic` -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help tactic /-- error: no tactic declarations start with foobarbaz -/ #guard_msgs in #help tactic foobarbaz /-- info: syntax "by_cases"... [«tacticBy_cases_:_»] `by_cases (h :)? p` splits the main goal into two cases, assuming `h : p` in the first branch, and `h : ¬ p` in the second branch. -/ #guard_msgs in #help tactic by /-- info: syntax "by_cases"... [«tacticBy_cases_:_»] `by_cases (h :)? p` splits the main goal into two cases, assuming `h : p` in the first branch, and `h : ¬ p` in the second branch. + macro «_aux_Init_ByCases___macroRules_tacticBy_cases_:__2» + macro «_aux_Init_ByCases___macroRules_tacticBy_cases_:__1» -/ #guard_msgs in #help tactic+ by /-! #help term -/ -- this is a long and constantly updated listing, we don't check the output #guard_msgs(error, drop info) in #help term /-- error: no term declarations start with foobarbaz -/ #guard_msgs in #help term foobarbaz /-- info: syntax "debug_assert!"... [Lean.Parser.Term.debugAssert] `debug_assert! cond` panics if `cond` evaluates to `false` and the executing code has been built with debug assertions enabled (see the `debugAssertions` option). syntax "decl_name%"... [Lean.Parser.Term.declName] A macro which evaluates to the name of the currently elaborating declaration. syntax "default_or_ofNonempty%"... [Lean.Parser.Term.defaultOrOfNonempty] -/ #guard_msgs in #help term de /-- info: syntax "debug_assert!"... [Lean.Parser.Term.debugAssert] `debug_assert! cond` panics if `cond` evaluates to `false` and the executing code has been built with debug assertions enabled (see the `debugAssertions` option). + term elab Lean.Elab.Term.elabDebugAssert syntax "decl_name%"... [Lean.Parser.Term.declName] A macro which evaluates to the name of the currently elaborating declaration. + term elab Lean.Elab.Term.elabDeclName syntax "default_or_ofNonempty%"... [Lean.Parser.Term.defaultOrOfNonempty] + term elab Lean.Elab.Term.Op.elabDefaultOrNonempty -/ #guard_msgs in #help term+ de ================================================ FILE: BatteriesTest/import_lean.lean ================================================ import Lean import Batteries /-! This file ensures that we can import all of `Lean` and `Batteries` without name conflicts. -/ ================================================ FILE: BatteriesTest/instances.lean ================================================ import Batteries.Tactic.Instances set_option linter.missingDocs false /-- error: type class instance expected Fin 1 -/ #guard_msgs in #instances Fin 1 /-- info: 3 instances: instAddNat : Add Nat (prio 100) Lean.Grind.Semiring.toAdd.{u} {α : Type u} [self : Lean.Grind.Semiring α] : Add α (prio 100) Lean.Grind.AddCommMonoid.toAdd.{u} {M : Type u} [self : Lean.Grind.AddCommMonoid M] : Add M -/ #guard_msgs in #instances Add Nat namespace Testing class A (α : Type) /-- info: No instances -/ #guard_msgs in #instances A instance (priority := high) : A Nat := ⟨⟩ instance : A Int := ⟨⟩ instance : A Bool := ⟨⟩ /-- info: 3 instances: (prio 10000) Testing.instANat : A Nat Testing.instABool : A Bool Testing.instAInt : A Int -/ #guard_msgs in #instances A _ /-- info: 3 instances: (prio 10000) Testing.instANat : A Nat Testing.instABool : A Bool Testing.instAInt : A Int -/ #guard_msgs in #instances A /-- info: No instances -/ #guard_msgs in #instances (α : Type) → A α instance : A α := ⟨⟩ /-- info: 5 instances: (local) inst✝ : A β (prio 10000) Testing.instANat : A Nat Testing.instABool : A Bool Testing.instAInt : A Int Testing.instA {α : Type} : A α -/ #guard_msgs in #instances [A β] : A /-- info: 1 instance: Testing.instA {α : Type} : A α -/ #guard_msgs in #instances (α : Type) → A α end Testing ================================================ FILE: BatteriesTest/isIndependentOf.lean ================================================ import Batteries.Lean.Meta.Basic import Batteries.Tactic.PermuteGoals import Lean.Meta.Tactic.IndependentOf open Lean Meta Elab.Tactic elab "check_indep" : tactic => do match ← getGoals with | [] => throwError "Expected goal" | g :: l => let res := if ←g.isIndependentOf l then "" else "not " let t ← instantiateMVars (← g.getType) logWarning s!"{←ppExpr (.mvar g)} : {←ppExpr t} is {res}independent of:" l.forM fun g' => do logInfo s!" {←ppExpr (.mvar g')} : {←ppExpr (← g'.getType)}" let ppD (l : LocalDecl) : TacticM PUnit := do logInfo s!" {←ppExpr (.fvar l.fvarId)} : {←ppExpr l.type}" let _ ← (←g'.getDecl).lctx.forM ppD pure () /-- warning: ?w : Nat is not independent of: -/ #guard_msgs(warning, drop info) in example : ∃ (n : Nat), ∀(x : Fin n), x.val = 0 := by apply Exists.intro intro x swap check_indep exact 0 revert x intro ⟨x, lt⟩ contradiction -- This is a tricker one, where the dependency is via a hypothesis. /-- warning: ?w : Nat is not independent of: -/ #guard_msgs(warning, drop info) in example : ∃ (n : Nat), ∀(x : Fin n) (y : Nat), x.val = y → y = 0 := by apply Exists.intro intro x y p swap check_indep exact 0 revert x intro ⟨x, lt⟩ contradiction ================================================ FILE: BatteriesTest/kmp_matcher.lean ================================================ import Batteries.Data.String.Matcher import Batteries.Data.List.Matcher /-! # Tests for the Knuth-Morris-Pratt (KMP) matching algorithm -/ /-! ### String API -/ /-- Matcher for pattern "abba" -/ def m := String.Matcher.ofString "abba" #guard ! Option.isSome (m.find? "AbbabbA") #guard Option.isSome (m.find? "aabbaa") #guard Array.size (m.findAll "abbabba") = 2 #guard Array.size (m.findAll "abbabbabba") = 3 #guard Option.isSome ("xyyxx".findSubstr? "xy") #guard ! Option.isSome ("xyyxx".findSubstr? "xyx") #guard Array.size ("xyyxx".findAllSubstr "xyx") = 0 #guard Array.size ("xyyxxyx".findAllSubstr "xyx") = 1 #guard Array.size ("xyxyyxxyx".findAllSubstr "xyx") = 2 #guard Array.size ("xyxyxyyxxyxyx".findAllSubstr "xyx") = 4 /-! ### List API -/ def lm := List.Matcher.ofList [0,1,1,0] #guard lm.find? [2,1,1,0,1,1,2] == none #guard lm.find? [0,0,1,1,0,0] == some (1, 5) #guard (lm.findAll [0,1,1,0,1,1,0]).size == 2 #guard (lm.findAll [0,1,1,0,1,1,0,1,1,0]).size == 3 ================================================ FILE: BatteriesTest/lemma_cmd.lean ================================================ import Batteries.Tactic.Lemma -- lemma disabled by default /-- info: Try this: [apply] theorem --- error: `lemma` is not supported by default, please use `theorem` instead. Use `set_option lang.lemmaCmd true` to enable the use of the `lemma` command in a file. Use the command line option `-Dlang.lemmaCmd=true` to enable the use of `lemma` globally. -/ #guard_msgs in lemma test1 : 3 < 7 := by decide -- lemma enabled for one command set_option lang.lemmaCmd true in lemma test2 : 3 < 7 := by decide -- lemma disabled again /-- info: Try this: [apply] theorem --- error: `lemma` is not supported by default, please use `theorem` instead. Use `set_option lang.lemmaCmd true` to enable the use of the `lemma` command in a file. Use the command line option `-Dlang.lemmaCmd=true` to enable the use of `lemma` globally. -/ #guard_msgs in lemma test3 : 3 < 7 := by decide -- lemma enabled for rest of file set_option lang.lemmaCmd true lemma test4 : 3 < 7 := by decide lemma test5 : 3 < 7 := by decide ================================================ FILE: BatteriesTest/library_note.lean ================================================ import Batteries.Tactic.HelpCmd import BatteriesTest.Internal.DummyLibraryNote2 /-- error: Note not found -/ #guard_msgs in #help note "no note" /-- info: library_note Other /-- 1: this is a testnote with a label not starting with "te", so it shouldn't appear when looking for notes with label starting with "te". -/ -/ #guard_msgs in #help note "Other" library_note «test4» /-- 4: This note was not imported, and therefore appears below the imported notes. -/ library_note «test5» /-- 5: This note was also not imported, and therefore appears below the imported notes, and the previously added note. -/ /-- info: library_note «temporary note» /-- 1: This is a testnote whose label also starts with "te", but gets sorted before "test" -/ library_note test1 /-- 1: This is a testnote for testing the library note feature of batteries. The `#help note` command should be able to find this note when imported. -/ library_note test2 /-- 2: This is a second testnote for testing the library note feature of batteries. -/ library_note test3 /-- 3: this is a note in a different file importing the above testnotes, but still imported by the actual testfile. -/ library_note test4 /-- 4: This note was not imported, and therefore appears below the imported notes. -/ library_note test5 /-- 5: This note was also not imported, and therefore appears below the imported notes, and the previously added note. -/ -/ #guard_msgs in #help note "te" /-! ## Tests for space-to-underscore encoding in declaration names Library notes with spaces in their names should create declarations with underscores, for compatibility with the Lean export format (which doesn't support whitespace in names). -/ -- Test that a note with spaces creates a declaration with underscores library_note «note with spaces» /-- This note has spaces in its name to test export format compatibility. -/ -- Verify the declaration name has underscores, not spaces /-- info: LibraryNote.note_with_spaces : Batteries.Util.LibraryNote -/ #guard_msgs in #check LibraryNote.note_with_spaces -- Test that a note with multiple consecutive spaces works library_note «note with multiple spaces» /-- This note has multiple consecutive spaces. -/ /-- info: LibraryNote.note__with___multiple____spaces : Batteries.Util.LibraryNote -/ #guard_msgs in #check LibraryNote.note__with___multiple____spaces /-- info: library_note «note with spaces» /-- This note has spaces in its name to test export format compatibility. -/ -/ #guard_msgs in #help note "note with" ================================================ FILE: BatteriesTest/lintTC.lean ================================================ import Batteries.Tactic.Lint.TypeClass import Lean.Elab.Command open Batteries.Tactic.Lint namespace A /-- warning: unused variable `β` Note: This linter can be disabled with `set_option linter.unusedVariables false` -/ #guard_msgs in local instance impossible {α β : Type} [Inhabited α] : Nonempty α := ⟨default⟩ run_meta guard (← impossibleInstance.test ``impossible).isSome end A namespace B instance bad : Nat := 1 run_meta guard (← nonClassInstance.test ``bad).isSome instance good : Inhabited Nat := ⟨1⟩ run_meta guard (← nonClassInstance.test ``good).isNone end B ================================================ FILE: BatteriesTest/lintTrace.lean ================================================ import Batteries.Tactic.Lint /-! Tests tracing in `#lint`. Note that this does not test tracing in `runLinter` per se. -/ -- oops, no docstring def foo := 3 theorem bar : foo = 3 := rfl set_option trace.Batteries.Lint true /-- trace: [Batteries.Lint] Running linters: docBlame [Batteries.Lint] - docBlame: (0/2) Starting... [Batteries.Lint] - docBlame: (1/2) Getting... [Batteries.Lint] - docBlame: (2/2) Failed with 1 messages. [Batteries.Lint] Completed linting! -/ #guard_msgs (trace, drop error) in #lint- only docBlame /-- trace: [Batteries.Lint] Running linters: defLemma [Batteries.Lint] - defLemma: (0/2) Starting... [Batteries.Lint] - defLemma: (1/2) Getting... [Batteries.Lint] - defLemma: (2/2) Passed! [Batteries.Lint] Completed linting! -/ #guard_msgs in #lint- only defLemma ================================================ FILE: BatteriesTest/lint_coinductive.lean ================================================ import Batteries.Tactic.Lint /-! Tests that linters skip auto-generated declarations from coinductive predicates. -/ /-- A coinductive stream predicate for testing. -/ coinductive MyStream (α : Type) : Prop where | cons : α → MyStream α → MyStream α mutual /-- Coinductive half of a mutual block for testing. -/ coinductive tick : Prop where | mk : ¬tock → tick /-- Inductive half of a mutual block for testing. -/ inductive tock : Prop where | mk : ¬tick → tock end #guard_msgs in #lint- only defLemma #guard_msgs in #lint- only docBlame ================================================ FILE: BatteriesTest/lint_docBlame.lean ================================================ import Batteries.Tactic.Lint set_option linter.missingDocs false /-- A docstring is needed here -/ structure AtLeastThirtySeven where /-- and here -/ val : Nat := 1 -- but not here prop : 37 ≤ val -- or here theorem AtLeastThirtySeven.lt (x : AtLeastThirtySeven) : 36 < x.val := x.prop #lint- only docBlame ================================================ FILE: BatteriesTest/lint_docBlameThm.lean ================================================ import Batteries.Tactic.Lint set_option linter.missingDocs false -- A docstring is not needed here structure AtLeastThirtySeven where -- or here val : Nat := 1 /-- but is needed here -/ prop : 37 ≤ val /-- and here -/ theorem AtLeastThirtySeven.lt (x : AtLeastThirtySeven) : 36 < x.val := x.prop #lint- only docBlameThm ================================================ FILE: BatteriesTest/lint_dupNamespace.lean ================================================ import Batteries.Tactic.Lint -- internal names should be ignored theorem Foo.Foo._bar : True := trivial #lint- only dupNamespace ================================================ FILE: BatteriesTest/lint_lean.lean ================================================ import Batteries.Tactic.Lint /-! This test file runs the environment linters set up in Batteries on the core Lean4 repository. Everything is commented out as it is too slow to run in regular Batteries CI (and in any case there are many failures still), but it is useful to run locally to see what the linters would catch. -/ -- We can't apply `nolint` attributes to imported declarations, -- but if we move the environment linters up to Lean, -- these nolints should be installed there. -- (And in the meantime you can "manually" ignore them!) -- attribute [nolint dupNamespace] Lean.Elab.Tactic.Tactic -- attribute [nolint dupNamespace] Lean.Parser.Parser Lean.Parser.Parser.rec Lean.Parser.Parser.mk -- Lean.Parser.Parser.info Lean.Parser.Parser.fn -- attribute [nolint explicitVarsOfIff] Iff.refl /-! Failing lints that need work. -/ -- Many fixed in https://github.com/leanprover/lean4/pull/4620 and subsequent PRs -- and should be checked again. -- #lint only simpNF in all -- Found 22 errors /-! Lints that fail, but that we're not intending to do anything about. -/ -- Mostly fixed in https://github.com/leanprover/lean4/pull/4621 -- There are many false positives here. -- To run this properly we would need to ignore all declarations with `@[extern]`. -- #lint only unusedArguments in all -- Found 89 errors -- After https://github.com/leanprover/lean4/pull/4616, these are all intentional and have -- `nolint` attributes above. -- #lint only dupNamespace in all -- Found 6 errors -- After https://github.com/leanprover/lean4/pull/4619 all of these should be caused by `abbrev`. -- Unless we decide to upstream something like `alias`, we're not planning on fixing these. -- #lint only defLemma in all -- Found 31 errors /-! Lints that have succeeded in the past, and hopefully still do! -/ -- #lint only explicitVarsOfIff in all -- Found 1 errors, `Iff.refl`, which could be nolinted. -- #lint only impossibleInstance in all -- Found 0 errors -- #lint only simpVarHead in all -- Found 0 error -- #lint only unusedHavesSuffices in all -- Found 0 errors -- #lint only checkUnivs in all -- Found 0 errors ================================================ FILE: BatteriesTest/lint_simpNF.lean ================================================ import Batteries.Tactic.Lint set_option linter.missingDocs false structure Equiv (α : Sort _) (β : Sort _) where toFun : α → β invFun : β → α infixl:25 " ≃ " => Equiv namespace Equiv instance : CoeFun (α ≃ β) fun _ => α → β := ⟨toFun⟩ protected def symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩ def sumCompl {α : Type _} (p : α → Prop) [DecidablePred p] : Sum { a // p a } { a // ¬p a } ≃ α where toFun := Sum.elim Subtype.val Subtype.val invFun a := if h : p a then Sum.inl ⟨a, h⟩ else Sum.inr ⟨a, h⟩ @[simp] theorem sumCompl_apply_symm_of_pos (p : α → Prop) [DecidablePred p] (a : α) (h : p a) : (sumCompl p).symm a = Sum.inl ⟨a, h⟩ := dif_pos h def foo (n : Nat) : Nat := if n = n then n else 0 @[simp] theorem foo_eq_id : foo = id := by funext n simp [foo] -- The following `dsimp`-lemma is (correctly) not flagged by the linter @[defeq, simp] theorem foo_eq_ite (n : Nat) : foo n = if n = n then n else 0 := by rfl end Equiv namespace List private axiom test_sorry : ∀ {α}, α @[simp] theorem ofFn_getElem_eq_map {β : Type _} (l : List α) (f : α → β) : ofFn (fun i : Fin l.length => f <| l[(i : Nat)]) = l.map f := test_sorry example {β : Type _} (l : List α) (f : α → β) : ofFn (fun i : Fin l.length => f <| l[(i : Nat)]) = l.map f := by simp only [ofFn_getElem_eq_map] end List /-! This tests that `simpNF` is not accidentally using `quasiPatternApprox := true`. -/ def eqToFun {X Y : Type} (p : X = Y) : X → Y := by rw [p]; exact id @[simp] theorem eqToFun_comp_eq_self {β} {X : Type} {f : β → Type} (z : ∀ b, X → f b) {j j' : β} (w : j = j') : eqToFun (by simp [w]) ∘ z j' = z j := by cases w; rfl @[simp] theorem eqToFun_comp_iso_hom_eq_self {β} {X : Type} {f : β → Type} (z : ∀ b, X ≃ f b) {j j' : β} (w : j = j') : eqToFun (by simp [w]) ∘ (z j').toFun = (z j).toFun := by cases w; rfl /-! Test that the simpNF linter does not report false positives when `dsimp` changes implicit arguments (e.g. unfolding carrier types in bundled structures). See https://github.com/leanprover/lean4/pull/12179. -/ section BackwardDefEqRespectTransparency class MyClass (α : Type) where op : α → α structure Bundle where carrier : Type [inst : MyClass carrier] attribute [instance] Bundle.inst def Bundle.of (X : Type) [MyClass X] : Bundle where carrier := X @[simp] theorem Bundle.of_carrier (X : Type) [MyClass X] : (Bundle.of X).carrier = X := rfl -- This simp lemma has a LHS where the implicit `α` argument to `MyClass.op` is -- `Bundle.carrier (Bundle.of X)` rather than `X`. `dsimp [Bundle.of_carrier]` can -- partially unfold this, but the result is the same up to the old defeq behavior. -- The linter should not flag this. @[simp] theorem Bundle.of_op {X : Type} [MyClass X] : @MyClass.op (Bundle.of X).carrier (Bundle.of X).inst = @MyClass.op X _ := rfl end BackwardDefEqRespectTransparency #lint- only simpNF ================================================ FILE: BatteriesTest/lint_simpNF_respectTransparency.lean ================================================ /- Copyright (c) 2025 Lean FRO, LLC. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ import Batteries.Tactic.Lint set_option linter.missingDocs false /-! Test that `linter.simpNF.respectTransparency true` catches simp lemmas whose LHS involves bundled carrier types that are only equal up to `backward.isDefEq.respectTransparency false`. With the default setting (`false`), `Bundle.of_op` is NOT flagged (see `lint_simpNF.lean`). With the strict setting (`true`), it IS flagged because the LHS is not in simp-normal form: `dsimp [Bundle.of_carrier]` simplifies the implicit carrier argument. -/ private class MyClass (α : Type) where op : α → α private structure Bundle where carrier : Type [inst : MyClass carrier] attribute [instance] Bundle.inst private def Bundle.of (X : Type) [MyClass X] : Bundle where carrier := X @[simp] private theorem Bundle.of_carrier (X : Type) [MyClass X] : (Bundle.of X).carrier = X := rfl @[simp] private theorem Bundle.of_op {X : Type} [MyClass X] : @MyClass.op (Bundle.of X).carrier (Bundle.of X).inst = @MyClass.op X _ := rfl /-- error: -- Found 1 error in 0 declarations (plus 31 automatically generated ones) in the current file with 1 linters /- The `simpNF` linter reports: SOME SIMP LEMMAS ARE NOT IN SIMP-NORMAL FORM. Please change the lemma to make sure their left-hand sides are in simp normal form. To learn about simp normal forms, see https://leanprover-community.github.io/extras/simp.html#simp-normal-form and https://lean-lang.org/doc/reference/latest/The-Simplifier/Simp-Normal-Forms/. -/ #check @Bundle.of_op /- Left-hand side simplifies from MyClass.op to MyClass.op using dsimp only [*, Bundle.of_carrier] Try to change the left-hand side to the simplified term! -/ -/ #guard_msgs in set_option linter.simpNF.respectTransparency true in #lint only simpNF ================================================ FILE: BatteriesTest/lint_unreachableTactic.lean ================================================ import Batteries.Linter.UnreachableTactic -- The warning generated by `linter.unreachableTactic` is not suppressed by `#guard_msgs`, -- because the linter is run on `#guard_msgs` itself. This is a known issue, see -- https://leanprover.zulipchat.com/#narrow/stream/348111-batteries/topic/unreachableTactic.20linter.20not.20suppressed.20by.20.60.23guard_msgs.60 -- We jump through an extra hoop here to silence the warning. set_option linter.unreachableTactic false in #guard_msgs(drop warning) in set_option linter.unreachableTactic true in /-- warning: this tactic is never executed Note: This linter can be disabled with `set_option linter.unreachableTactic false` -/ #guard_msgs in example : 1 = 1 := by rfl <;> simp /-- warning: declaration uses `sorry` -/ #guard_msgs in example : 1 = 1 := by stop rfl #guard_msgs (drop warning) in def t : Nat → Nat := sorry #guard_msgs (drop warning) in @[simp] theorem a : aa = 0 → t aa = 0 := sorry #guard_msgs in example (ha : aa = 0) : t aa = 0 := by simp (disch := assumption) ================================================ FILE: BatteriesTest/linterVisibility.lean ================================================ module -- import `Linter` into both private and public scopes for testing import Batteries.Tactic.Lint.Basic public import Batteries.Tactic.Lint.Basic open Batteries.Tactic.Lint /-- error: invalid attribute `env_linter`, declaration `foo` must be marked as `public` and `meta` -/ #guard_msgs (error, drop warning) in @[env_linter] def foo : Linter := sorry /-- error: invalid attribute `env_linter`, declaration `foo'` must be marked as `public` and `meta` but is only marked `public` -/ #guard_msgs (error, drop warning) in @[env_linter] public def foo' : Linter := sorry /-- error: invalid attribute `env_linter`, declaration `foo''` must be marked as `public` and `meta` but is only marked `meta` -/ #guard_msgs (error, drop warning) in @[env_linter] meta def foo'' : Linter := sorry ================================================ FILE: BatteriesTest/lintsimp.lean ================================================ import Batteries.Tactic.Lint open Batteries.Tactic.Lint set_option linter.missingDocs false def f : Nat := 0 def g : Nat := 0 def h : Nat := 0 @[simp] theorem fg : f = g := rfl @[simp] theorem fh : f = h := rfl run_meta guard (← [``fg, ``fh].anyM fun n => return (← simpNF.test n).isSome) @[simp] theorem test_and_comm : a ∧ b ↔ b ∧ a := And.comm run_meta guard (← simpComm.test ``test_and_comm).isSome @[simp] theorem Prod.mk_fst : (a, b).1 = id a := rfl run_meta guard (← simpVarHead.test ``Prod.mk_fst).isSome def SemiconjBy [Mul M] (a x y : M) : Prop := a * x = y * a structure MulOpposite (α : Type u) : Type u where op :: unop : α postfix:max "ᵐᵒᵖ" => MulOpposite namespace MulOpposite instance [Mul α] : Mul αᵐᵒᵖ where mul x y := op (unop y * unop x) @[simp] theorem unop_inj {x y : αᵐᵒᵖ} : unop x = unop y ↔ x = y := by cases x; cases y; simp #guard_msgs (drop warning) in @[simp] theorem semiconj_by_unop [Mul α] {a x y : αᵐᵒᵖ} : SemiconjBy (unop a) (unop y) (unop x) ↔ SemiconjBy a x y := sorry run_meta guard (← simpComm.test ``unop_inj).isNone run_meta guard (← simpComm.test ``semiconj_by_unop).isNone end MulOpposite section def MyPred (_ : Nat → Nat) : Prop := True @[simp] theorem bad1 (f : Unit → Nat → Nat) : MyPred (f ()) ↔ True := by rw [MyPred] @[simp] theorem bad2 (f g : Nat → Nat) : MyPred (fun x => f (g x)) ↔ True := by rw [MyPred] -- Note, this is not a proper regression test because #671 depends on how the `MetaM` is -- executed, and `run_meta` sets the options appropriately. But setting the config -- explicitly here would amount to replicating the fix in the test itself. run_meta guard (← simpNF.test ``bad1).isNone run_meta guard (← simpNF.test ``bad2).isNone end ================================================ FILE: BatteriesTest/lintunused.lean ================================================ import Batteries.Tactic.Lint -- should be ignored as the proof contains sorry /-- warning: declaration uses `sorry` -/ #guard_msgs in theorem Foo (h : 1 = 1) : True := sorry #lint- only unusedArguments ================================================ FILE: BatteriesTest/list_enumeration.lean ================================================ import Batteries.Data.List.Perm open List #guard findIdxNth (· < 3) [5, 1, 3, 2, 4, 0, 1, 4] 2 == 5 #guard idxOfNth 1 [5, 1, 3, 2, 4, 0, 1, 4] 1 == 6 #guard countPBefore (· < 3) [5, 1, 3, 2, 4, 0, 1, 4] 5 == 2 #guard countBefore 1 [5, 1, 3, 2, 4, 0, 1, 4] 6 == 1 #guard (by decide : [1, 0, 1] <+~ [5, 0, 1, 3, 1]).idxInj 1 = 1 #guard (by decide : [0, 1, 1, 3, 5] ~ [5, 0, 1, 3, 1]).idxBij 2 == 4 ================================================ FILE: BatteriesTest/list_sublists.lean ================================================ import Batteries.Data.List.Basic -- this times out with `sublistsFast` set_option maxRecDepth 562 in example : [1, 2, 3].sublists.sublists.length = 256 := rfl ================================================ FILE: BatteriesTest/mersenne_twister.lean ================================================ import Batteries.Data.Random.MersenneTwister import Batteries.Data.Stream open Batteries.Random.MersenneTwister #guard (Std.Stream.take mt19937.init 5).1 == [874448474, 2424656266, 2174085406, 1265871120, 3155244894] /- Sample output was generated using `numpy`'s implementation of MT19937: ```python from numpy import array, uint32 from numpy.random import MT19937 mt = MT19937() mt.state = { 'bit_generator' : 'MT19937', 'state' : { 'pos' : 624, 'key' : array([ 4357, 1673174024, 1301878288, 1129097449, 2180885271, 2495295730, 3729202114, 3451529139, 2624228201, 696045212, 2296245684, 4097888573, 2110311931, 1672374534, 381896678, 2887874951, 3859861197, 420983856, 1691952728, 4233606289, 1707944415, 3515687962, 4265198858, 1433261659, 1131854641, 228846788, 3811811324, 873525989, 588291779, 2854617646, 948269870, 3798261295, 3422826645, 340138072, 3671734944, 3961007161, 2839350439, 3264455490, 310719058, 2570596611, 3750039289, 648992492, 3816674884, 2210726029, 371217291, 196912982, 3046892150, 470118103, 1302935133, 362465408, 1360220904, 2946174945, 1630294895, 3570642538, 1798333338, 1196832683, 226789057, 2740096276, 1062441100, 1875507765, 2599873619, 1037523070, 4029519294, 3231722367, 2232344613, 3458909352, 2906353456, 3064815497, 3166305847, 3658630546, 3632421090, 885320275, 1621369481, 1258557244, 2827734740, 3209486301, 131295515, 2191201702, 44141830, 1183978535, 4202966509, 801836240, 2303299448, 333191985, 4114943231, 1490315450, 453120554, 759253243, 1381163601, 3455606116, 1027445020, 1144697221, 3040135651, 4176273102, 798935118, 49817807, 2492997557, 3171983608, 2742334400, 1282687705, 1047297991, 3697219554, 1400278898, 3276297123, 843040281, 354711436, 4156544868, 2873126701, 3990490795, 3966874614, 1376536470, 4189022583, 2283386237, 3645931808, 1312021512, 679663233, 3054458511, 1152865034, 1927729338, 538380875, 374984161, 2453495220, 514433452, 1271601365, 3737270131, 630101278, 1292962526, 2908018207, 1209528133, 413117768, 3762161744, 2194986537, 1414304087, 379722290, 2862208514, 3551161587, 3402627497, 2411204572, 3033657332, 4161252989, 2267825211, 963150406, 2081690150, 4014304967, 1977732365, 2412979568, 613038232, 418857425, 3682807839, 3416550746, 3692470090, 2764012443, 3255912817, 2160692740, 3914318396, 3437441061, 2828481795, 3655629678, 582770030, 2946380655, 3506851541, 612362648, 3394202848, 1530337657, 3360830183, 570641538, 153365650, 1624454723, 80526649, 1365694508, 2272925828, 34250189, 3066169803, 631734422, 3706776758, 3443270679, 659846301, 3707435456, 3573851432, 1017208097, 1100519855, 1824765866, 3284762074, 2887949547, 569464065, 3057970772, 1726477004, 3119183733, 3349922451, 4162228670, 249085950, 3854319807, 1155219045, 811161064, 207675760, 50531529, 141911159, 3819613906, 2655884066, 3517624211, 514724041, 2094583932, 3681571092, 3518053661, 2207473499, 961982182, 1423628102, 628853095, 3823741997, 1450180112, 1817911736, 384378993, 1749521215, 4080873978, 2604100714, 2468900411, 1718743185, 3679944356, 623522652, 2974445253, 351789091, 776787982, 4087231118, 395771407, 2634989045, 2547249720, 2502583808, 3550523417, 648947207, 2361409826, 2639137202, 4179155171, 3136025689, 3233151180, 3765213604, 459508845, 412632299, 3365801270, 1208603094, 1978375863, 3608769469, 2648322656, 994422344, 1463198657, 1938300111, 1983437898, 3617090298, 582545291, 604707873, 615071476, 1976468460, 4251555349, 2373160371, 4138683998, 927249694, 4178996063, 3071856005, 3264724616, 2539911824, 1383596905, 3639900055, 2590770034, 1029541954, 369472051, 3757991913, 1470517532, 2317808180, 1065978813, 3301489275, 4087716742, 2662718566, 678716423, 274451277, 1625396912, 3598469848, 3639725841, 726808159, 1490990746, 4062476682, 2411471067, 1395972017, 1390554948, 1854727292, 2494590309, 1377225539, 2540041390, 3288614830, 706906287, 1416719637, 609008344, 2311429920, 821102265, 2034260263, 3587569090, 3115591378, 3545840515, 4166871929, 139581804, 2421643972, 1250638605, 4212965387, 2794805718, 3306616566, 2466109783, 2200482525, 1496197888, 381089640, 2743249505, 4221427695, 1247199466, 1746114586, 2065302059, 1348936513, 2997505940, 3911013644, 428274869, 2816055507, 580438782, 135588414, 916674047, 445684901, 1016784680, 654791600, 1282652681, 92916407, 1411782674, 1367985506, 1207661779, 3531669257, 627085756, 1857409876, 4107311709, 1384928667, 2576697382, 2875531654, 4151312039, 116927085, 1281879888, 414036984, 3931190705, 4100135295, 1170799418, 3130902186, 4055536507, 3692691153, 480878564, 2201474460, 3663014917, 4155766371, 1987039566, 4121861326, 2525025103, 2465094709, 2536129400, 1843468352, 2926058841, 533253191, 1988389474, 1209435122, 4141112867, 2699109017, 2373614092, 1694129124, 2730600877, 2249161515, 1355638390, 3319290902, 2209534967, 1463955965, 204923808, 1025015944, 214266113, 3382305551, 2455594378, 1861944634, 1820710091, 449145441, 4119339060, 2660525612, 3515028309, 3466454003, 1024657310, 50945886, 2913140895, 721595333, 3416444872, 2701847760, 2352361641, 234184151, 3927502002, 3834792578, 3469473651, 4193637929, 2873594460, 1994191988, 1690724605, 1956524219, 476427462, 212379302, 1370380615, 327076237, 1984104432, 682581272, 2521259089, 3543809183, 3275489242, 241390538, 3496199707, 2497799665, 770560132, 1626015420, 2776148645, 3717161347, 3970592238, 710750702, 3421625839, 876972885, 2108460056, 1195168096, 1195766777, 3121053543, 2819333890, 1916084498, 717897923, 3627489721, 1970264748, 1813355780, 4148615245, 556824139, 411448086, 4228776246, 1732939415, 3206934813, 1949588544, 3291105704, 1044314017, 222045743, 3079457322, 638497370, 1849452395, 921039233, 1115861204, 3019093836, 2828923381, 4185943827, 3344827454, 3923907710, 760572735, 3828284133, 1559197800, 724485616, 1828677449, 2985767159, 4119101778, 1077348258, 3518446099, 2585587017, 1855673084, 3495712148, 3265984413, 2998815707, 760668518, 2487249862, 3060757479, 3249514669, 4222804112, 1010910776, 3893641969, 395812799, 2591540346, 1194664170, 49789115, 1363873041, 1005502756, 1164343260, 3646613829, 459869347, 3679832718, 1137706766, 4189431951, 1412889205, 622040248, 1536739968, 3066727065, 666661511, 1672188834, 2714762802, 4135248739, 35606745, 2775710540, 4083752484, 3680159469, 1950331243, 251641782, 1501029974, 486869303, 1720971325, 241603808, 28070600, 2737782337, 910469455, 3810848458, 118398842, 3078470155, 2559096993, 2933522804, 2264615020, 3793195157, 1614887475, 45727966, 3193899422, 1157273055, 2178255365, 2646663432, 724754192, 168779241, 4048503831, 3483948530, 3996648642, 939343027, 917914729, 3030111132, 3908302516, 29247037, 3568084731, 1034472966, 1408004326, 1693666951, 3712665549, 3120003376, 3374542680, 2868373905, 1362838239, 1421625626, 4275252746, 548825947, 622261297, 3152835012, 2926192892, 423356389, 151058371, 3820087086, 1673993262, 252457775, 1317185941, 2594135384, 817169312, 2016796985, 2292688295, 1654933570, 2158435154, 2703640067, 3260663801, 3267419116, 2293555012, 2721936781, 1727868043, 91884630, 265685878, 1143096279, 961294173, 403541376, 2338233320, 1725318369, 4101205103, 4268086122, 3418016922, 1065995435, 1936572353, 265163284, 3043694988, 2167402293, 2057323859, 4033232254, 3258990270, 1137868927, 2142656805, 4216785320, 1188509744, 1051071625, 196974391, 2445666962, 3092595170, 2833121107, 2474761097, 2190021692, 1852037076, 3577763037, 3794354715, 2124118694, 2641147398, 1551493415, 1913661165, 1313919440, 2232801400, 1781682225, 1340417535, 994676154, 251493162, 2162155003, 1678056273, 3810976356, 1505106460, 3361449605, 1041703651, 1727972302, 3959583054, 3140845007, 3202914485, 2878334456, 2354150592, 3334993881, 1015617735, 506838242, 4168775794, 839674019, 4238769945, 849116300, 4189642852, 1596908589, 556328875, 2369067254, 2431152278, 1004682871], dtype=uint32)}} print(mt.random_raw(5)) ``` -/ ================================================ FILE: BatteriesTest/nondet.lean ================================================ import Batteries.Control.Nondet.Basic import Batteries.Lean.Meta.Basic set_option linter.missingDocs false open Lean Meta def M := StateT (List Nat) MetaM deriving instance AlternativeMonad for M instance : MonadBacktrack (List Nat) M where saveState := StateT.get restoreState := StateT.set def record (n : Nat) : M Unit := do discard <| restoreState (n :: (← saveState)) def iotaM [AlternativeMonad m] [MonadBacktrack σ m] (n : Nat) : Nondet m Nat := Nondet.ofList (List.range' 1 n).reverse /-- info: (52, []) -/ #guard_msgs in #eval show MetaM (Nat × List Nat) from StateT.run (iotaM 52 : Nondet M Nat).head [] /-- info: ((), [52]) -/ #guard_msgs in #eval show MetaM (Unit × List Nat) from StateT.run (((iotaM 52).mapM record).head) [] def x : Nondet M Nat := (iotaM 52).filterMapM fun x => do record x if x % 7 = 0 then return some (x^2) else return none /-- info: (2401, [49]) -/ #guard_msgs in #eval show MetaM (Nat × List Nat) from StateT.run x.head [] def divisors (n : Nat) : List Nat := List.range' 1 (n - 1) |>.reverse.filter fun m => n % m = 0 example : divisors 52 = [26, 13, 4, 2, 1] := rfl def divisorsM [Monad m] [MonadBacktrack σ m] (n : Nat) : Nondet m Nat := Nondet.ofList (divisors n) /-- Take the numbers `32, ..., 1`, replace each with their divisors, then replace again. -/ def y : Nondet M Nat := (iotaM 32) |>.bind fun x => do record x divisorsM x |>.bind fun x => do record x divisorsM x /-- info: [8, 4, 2, 1, 4, 2, 1, 2, 1, 1, 5, 3, 1, 5, 2, 1, 3, 2, 1, 1, 1, 1, 7] -/ #guard_msgs in #eval show MetaM (List Nat) from StateT.run' (y.toMLList'.takeAsList 23) [] -- All ways to find `4 ∣ a ∣ b`, with `b = 32, ..., 1`. /-- info: ([(4, [16, 32]), (4, [8, 32]), (4, [12, 24]), (4, [8, 24]), (4, [8, 16])], [1]) -/ #guard_msgs in #eval show MetaM (List (Nat × List Nat) × List Nat) from StateT.run (y.filter (· = 4)).toMLList.force [] /-- info: [15, 14, 13, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1] -/ #guard_msgs in #eval (iotaM 15 : Nondet MetaM Nat).toList' -- Depth first search of the divisors of 255. /-- info: [255, 85, 17, 1, 5, 1, 1, 51, 17, 1, 3, 1, 1, 17, 1, 15, 5, 1, 3, 1, 1, 5, 1, 3, 1, 1] -/ #guard_msgs in #eval (Nondet.iterate divisorsM 255 : Nondet Id Nat).toList' ================================================ FILE: BatteriesTest/norm_cast.lean ================================================ /-! # Tests for norm_cast involving `Rat`. -/ set_option linter.missingDocs false -- set_option trace.Meta.Tactic.simp true variable (aq bq cq dq : Rat) example : az = bz ↔ (az : Rat) = bz := by norm_cast -- zero and one cause special problems example : aq < (1 : Nat) ↔ (aq : Rat) < (1 : Int) := by norm_cast --testing numerals example : ((42 : Nat) : Rat) = 42 := by norm_cast example : ((42 : Int) : Rat) = 42 := by norm_cast -- We don't yet have `{n m : Int} : (↑n : Rat) ≤ ↑m ↔ n ≤ m` in Batteries -- example (n : Int) (h : n + 1 > 0) : ((n + 1 : Int) : Rat) > 0 := by exact_mod_cast h ================================================ FILE: BatteriesTest/omega/benchmark.lean ================================================ /-! # Benchmarking the `omega` tactic As it's important that `omega` is fast, particularly when it has nothing to do, this file maintains a benchmark suite for `omega`. It is particularly low-tech, and currently only reproducible on Kim Morrison's FRO machine; nevertheless it seems useful to keep the benchmark history in the repository. The benchmark file consists of the test suite from `omega`'s initial release, with one test removed (in which a test-for-failure succeeds with today's `omega`). The benchmark consists of `lake build && hyperfine "lake env lean test/omega/benchmark.lean"` run on a freshly rebooted machine! 2024-02-06 feat: omega uses Lean.HashMap instead of Std.Data.HashMap (#588) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.530 s ± 0.008 s [User: 2.249 s, System: 0.276 s] Range (min … max): 2.513 s … 2.542 s 10 runs 2024-02-03 feat: omega handles min, max, if (#575) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.526 s ± 0.009 s [User: 2.250 s, System: 0.272 s] Range (min … max): 2.513 s … 2.542 s 10 runs 2024-02-02 fix: revert OmegaM state when not multiplying out (#570) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.569 s ± 0.004 s [User: 2.291 s, System: 0.273 s] Range (min … max): 2.563 s … 2.574 s 10 runs 2024-01-12 feat: omega handles double negation and implication hypotheses (#522) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.575 s ± 0.004 s [User: 2.302 s, System: 0.268 s] Range (min … max): 2.570 s … 2.581 s 10 runs 2024-01-10 feat: omega understands Prod.Lex (#511) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.567 s ± 0.006 s [User: 2.295 s, System: 0.268 s] Range (min … max): 2.559 s … 2.576 s 10 runs 2024-01-10 feat: omega handles iff and implications (#503) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.348 s ± 0.007 s [User: 2.060 s, System: 0.282 s] Range (min … max): 2.335 s … 2.356 s 10 runs 2023-12-21 feat: omega (#463) kim@carica std4 % lake build && hyperfine "lake env lean test/omega/benchmark.lean" Benchmark 1: lake env lean test/omega/benchmark.lean Time (mean ± σ): 2.362 s ± 0.008 s [User: 2.080 s, System: 0.277 s] Range (min … max): 2.349 s … 2.372 s 10 runs -/ example : True := by fail_if_success omega trivial -- set_option trace.omega true example (_ : (1 : Int) < (0 : Int)) : False := by omega example (_ : (0 : Int) < (0 : Int)) : False := by omega example (_ : (0 : Int) < (1 : Int)) : True := by (fail_if_success omega); trivial example {x : Int} (_ : 0 ≤ x) (_ : x ≤ 1) : True := by (fail_if_success omega); trivial example {x : Int} (_ : 0 ≤ x) (_ : x ≤ -1) : False := by omega example {x : Int} (_ : x % 2 < x - 2 * (x / 2)) : False := by omega example {x : Int} (_ : x % 2 > 5) : False := by omega example {x : Int} (_ : 2 * (x / 2) > x) : False := by omega example {x : Int} (_ : 2 * (x / 2) ≤ x - 2) : False := by omega example {x : Nat} : x / 0 = 0 := by omega example {x : Int} : x / 0 = 0 := by omega example {x : Int} : x / 2 + x / (-2) = 0 := by omega example (_ : 7 < 3) : False := by omega example (_ : 0 < 0) : False := by omega example {x : Nat} (_ : x > 7) (_ : x < 3) : False := by omega example {x : Nat} (_ : x ≥ 7) (_ : x ≤ 3) : False := by omega example {x y : Nat} (_ : x + y > 10) (_ : x < 5) (_ : y < 5) : False := by omega example {x y : Int} (_ : x + y > 10) (_ : 2 * x < 11) (_ : y < 5) : False := by omega example {x y : Nat} (_ : x + y > 10) (_ : 2 * x < 11) (_ : y < 5) : False := by omega example {x y : Int} (_ : 2 * x + 4 * y = 5) : False := by omega example {x y : Nat} (_ : 2 * x + 4 * y = 5) : False := by omega example {x y : Int} (_ : 6 * x + 7 * y = 5) : True := by (fail_if_success omega); trivial example {x y : Nat} (_ : 6 * x + 7 * y = 5) : False := by omega example {x : Nat} (_ : x < 0) : False := by omega example {x y z : Int} (_ : x + y > z) (_ : x < 0) (_ : y < 0) (_ : z > 0) : False := by omega example {x y : Nat} (_ : x - y = 0) (_ : x > y) : False := by fail_if_success omega (config := { splitNatSub := false }) omega example {x y z : Int} (_ : x - y - z = 0) (_ : x > y + z) : False := by omega example {x y z : Nat} (_ : x - y - z = 0) (_ : x > y + z) : False := by omega example {a b c d e f : Nat} (_ : a - b - c - d - e - f = 0) (_ : a > b + c + d + e + f) : False := by omega example {x y : Nat} (h₁ : x - y ≤ 0) (h₂ : y < x) : False := by omega example {x y : Int} (_ : x / 2 - y / 3 < 1) (_ : 3 * x ≥ 2 * y + 6) : False := by omega example {x y : Nat} (_ : x / 2 - y / 3 < 1) (_ : 3 * x ≥ 2 * y + 6) : False := by omega example {x y : Nat} (_ : x / 2 - y / 3 < 1) (_ : 3 * x ≥ 2 * y + 4) : False := by omega example {x y : Nat} (_ : x / 2 - y / 3 < x % 2) (_ : 3 * x ≥ 2 * y + 4) : False := by omega example {x : Int} (h₁ : 5 ≤ x) (h₂ : x ≤ 4) : False := by omega example {x : Nat} (h₁ : 5 ≤ x) (h₂ : x ≤ 4) : False := by omega example {x : Nat} (h₁ : x / 3 ≥ 2) (h₂ : x < 6) : False := by omega example {x : Int} {y : Nat} (_ : 0 < x) (_ : x + y ≤ 0) : False := by omega example {a b c : Nat} (_ : a - (b - c) ≤ 5) (_ : b ≥ c + 3) (_ : a + c ≥ b + 6) : False := by omega example {x : Nat} : 1 < (1 + ((x + 1 : Nat) : Int) + 2) / 2 := by omega example {x : Nat} : (x + 4) / 2 ≤ x + 2 := by omega example {x : Int} {m : Nat} (_ : 0 < m) (_ : ¬x % ↑m < (↑m + 1) / 2) : -↑m / 2 ≤ x % ↑m - ↑m := by omega example (h : (7 : Int) = 0) : False := by omega example (h : (7 : Int) ≤ 0) : False := by omega example (h : (-7 : Int) + 14 = 0) : False := by omega example (h : (-7 : Int) + 14 ≤ 0) : False := by omega example (h : (1 : Int) + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 = 0) : False := by omega example (h : (7 : Int) - 14 = 0) : False := by omega example (h : (14 : Int) - 7 ≤ 0) : False := by omega example (h : (1 : Int) - 1 + 1 - 1 + 1 - 1 + 1 - 1 + 1 - 1 + 1 - 1 + 1 - 1 + 1 = 0) : False := by omega example (h : -(7 : Int) = 0) : False := by omega example (h : -(-7 : Int) ≤ 0) : False := by omega example (h : 2 * (7 : Int) = 0) : False := by omega example (h : (7 : Int) < 0) : False := by omega example {x : Int} (h : x + x + 1 = 0) : False := by omega example {x : Int} (h : 2 * x + 1 = 0) : False := by omega example {x y : Int} (h : x + x + y + y + 1 = 0) : False := by omega example {x y : Int} (h : 2 * x + 2 * y + 1 = 0) : False := by omega example {x : Int} (h₁ : 0 ≤ -7 + x) (h₂ : 0 ≤ 3 - x) : False := by omega example {x : Int} (h₁ : 0 ≤ -7 + x) (h₂ : 0 < 4 - x) : False := by omega example {x : Int} (h₁ : 0 ≤ 2 * x + 1) (h₂ : 2 * x + 1 ≤ 0) : False := by omega example {x : Int} (h₁ : 0 < 2 * x + 2) (h₂ : 2 * x + 1 ≤ 0) : False := by omega example {x y : Int} (h₁ : 0 ≤ 2 * x + 1) (h₂ : x = y) (h₃ : 2 * y + 1 ≤ 0) : False := by omega example {x y z : Int} (h₁ : 0 ≤ 2 * x + 1) (h₂ : x = y) (h₃ : y = z) (h₄ : 2 * z + 1 ≤ 0) : False := by omega example {x1 x2 x3 x4 x5 x6 : Int} (h : 0 ≤ 2 * x1 + 1) (h : x1 = x2) (h : x2 = x3) (h : x3 = x4) (h : x4 = x5) (h : x5 = x6) (h : 2 * x6 + 1 ≤ 0) : False := by omega example {x : Int} (_ : 1 ≤ -3 * x) (_ : 1 ≤ 2 * x) : False := by omega example {x y : Int} (_ : 2 * x + 3 * y = 0) (_ : 1 ≤ x) (_ : 1 ≤ y) : False := by omega example {x y z : Int} (_ : 2 * x + 3 * y = 0) (_ : 3 * y + 4 * z = 0) (_ : 1 ≤ x) (_ : 1 ≤ -z) : False := by omega example {x y z : Int} (_ : 2 * x + 3 * y + 4 * z = 0) (_ : 1 ≤ x + y) (_ : 1 ≤ y + z) (_ : 1 ≤ x + z) : False := by omega example {x y : Int} (_ : 1 ≤ 3 * x) (_ : y ≤ 2) (_ : 6 * x - 2 ≤ y) : False := by omega example {x y : Int} (_ : y = x) (_ : 0 ≤ x - 2 * y) (_ : x - 2 * y ≤ 1) (_ : 1 ≤ x) : False := by omega example {x y : Int} (_ : y = x) (_ : 0 ≤ x - 2 * y) (_ : x - 2 * y ≤ 1) (_ : x ≥ 1) : False := by omega example {x y : Int} (_ : y = x) (_ : 0 ≤ x - 2 * y) (_ : x - 2 * y ≤ 1) (_ : 0 < x) : False := by omega example {x y : Int} (_ : y = x) (_ : 0 ≤ x - 2 * y) (_ : x - 2 * y ≤ 1) (_ : x > 0) : False := by omega example {x : Nat} (_ : 10 ∣ x) (_ : ¬ 5 ∣ x) : False := by omega example {x y : Nat} (_ : 5 ∣ x) (_ : ¬ 10 ∣ x) (_ : y = 7) (_ : x - y ≤ 2) (_ : x ≥ 6) : False := by omega example (x : Nat) : x % 4 - x % 8 = 0 := by omega example {n : Nat} (_ : n > 0) : (2*n - 1) % 2 = 1 := by omega example (x : Int) (_ : x > 0 ∧ x < -1) : False := by omega example (x : Int) (_ : x > 7) : x < 0 ∨ x > 3 := by omega example (_ : ∃ n : Nat, n < 0) : False := by omega example (_ : { x : Int // x < 0 ∧ x > 0 }) : False := by omega example {x y : Int} (_ : x < y) (z : { z : Int // y ≤ z ∧ z ≤ x }) : False := by omega example (a b c d e : Int) (ha : 2 * a + b + c + d + e = 4) (hb : a + 2 * b + c + d + e = 5) (hc : a + b + 2 * c + d + e = 6) (hd : a + b + c + 2 * d + e = 7) (he : a + b + c + d + 2 * e = 8) : e = 3 := by omega example (a b c d e : Int) (ha : 2 * a + b + c + d + e = 4) (hb : a + 2 * b + c + d + e = 5) (hc : a + b + 2 * c + d + e = 6) (hd : a + b + c + 2 * d + e = 7) (he : a + b + c + d + 2 * e = 8 ∨ e = 3) : e = 3 := by fail_if_success omega (config := { splitDisjunctions := false }) omega example {a b : Int} (h : a < b) (w : b < a) : False := by omega example (_e b c a v0 v1 : Int) (_h1 : v0 = 5 * a) (_h2 : v1 = 3 * b) (h3 : v0 + v1 + c = 10) : v0 + 5 + (v1 - 3) + (c - 2) = 10 := by omega example (h : (1 : Int) < 0) (_ : ¬ (37 : Int) < 42) (_ : True) (_ : (-7 : Int) < 5) : (3 : Int) < 7 := by omega example (A B : Int) (h : 0 < A * B) : 0 < 8 * (A * B) := by omega example (A B : Nat) (h : 7 < A * B) : 0 < A*B/8 := by omega example (A B : Int) (h : 7 < A * B) : 0 < A*B/8 := by omega example (ε : Int) (h1 : ε > 0) : ε / 2 + ε / 3 + ε / 7 < ε := by omega example (x y z : Int) (h1 : 2*x < 3*y) (h2 : -4*x + z/2 < 0) (h3 : 12*y - z < 0) : False := by omega example (ε : Int) (h1 : ε > 0) : ε / 2 < ε := by omega example (ε : Int) (_ : ε > 0) : ε - 2 ≤ ε / 3 + ε / 3 + ε / 3 := by omega example (ε : Int) (_ : ε > 0) : ε / 3 + ε / 3 + ε / 3 ≤ ε := by omega example (ε : Int) (_ : ε > 0) : ε - 2 ≤ ε / 3 + ε / 3 + ε / 3 ∧ ε / 3 + ε / 3 + ε / 3 ≤ ε := by omega example (x : Int) (h : 0 < x) : 0 < x / 1 := by omega example (x : Int) (h : 5 < x) : 0 < x/2/3 := by omega example (_a b _c : Nat) (h2 : b + 2 > 3 + b) : False := by omega example (_a b _c : Int) (h2 : b + 2 > 3 + b) : False := by omega example (g v V c h : Int) (_ : h = 0) (_ : v = V) (_ : V > 0) (_ : g > 0) (_ : 0 ≤ c) (_ : c < 1) : v ≤ V := by omega example (x y z : Int) (h1 : 2 * x < 3 * y) (h2 : -4 * x + 2 * z < 0) (h3 : 12 * y - 4 * z < 0) : False := by omega example (x y z : Int) (h1 : 2 * x < 3 * y) (h2 : -4 * x + 2 * z < 0) (_h3 : x * y < 5) (h3 : 12 * y - 4 * z < 0) : False := by omega example (a b c : Int) (h1 : a > 0) (h2 : b > 5) (h3 : c < -10) (h4 : a + b - c < 3) : False := by omega example (_ b _ : Int) (h2 : b > 0) (h3 : ¬ b ≥ 0) : False := by omega example (x y z : Int) (hx : x ≤ 3 * y) (h2 : y ≤ 2 * z) (h3 : x ≥ 6 * z) : x = 3 * y := by omega example (x y z : Int) (h1 : 2 * x < 3 * y) (h2 : -4 * x + 2 * z < 0) (_h3 : x * y < 5) : ¬ 12 * y - 4 * z < 0 := by omega example (x y z : Int) (hx : ¬ x > 3 * y) (h2 : ¬ y > 2 * z) (h3 : x ≥ 6 * z) : x = 3 * y := by omega example (x y : Int) (h : 6 + ((x + 4) * x + (6 + 3 * y) * y) = 3) (h' : (x + 4) * x ≥ 0) (h'' : (6 + 3 * y) * y ≥ 0) : False := by omega example (a : Int) (ha : 0 ≤ a) : 0 * 0 ≤ 2 * a := by omega example (x y : Int) (h : x < y) : x ≠ y := by omega example (x y : Int) (h : x < y) : ¬ x = y := by omega example (prime : Nat → Prop) (x y z : Int) (h1 : 2 * x + ((-3) * y) < 0) (h2 : (-4) * x + 2* z < 0) (h3 : 12 * y + (-4) * z < 0) (_ : prime 7) : False := by omega example (i n : Nat) (h : (2 : Int) ^ i ≤ 2 ^ n) : (0 : Int) ≤ 2 ^ n - 2 ^ i := by omega -- Check we use `exfalso` on non-comparison goals. example (prime : Nat → Prop) (_ b _ : Nat) (h2 : b > 0) (h3 : b < 0) : prime 10 := by omega example (a b c : Nat) (h2 : (2 : Nat) > 3) : a + b - c ≥ 3 := by omega -- Verify that we split conjunctions in hypotheses. example (x y : Int) (h : 6 + ((x + 4) * x + (6 + 3 * y) * y) = 3 ∧ (x + 4) * x ≥ 0 ∧ (6 + 3 * y) * y ≥ 0) : False := by omega example (mess : Nat → Nat) (S n : Nat) : mess S + (n * mess S + n * 2 + 1) < n * mess S + mess S + (n * 2 + 2) := by omega example (p n p' n' : Nat) (h : p + n' = p' + n) : n + p' = n' + p := by omega example (a b c : Int) (h1 : 32 / a < b) (h2 : b < c) : 32 / a < c := by omega ================================================ FILE: BatteriesTest/on_goal.lean ================================================ import Batteries.Tactic.PermuteGoals import Batteries.Tactic.Unreachable example (p q r : Prop) : p → q → r → p ∧ q ∧ r := by intros constructor on_goal 2 => guard_target = q ∧ r constructor assumption -- Note that we have not closed all the subgoals here. guard_target = p assumption guard_target = r assumption example (p q r : Prop) : p → q → r → p ∧ q ∧ r := by intros a b c constructor fail_if_success on_goal -3 => unreachable! fail_if_success on_goal -1 => exact a fail_if_success on_goal 0 => unreachable! fail_if_success on_goal 2 => exact a fail_if_success on_goal 3 => unreachable! on_goal 1 => exact a constructor swap exact c exact b example (p q : Prop) : p → q → p ∧ q := by intros a b constructor fail_if_success pick_goal -3 fail_if_success pick_goal 0 fail_if_success pick_goal 3 pick_goal -1 exact b exact a example (p : Prop) : p → p := by intros fail_if_success swap -- can't swap with a single goal assumption ================================================ FILE: BatteriesTest/openPrivate.lean ================================================ import Batteries.Tactic.OpenPrivate import BatteriesTest.OpenPrivateDefs /-- error: Unknown identifier `secretNumber` -/ #guard_msgs in #eval secretNumber -- It works with one space between the tokens /-- info: 2 -/ #guard_msgs in open private secretNumber from BatteriesTest.OpenPrivateDefs in #eval secretNumber -- It also works with other kinds of whitespace between the tokens /-- info: 2 -/ #guard_msgs in open private secretNumber from BatteriesTest.OpenPrivateDefs in #eval secretNumber /-- info: 2 -/ #guard_msgs in open private secretNumber from BatteriesTest.OpenPrivateDefs in #eval secretNumber /-- info: 2 -/ #guard_msgs in open /- Being sneaky! -/ private secretNumber from BatteriesTest.OpenPrivateDefs in #eval secretNumber /-- info: @[defeq] private theorem secretNumber.eq_def : secretNumber✝ = 2 := Eq.refl secretNumber✝ -/ #guard_msgs in open private secretNumber.eq_def from BatteriesTest.OpenPrivateDefs in #print secretNumber.eq_def ================================================ FILE: BatteriesTest/print_opaques.lean ================================================ import Batteries.Tactic.PrintOpaques partial def foo : Unit → Nat := foo def bar : Unit → Nat := foo /-- info: 'bar' depends on opaque or partial definitions: [foo] -/ #guard_msgs in #print opaques bar opaque qux : Nat def quux : Bool := qux == 0 /-- info: 'quux' depends on opaque or partial definitions: [qux] -/ #guard_msgs in #print opaques quux /-! Examples from the documentation. -/ /-- info: 'Classical.choice' depends on opaque or partial definitions: [Classical.choice] -/ #guard_msgs in #print opaques Classical.choice /-- info: 'Classical.axiomOfChoice' does not use any opaque or partial definitions -/ #guard_msgs in #print opaques Classical.axiomOfChoice /-- info: 'Std.HashMap.insert' depends on opaque or partial definitions: [System.Platform.getNumBits] -/ #guard_msgs in #print opaques Std.HashMap.insert /-- info: 'Std.Stream.forIn' depends on opaque or partial definitions: [_private.Init.Data.Stream.0.Std.Stream.forIn.visit] -/ #guard_msgs in #print opaques Std.Stream.forIn ================================================ FILE: BatteriesTest/print_prefix.lean ================================================ import Batteries.Tactic.PrintPrefix inductive TEmpty : Type /-- info: TEmpty : Type TEmpty.casesOn.{u} (motive : TEmpty → Sort u) (t : TEmpty) : motive t TEmpty.ctorIdx : TEmpty → Nat TEmpty.noConfusion.{u} {P : Sort u} {t t' : TEmpty} (eq : t = t') : TEmpty.noConfusionType P t t' TEmpty.noConfusionType.{u} (P : Sort u) (t t' : TEmpty) : Sort u TEmpty.rec.{u} (motive : TEmpty → Sort u) (t : TEmpty) : motive t TEmpty.recOn.{u} (motive : TEmpty → Sort u) (t : TEmpty) : motive t -/ #guard_msgs in #print prefix TEmpty -- Test type that probably won't change much. /-- info: -/ #guard_msgs in #print prefix -imported Empty namespace EmptyPrefixTest end EmptyPrefixTest -- Note. This error message could be cleaned up, but left during migration from Mathlib /-- error: Unknown constant `EmptyPrefixTest` -/ #guard_msgs in #print prefix EmptyPrefixTest namespace Prefix.Test /-- Supress lint -/ def foo (_l:List String) : Int := 0 end Prefix.Test /-- info: Prefix.Test.foo (_l : List String) : Int -/ #guard_msgs in #print prefix Prefix.Test /-- Supress lint -/ structure TestStruct where /-- Supress lint -/ foo : Int /-- Supress lint -/ bar : Int /-- info: TestStruct : Type TestStruct.bar (self : TestStruct) : Int TestStruct.casesOn.{u} {motive : TestStruct → Sort u} (t : TestStruct) (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) : motive t TestStruct.ctorIdx : TestStruct → Nat TestStruct.foo (self : TestStruct) : Int TestStruct.mk (foo bar : Int) : TestStruct TestStruct.mk.inj {foo bar foo✝ bar✝ : Int} : { foo := foo, bar := bar } = { foo := foo✝, bar := bar✝ } → foo = foo✝ ∧ bar = bar✝ TestStruct.mk.injEq (foo bar foo✝ bar✝ : Int) : ({ foo := foo, bar := bar } = { foo := foo✝, bar := bar✝ }) = (foo = foo✝ ∧ bar = bar✝) TestStruct.mk.noConfusion.{u} {P : Sort u} {foo bar foo' bar' : Int} (eq : { foo := foo, bar := bar } = { foo := foo', bar := bar' }) (k : foo = foo' → bar = bar' → P) : P TestStruct.mk.sizeOf_spec (foo bar : Int) : sizeOf { foo := foo, bar := bar } = 1 + sizeOf foo + sizeOf bar TestStruct.noConfusion.{u} {P : Sort u} {t t' : TestStruct} (eq : t = t') : TestStruct.noConfusionType P t t' TestStruct.noConfusionType.{u} (P : Sort u) (t t' : TestStruct) : Sort u TestStruct.rec.{u} {motive : TestStruct → Sort u} (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) (t : TestStruct) : motive t TestStruct.recOn.{u} {motive : TestStruct → Sort u} (t : TestStruct) (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) : motive t -/ #guard_msgs in #print prefix TestStruct /-- info: TestStruct : Type TestStruct.bar (self : TestStruct) : Int TestStruct.casesOn.{u} {motive : TestStruct → Sort u} (t : TestStruct) (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) : motive t TestStruct.ctorIdx : TestStruct → Nat TestStruct.foo (self : TestStruct) : Int TestStruct.mk (foo bar : Int) : TestStruct TestStruct.mk.noConfusion.{u} {P : Sort u} {foo bar foo' bar' : Int} (eq : { foo := foo, bar := bar } = { foo := foo', bar := bar' }) (k : foo = foo' → bar = bar' → P) : P TestStruct.noConfusion.{u} {P : Sort u} {t t' : TestStruct} (eq : t = t') : TestStruct.noConfusionType P t t' TestStruct.noConfusionType.{u} (P : Sort u) (t t' : TestStruct) : Sort u TestStruct.rec.{u} {motive : TestStruct → Sort u} (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) (t : TestStruct) : motive t TestStruct.recOn.{u} {motive : TestStruct → Sort u} (t : TestStruct) (mk : (foo bar : Int) → motive { foo := foo, bar := bar }) : motive t -/ #guard_msgs in #print prefix -propositions TestStruct /-- info: TestStruct.mk.inj {foo bar foo✝ bar✝ : Int} : { foo := foo, bar := bar } = { foo := foo✝, bar := bar✝ } → foo = foo✝ ∧ bar = bar✝ TestStruct.mk.injEq (foo bar foo✝ bar✝ : Int) : ({ foo := foo, bar := bar } = { foo := foo✝, bar := bar✝ }) = (foo = foo✝ ∧ bar = bar✝) TestStruct.mk.sizeOf_spec (foo bar : Int) : sizeOf { foo := foo, bar := bar } = 1 + sizeOf foo + sizeOf bar -/ #guard_msgs in #print prefix +propositionsOnly TestStruct /-- info: TestStruct TestStruct.bar TestStruct.casesOn TestStruct.ctorIdx TestStruct.foo TestStruct.mk TestStruct.mk.inj TestStruct.mk.injEq TestStruct.mk.noConfusion TestStruct.mk.sizeOf_spec TestStruct.noConfusion TestStruct.noConfusionType TestStruct.rec TestStruct.recOn -/ #guard_msgs in #print prefix -showTypes TestStruct /-- Artificial test function to show #print prefix filters out internals including match_/proof_. Note. Internal names are inherently subject to change. This test case may fail regularly when the Lean version is changed. If so, we should disable the test case using this function below until a more robust solution is found. -/ def testMatchProof : (n : Nat) → Fin n → Unit | _, ⟨0, _⟩ => () | Nat.succ as, ⟨Nat.succ i, h⟩ => testMatchProof as ⟨i, Nat.le_of_succ_le_succ h⟩ /-- info: testMatchProof (n : Nat) : Fin n → Unit -/ #guard_msgs in #print prefix testMatchProof /-- info: testMatchProof (n : Nat) : Fin n → Unit testMatchProof._f (x✝ : Nat) (f : Nat.below (motive := fun x => Fin x → Unit) x✝) : Fin x✝ → Unit testMatchProof._proof_1 (as i : Nat) (h : i.succ < as.succ) : i.succ ≤ as testMatchProof._sunfold (n : Nat) : Fin n → Unit testMatchProof._unsafe_rec (n : Nat) : Fin n → Unit testMatchProof.match_1.{u_1} (motive : (x : Nat) → Fin x → Sort u_1) (x✝ : Nat) (x✝¹ : Fin x✝) (h_1 : (n : Nat) → (isLt : 0 < n) → motive n ⟨0, isLt⟩) (h_2 : (as i : Nat) → (h : i.succ < as.succ) → motive as.succ ⟨i.succ, h⟩) : motive x✝ x✝¹ -/ #guard_msgs in #print prefix +internals testMatchProof private inductive TestInd where | foo : TestInd | bar : TestInd /-- info: TestInd : Type TestInd.bar : TestInd TestInd.bar.elim.{u} {motive : TestInd → Sort u} (t : TestInd) (h : t.ctorIdx = 1) (bar : motive TestInd.bar) : motive t TestInd.bar.sizeOf_spec : sizeOf TestInd.bar = 1 TestInd.casesOn.{u} {motive : TestInd → Sort u} (t : TestInd) (foo : motive TestInd.foo) (bar : motive TestInd.bar) : motive t TestInd.ctorElim.{u} {motive : TestInd → Sort u} (ctorIdx : Nat) (t : TestInd) (h : ctorIdx = t.ctorIdx) (k : TestInd.ctorElimType ctorIdx) : motive t TestInd.ctorElimType.{u} {motive : TestInd → Sort u} (ctorIdx : Nat) : Sort (max 1 u) TestInd.ctorIdx : TestInd → Nat TestInd.foo : TestInd TestInd.foo.elim.{u} {motive : TestInd → Sort u} (t : TestInd) (h : t.ctorIdx = 0) (foo : motive TestInd.foo) : motive t TestInd.foo.sizeOf_spec : sizeOf TestInd.foo = 1 TestInd.noConfusion.{v✝} {P : Sort v✝} {x y : TestInd} (h : x = y) : TestInd.noConfusionType P x y TestInd.noConfusionType.{v✝} (P : Sort v✝) (x y : TestInd) : Sort v✝ TestInd.rec.{u} {motive : TestInd → Sort u} (foo : motive TestInd.foo) (bar : motive TestInd.bar) (t : TestInd) : motive t TestInd.recOn.{u} {motive : TestInd → Sort u} (t : TestInd) (foo : motive TestInd.foo) (bar : motive TestInd.bar) : motive t TestInd.toCtorIdx : TestInd → Nat -/ #guard_msgs in #print prefix TestInd -- `#print prefix` does nothing if no identifier is provided #guard_msgs in #print prefix ================================================ FILE: BatteriesTest/proof_wanted.lean ================================================ import Batteries.Util.ProofWanted /-! No unused variable warnings. -/ #guard_msgs in proof_wanted foo (x : Nat) : True /-! When not a proposition, rely on `theorem` command failing. -/ /-- error: type of theorem `foo` is not a proposition Nat → Nat -/ #guard_msgs in proof_wanted foo (x : Nat) : Nat ================================================ FILE: BatteriesTest/register_label_attr.lean ================================================ import BatteriesTest.Internal.DummyLabelAttr import Lean.LabelAttribute set_option linter.missingDocs false open Lean def f := 0 /-- info: #[] -/ #guard_msgs in #eval labelled `dummy_label_attr attribute [dummy_label_attr] f /-- info: #[`f] -/ #guard_msgs in #eval labelled `dummy_label_attr section attribute [-dummy_label_attr] f /-- info: #[] -/ #guard_msgs in #eval labelled `dummy_label_attr end /-- info: #[`f] -/ #guard_msgs in #eval labelled `dummy_label_attr -- Adding the label again is a no-op attribute [dummy_label_attr] f /-- info: #[`f] -/ #guard_msgs in #eval labelled `dummy_label_attr ================================================ FILE: BatteriesTest/rfl.lean ================================================ import Lean.Elab.Tactic.Rfl -- Adaptation note: we should be able to remove this import after nightly-2024-03-19 set_option linter.missingDocs false example (a : Nat) : a = a := rfl example (a : Nat) : a = a := by rfl open Setoid universe u variable {α : Sort u} [Setoid α] @[refl] def iseqv_refl (a : α) : a ≈ a := iseqv.refl a example (a : α) : a ≈ a := by rfl example (a : Nat) : a ≤ a := by (fail_if_success rfl); apply Nat.le_refl attribute [refl] Nat.le_refl example (a : Nat) : a ≤ a := by rfl structure Foo def Foo.le (_ _ : Foo) := Unit → True instance : LE Foo := ⟨Foo.le⟩ @[refl] theorem Foo.le_refl (a : Foo) : a ≤ a := fun _ => trivial example (a : Foo) : a ≤ a := by apply Foo.le_refl example (a : Foo) : a ≤ a := by rfl example (x : Nat) : x ≤ x := by show _ rfl ================================================ FILE: BatteriesTest/satisfying.lean ================================================ import Batteries.Lean.SatisfiesM import Batteries.Data.Array.Monadic open Lean Meta Array Elab Term Tactic Command -- Note: as of nightly-2025-10-23, after https://github.com/leanprover/lean4/pull/10625 -- the `MonadSatisfying` instances for the core monad stack need to be re-implemented. -- See `Batteries.Lean.LawfulMonad` first. -- example (xs : Array Expr) : MetaM { ts : Array Expr // ts.size = xs.size } := do -- let r ← satisfying (xs.size_mapM inferType) -- return r ================================================ FILE: BatteriesTest/seq_focus.lean ================================================ import Batteries.Tactic.SeqFocus example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by constructor constructor -- error: too many tactics fail_if_success map_tacs [trivial; exact ⟨0, rfl⟩; trivial; trivial] -- error: not enough tactics fail_if_success map_tacs [trivial; exact ⟨0, rfl⟩] map_tacs [trivial; exact ⟨0, rfl⟩; trivial] example : ((True ∧ True) ∧ (∃ x : Nat, x = x)) ∧ (True ∧ (∃ x : Nat, x = x)) := by constructor constructor map_tacs [(constructor; trivial); exact ⟨0, rfl⟩; constructor] trivial trivial exact ⟨0, rfl⟩ example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by constructor -- error: not enough tactics fail_if_success constructor <;> [trivial] map_tacs [constructor <;> [trivial; exact ⟨0, rfl⟩]; constructor] ================================================ FILE: BatteriesTest/show_term.lean ================================================ /- Copyright (c) 2021 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ /-- info: Try this: [apply] exact (n, 37) -/ #guard_msgs in example (n : Nat) : Nat × Nat := by show_term constructor exact n exact 37 /-- info: Try this: [apply] refine (?_, ?_) -/ #guard_msgs in example : Nat × Nat := by show_term constructor repeat exact 42 /-- info: Try this: [apply] fun {X} => X -/ #guard_msgs in example : {_a : Nat} → Nat := show_term by intro X exact X ================================================ FILE: BatteriesTest/show_unused.lean ================================================ import Batteries.Tactic.ShowUnused def foo := 1 def baz := 2 def bar := foo /-- warning: #show_unused (line 14) says: baz is not used transitively by [bar] --- warning: unused definitions in this file: baz -/ #guard_msgs in #show_unused bar ================================================ FILE: BatteriesTest/simp_trace.lean ================================================ import Batteries.Tactic.SqueezeScope -- undo changes to simp set after test was written attribute [-simp] Nat.add_left_cancel_iff Nat.add_right_cancel_iff set_option linter.missingDocs false /-- info: Try this: [apply] simp only [Nat.add_comm] -/ #guard_msgs in example : x + 1 = 1 + x := by simp? [Nat.add_comm, Nat.mul_comm] /-- info: Try this: [apply] dsimp only [Nat.reduceAdd] -/ #guard_msgs in example : 1 + 1 = 2 := by dsimp? -- Helper definitions for squeeze_scope tests @[simp] def bar (z : Nat) := 1 + z @[simp] def baz (z : Nat) := 1 + z @[simp] def foo : Nat → Nat → Nat | 0, z => bar z | _+1, z => baz z @[simp] def qux : Bool → Nat → Nat | true, z => bar z | false, z => baz z def myId (x : Nat) := x def myId2 (x : Nat) := x def myPair : Bool → Nat → Nat | true, x => myId x | false, x => myId2 x -- Without squeeze_scope: multiple printouts /-- info: Try this: [apply] simp only [foo, bar] --- info: Try this: [apply] simp only [foo, baz] -/ #guard_msgs in example : foo x y = 1 + y := by cases x <;> simp? -- two printouts: -- "Try this: simp only [foo, bar]" -- "Try this: simp only [foo, baz]" -- With squeeze_scope: single aggregated printout /-- info: Try this: [apply] simp only [foo, bar, baz] -/ #guard_msgs in example : foo x y = 1 + y := by squeeze_scope cases x <;> simp -- only one printout: "Try this: simp only [foo, baz, bar]" -- squeeze_scope works with simp? /-- info: Try this: [apply] simp only [foo, bar, baz] -/ #guard_msgs in example : foo x y = 1 + y := by squeeze_scope cases x <;> simp? -- squeeze_scope works with simp_all? /-- info: Try this: [apply] simp_all only [qux, baz, bar] -/ #guard_msgs in example : qux b y = 1 + y := by squeeze_scope cases b <;> simp_all? -- squeeze_scope works with dsimp? /-- info: Try this: [apply] dsimp only [myPair, myId2, myId] -/ #guard_msgs in example : myPair b x = x := by squeeze_scope cases b <;> dsimp? [myPair, myId, myId2] ================================================ FILE: BatteriesTest/simpa.lean ================================================ /- Copyright (c) 2022 Arthur Paulino. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Arthur Paulino, Gabriel Ebner -/ set_option linter.missingDocs false example {P : Prop} (p : P) : P := by simpa example {P : Prop} (p : False) : P := by simp at p def foo (n : α) := [n] section unnecessarySimpa /-- warning: try 'simp' instead of 'simpa' Note: This linter can be disabled with `set_option linter.unnecessarySimpa false` -/ #guard_msgs in example : foo n = [n] := by simpa only [foo] /-- warning: Try `simp at h` instead of `simpa using h` Note: This linter can be disabled with `set_option linter.unnecessarySimpa false` -/ #guard_msgs in example (h : foo n ≠ [n]) : False := by simpa [foo] using h end unnecessarySimpa example (p : Nat → Prop) (h : p (a + b)) : p (b + a) := by have : a + b = b + a := Nat.add_comm _ _ simpa [this] using h def Injective (f : α → β) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂ namespace div_left_inj_issue class Inv (α : Type u) where inv : α → α class Group (α) extends Mul α, Div α, Inv α variable [Group G] axiom div_eq_mul_inv (a b : G) : a / b = a * Inv.inv b axiom mul_left_injective (a : G) : Injective (· * a) theorem div_left_injective (b : G) : Injective fun a => a / b := by simpa only [div_eq_mul_inv] using fun a a' h => mul_left_injective (Inv.inv b) h end div_left_inj_issue namespace Prod theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ a₁ = a₂ ∧ b₁ = b₂ := Iff.of_eq (mk.injEq _ _ _ _) theorem mk.inj_left {α β : Type _} (a : α) : Injective (Prod.mk a : β → α × β) := by intro b₁ b₂ h simpa only [true_and, Prod.mk.inj_iff, eq_self] using h end Prod theorem implicit_lambda (h : ∀ {x : Nat}, a = x) : a = 2 := by simpa using h theorem implicit_lambda2 (h : a = 2) : ∀ {_ : Nat}, a = 2 := by simpa using h theorem no_implicit_lambda (h : ∀ {x : Nat}, a = x) : ∀ {x : Nat}, a = x := by simpa using @h #guard_msgs (drop warning) in theorem thm : (a : Int) ≤ b - c ↔ a + b ≤ c := sorry #guard_msgs (drop warning) in theorem thm2 : (b : Int) - c ≤ (a - b) - (a - c) := sorry example : (b - c : Int) + (a - b) + a ≤ c := by simpa only [thm] using thm2 example : (b - c : Int) + (a - b) + a ≤ c := by simpa only [thm] using @thm2 example (P : Bool) (h : ¬ ¬ P) : P := by have : ¬ ¬ P := h simpa /-- info: Try this: [apply] simpa only using h -/ #guard_msgs in example (p : Prop) (h : p) : p := by simpa? using h /-- info: Try this: [apply] simpa only [and_true] using h -/ #guard_msgs in example (p : Prop) (h : p ∧ True) : p := by simpa? using h ================================================ FILE: BatteriesTest/solve_by_elim.lean ================================================ /- Copyright (c) 2021 Kim Morrison. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Kim Morrison -/ import Batteries.Tactic.PermuteGoals import BatteriesTest.Internal.DummyLabelAttr import Lean.Meta.Tactic.Constructor import Lean.Elab.SyntheticMVars import Lean.Elab.Tactic.SolveByElim -- FIXME we need to make SolveByElimConfig builtin set_option autoImplicit true open Lean Elab Tactic in /-- `fconstructor` is like `constructor` (it calls `apply` using the first matching constructor of an inductive datatype) except that it does not reorder goals. -/ elab "fconstructor" : tactic => withMainContext do let mvarIds' ← (← getMainGoal).constructor {newGoals := .all} Term.synthesizeSyntheticMVarsNoPostponing replaceMainGoal mvarIds' -- Test that `solve_by_elim*`, which works on multiple goals, -- successfully uses the relevant local hypotheses for each goal. example (f g : Nat → Prop) : (∃ k : Nat, f k) ∨ (∃ k : Nat, g k) ↔ ∃ k : Nat, f k ∨ g k := by fconstructor rintro (⟨n, fn⟩ | ⟨n, gn⟩) on_goal 3 => rintro ⟨n, hf | hg⟩ solve_by_elim* (config := {maxDepth := 13}) [Or.inl, Or.inr, Exists.intro] section «using» /-- -/ @[dummy_label_attr] axiom foo : 1 = 2 example : 1 = 2 := by fail_if_success solve_by_elim solve_by_elim using dummy_label_attr end «using» section issue1581 /-- -/ axiom mySorry {α} : α @[dummy_label_attr] theorem le_rfl [LE α] {b c : α} (_h : b = c) : b ≤ c := mySorry example : 5 ≤ 7 := by apply_rules using dummy_label_attr guard_target = 5 = 7 exact mySorry example : 5 ≤ 7 := by apply_rules [le_rfl] guard_target = 5 = 7 exact mySorry end issue1581 ================================================ FILE: BatteriesTest/trans.lean ================================================ import Batteries.Tactic.Trans -- testing that the attribute is recognized and used def nleq (a b : Nat) : Prop := a ≤ b @[trans] def nleq_trans : nleq a b → nleq b c → nleq a c := Nat.le_trans example (a b c : Nat) : nleq a b → nleq b c → nleq a c := by intro h₁ h₂ trans b assumption assumption example (a b c : Nat) : nleq a b → nleq b c → nleq a c := by intros; trans <;> assumption -- using `Trans` typeclass @[trans] def eq_trans {a b c : α} : a = b → b = c → a = c := by intro h₁ h₂ apply Eq.trans h₁ h₂ example (a b c : Nat) : a = b → b = c → a = c := by intros; trans <;> assumption example (a b c : Nat) : a = b → b = c → a = c := by intro h₁ h₂ trans b assumption assumption example : @Trans Nat Nat Nat (· ≤ ·) (· ≤ ·) (· ≤ ·) := inferInstance example (a b c : Nat) : a ≤ b → b ≤ c → a ≤ c := by intros h₁ h₂ trans ?b case b => exact b exact h₁ exact h₂ example (a b c : α) (R : α → α → Prop) [Trans R R R] : R a b → R b c → R a c := by intros h₁ h₂ trans ?b case b => exact b exact h₁ exact h₂ example (a b c : Nat) : a ≤ b → b ≤ c → a ≤ c := by intros h₁ h₂ trans exact h₁ exact h₂ example (a b c : Nat) : a ≤ b → b ≤ c → a ≤ c := by intros; trans <;> assumption example (a b c : Nat) : a < b → b < c → a < c := by intro h₁ h₂ trans b assumption assumption example (a b c : Nat) : a < b → b < c → a < c := by intros; trans <;> assumption example (x n p : Nat) (h₁ : n * Nat.succ p ≤ x) : n * p ≤ x := by trans · apply Nat.mul_le_mul_left; apply Nat.le_succ · apply h₁ example (a : α) (c : γ) : ∀ b : β, a ≍ b → b ≍ c → a ≍ c := by intro b h₁ h₂ trans b assumption assumption def MyLE (n m : Nat) := ∃ k, n + k = m @[trans] theorem MyLE.trans {n m k : Nat} (h1 : MyLE n m) (h2 : MyLE m k) : MyLE n k := by cases h1 cases h2 subst_vars exact ⟨_, Eq.symm <| Nat.add_assoc _ _ _⟩ example {n m k : Nat} (h1 : MyLE n m) (h2 : MyLE m k) : MyLE n k := by trans <;> assumption /-- `trans` for implications. -/ example {A B C : Prop} (h : A → B) (g : B → C) : A → C := by trans B · guard_target =ₛ A → B -- ensure we have `B` and not a free metavariable. exact h · guard_target =ₛ B → C exact g /-- `trans` for arrows between types. -/ example {A B C : Type} (h : A → B) (g : B → C) : A → C := by trans rotate_right · exact B · exact h · exact g universe u v w /-- `trans` for arrows between types. -/ example {A : Type u} {B : Type v} {C : Type w} (h : A → B) (g : B → C) : A → C := by trans rotate_right · exact B · exact h · exact g ================================================ FILE: BatteriesTest/tryThis.lean ================================================ /- Copyright (c) 2023 Thomas Murrills. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Thomas Murrills -/ import Lean.Meta.Tactic.TryThis open Lean.Meta.Tactic.TryThis /-! This test file demonstrates the `Try This:` widget and describes how certain examples should look. Note that while the evaluations here shouldn't fail, they also aren't tests in the traditional sense—CI has no way of inspecting the HTML output, and therefore no way of checking that the output is styled correctly. All clickables should dim on mouseover without changing color drastically. Both widgets should provide a (list of) `Try this: rfl` code actions. -/ /-! # Setup -/ open Lean Meta Elab Term Expr /-- Add a suggestion. -/ elab "add_suggestion" s:term : tactic => unsafe do addSuggestion (← getRef) (← evalTerm Suggestion (.const ``Suggestion []) s) /-- Add a suggestion with a header. -/ elab "add_suggestion" s:term "with_header" h:str : tactic => unsafe do addSuggestion (← getRef) (← evalTerm Suggestion (.const ``Suggestion []) s) (header := h.getString) /-- Add a suggestion. -/ elab "add_suggestions" s:term : tactic => unsafe do let s ← evalTerm (Array Suggestion) (.app (.const ``Array [.zero]) (.const ``Suggestion [])) s addSuggestions (← getRef) s /-- Add suggestions with a header. -/ elab "add_suggestions" s:term "with_header" h:str : tactic => unsafe do let s ← evalTerm (Array Suggestion) (.app (.const ``Array [.zero]) (.const ``Suggestion [])) s addSuggestions (← getRef) s (header := h.getString) /-- Demo adding a suggestion. -/ macro "#demo1" s:term : command => `(example : True := by add_suggestion $s; trivial) /-- Demo adding a suggestion with a header. -/ macro "#demo1" s:term "with_header" h:str : command => `(example : True := by add_suggestion $s with_header $h; trivial) /-- Demo adding suggestions. -/ macro "#demo" s:term : command => `(example : True := by add_suggestions $s; trivial) /-- Demo adding suggestions with a header. -/ macro "#demo" s:term "with_header" h:str : command => `(example : True := by add_suggestions $s with_header $h; trivial) /-- A basic suggestion. -/ private def s : Suggestion := Unhygienic.run `(tactic| rfl) /-! # Demos -/ /-- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` with `rfl` in text-link color. #demo1 s /-- info: Try these: [apply] rfl [apply] rfl [apply] rfl [apply] rfl -/ #guard_msgs in /- ``` Try these: • rfl • rfl • rfl • rfl ``` with `rfl` in text-link color. -/ #demo #[s,s,s,s] /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.value` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.value` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try these: [apply] rfl [apply] rfl [apply] rfl [apply] rfl [apply] rfl [apply] rfl [apply] rfl -/ #guard_msgs in /- ``` Try these: • rfl -- red • rfl -- red-orange • rfl -- orange • rfl -- yellow • rfl -- yellow-green • rfl -- light green • rfl -- green ``` -/ #demo #[0.0, 1/6, 2/6, 3/6, 4/6, 5/6, 1.0].map fun t => {s with style? := some <| .value t} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.error` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.error` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- error color, no squiggle #demo1 {s with style? := some <| .error (decorated := false)} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- gold color with warning squiggle #demo1 {s with style? := some .warning} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- gold color with no squiggle #demo1 {s with style? := some <| .warning (decorated := false)} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.success` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.success` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- Lean green #demo1 {s with style? := some .success} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.asHypothesis` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.asHypothesis` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- styled like a goal hypothesis #demo1 {s with style? := some .asHypothesis} /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.asInaccessible` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.asInaccessible` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Try this: [apply] rfl -/ #guard_msgs in -- `Try this: rfl` -- styled like an inaccessible goal hypothesis #demo1 {s with style? := some .asInaccessible} /-- info: Try this: [apply] Starfleet -/ #guard_msgs in -- `Try this: Starfleet` #demo1 {s with preInfo? := "Sta", postInfo? := "eet"} /-- info: Try this: [apply] a secret message -/ #guard_msgs in -- `Try this: a secret message` #demo1 {s with messageData? := m!"a secret message"} /-- info: Try these: [apply] a secret message [apply] another secret message -/ #guard_msgs in /- ``` Try these: • a secret message • another secret message ``` -/ #demo #[ {s with messageData? := m!"a secret message"}, {s with messageData? := m!"another secret message"} ] /-- info: Our only hope is ⏎ [apply] rfl -/ #guard_msgs in #demo1 s with_header "Our only hope is " /-- info: We've got everything here! Such as: [apply] rfl [apply] rfl [apply] rfl [apply] rfl -/ #guard_msgs in #demo #[s,s,s,s] with_header "We've got everything here! Such as:" /-- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.error` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.error` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.warning` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.success` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.success` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.value` has been deprecated: `SuggestionStyle` is not used anymore. --- warning: `Lean.Meta.Tactic.TryThis.SuggestionStyle.value` has been deprecated: `SuggestionStyle` is not used anymore. --- info: Grab bag: [apply] This is not a tactic. [apply] This could be a tactic--but watch out! [apply] rfl. Finally, a tactic that just works. [apply] I'm just link-styled. [apply] On a scale of 0 to 1, I'd put this at 0.166667. -/ #guard_msgs in #demo #[ {s with suggestion := "not a tactic", preInfo? := "This is ", postInfo? := ".", style? := some .error}, {s with suggestion := "This", postInfo? := " could be a tactic--but watch out!", style? := some .warning}, {s with postInfo? := ". Finally, a tactic that just works.", style? := some .success}, {s with preInfo? := "I'm just " suggestion := "link-styled", postInfo? := "."}, {s with preInfo? := "On a scale of 0 to 1, I'd put ", suggestion := "this", postInfo? := " at 0.166667.", style? := some (.value (1/6))} ] with_header "Grab bag:" /-- error: No suggestions available -/ #guard_msgs in #demo #[] /- The messages and suggestion should still read `Try this: rfl`, but the text in the lightbulb menu should read "Consider rfl, please" -/ /-- info: Try this: [apply] rfl -/ #guard_msgs in #demo1 { s with toCodeActionTitle? := fun text => "Consider " ++ text ++ ", please" } /-- Add suggestions with a default code action title prefix. -/ elab "add_suggestions" s:term "with_code_action_prefix" h:str : tactic => unsafe do let s ← evalTerm (Array Suggestion) (.app (.const ``Array [.zero]) (.const ``Suggestion [])) s addSuggestions (← getRef) s (codeActionPrefix? := h.getString) /-- Demo adding suggestions with a header. -/ macro "#demo" s:term "with_code_action_prefix" h:str : command => `(example : True := by add_suggestions $s with_code_action_prefix $h; trivial) /- The messages and suggestions should still read `Try these: ...`, but the text in the lightbulb menu should read "Maybe use: rfl"; "Maybe use: rfl"; "Also consider rfl, please!" -/ /-- info: Try these: [apply] rfl [apply] rfl [apply] rfl -/ #guard_msgs in #demo #[ s, s, { s with toCodeActionTitle? := fun text => "Also consider " ++ text ++ ", please!" } ] with_code_action_prefix "Maybe use: " ================================================ FILE: BatteriesTest/vector.lean ================================================ import Batteries.Data.Vector /-! ### Testing decidable quantifiers for `Vector`. -/ example : ∃ v : Vector Bool 6, v.toList.count true = 3 := by decide inductive Gate : Nat → Type | const : Bool → Gate 0 | if : ∀ {n}, Gate n → Gate n → Gate (n + 1) namespace Gate def and : Gate 2 := .if (.if (.const true) (.const false)) (.if (.const false) (.const false)) def eval (g : Gate n) (v : Vector Bool n) : Bool := match g, v with | .const b, _ => b | .if g₁ g₂, v => if v.1.back! then eval g₁ v.pop else eval g₂ v.pop example : ∀ v, and.eval v = (v[0] && v[1]) := by decide example : ∃ v, and.eval v = false := by decide end Gate ================================================ FILE: BatteriesTest/where.lean ================================================ -- None of these imports are really necessary, except to create namespace mentioned below. import Lean.Elab.Term import Lean.Elab.Command import Batteries.Data.UnionFind.Basic -- Return to pristine state set_option linter.missingDocs false set_option internal.cmdlineSnapshots false set_option experimental.module false set_option Elab.inServer false /-- info: -- In root namespace with initial scope -/ #guard_msgs in #where noncomputable section /-- info: noncomputable section -/ #guard_msgs in #where end namespace WhereTest variable (x : Nat) (α : Type) /-- info: namespace WhereTest variable (x : Nat) (α : Type) -/ #guard_msgs in #where universe u v w /-- info: namespace WhereTest universe u v w variable (x : Nat) (α : Type) -/ #guard_msgs in #where set_option pp.piBinderTypes false /-- info: namespace WhereTest universe u v w variable (x : Nat) (α : Type) set_option pp.piBinderTypes false -/ #guard_msgs in #where end WhereTest open Lean Meta /-- info: open Lean Lean.Meta -/ #guard_msgs in #where open Elab hiding TermElabM /-- info: open Lean Lean.Meta open Lean.Elab hiding TermElabM -/ #guard_msgs in #where open Command Batteries open Array renaming map -> listMap /-- info: open Lean Lean.Meta open Lean.Elab hiding TermElabM open Lean.Elab.Command Batteries open Array renaming map → listMap -/ #guard_msgs in #where ================================================ FILE: LICENSE ================================================ Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ================================================ FILE: README.md ================================================ # Batteries The "batteries included" extended library for Lean 4. This is a collection of data structures and tactics intended for use by both computer-science applications and mathematics applications of Lean 4. # Using `batteries` To use `batteries` in your project, add the following to your `lakefile.lean`: ```lean require "leanprover-community" / "batteries" @ git "main" ``` Or add the following to your `lakefile.toml`: ```toml [[require]] name = "batteries" scope = "leanprover-community" rev = "main" ``` Additionally, please make sure that you're using the version of Lean that the current version of `batteries` expects. The easiest way to do this is to copy the [`lean-toolchain`](./lean-toolchain) file from this repository to your project. Once you've added the dependency declaration, the command `lake update` checks out the current version of `batteries` and writes it the Lake manifest file. Don't run this command again unless you're prepared to potentially also update your Lean compiler version, as it will retrieve the latest version of dependencies and add them to the manifest. # Build instructions * Get the newest version of `elan`. If you already have installed a version of Lean, you can run ```sh elan self update ``` If the above command fails, or if you need to install `elan`, run ```sh curl https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh -sSf | sh ``` If this also fails, follow the instructions under `Regular install` [here](https://leanprover-community.github.io/get_started.html). * To build `batteries` run `lake build`. * To build and run all tests, run `lake test`. * To run the environment linter, run `lake lint`. * If you added a new file, run the command `scripts/updateBatteries.sh` to update the imports. # Documentation You can generate `batteries` documentation with ```sh cd docs lake build Batteries:docs ``` The top-level HTML file will be located at `docs/doc/index.html`, though to actually expose the documentation you need to run an HTTP server (e.g. `python3 -m http.server`) in the `docs/doc` directory. Note that documentation for the latest nightly of `batteries` is also available as part of [the Mathlib 4 documentation][mathlib4 docs]. [mathlib4 docs]: https://leanprover-community.github.io/mathlib4_docs/Batteries.html # Contributing The first step to contribute is to create a fork of Batteries. Then add your contributions to a branch of your fork and make a PR to Batteries. Do not make your changes to the main branch of your fork, that may lead to complications on your end. Every pull request should have exactly one of the status labels `awaiting-review`, `awaiting-author` or `WIP` (in progress). To change the status label of a pull request, add a comment containing one of these options and _nothing else_. This will remove the previous label and replace it by the requested status label. These labels are used for triage. One of the easiest ways to contribute is to find a missing proof and complete it. The [`proof_wanted`](https://github.com/search?q=repo%3Aleanprover-community%2Fbatteries+language%3ALean+%2F^proof_wanted%2F&type=code) declaration documents statements that have been identified as being useful, but that have not yet been proven. ### Mathlib Adaptations Batteries PRs often affect Mathlib, a key component of the Lean ecosystem. When Batteries changes in a significant way, Mathlib must adapt promptly. When necessary, Batteries contributors are expected to either create an adaptation PR on Mathlib, or ask for assistance for and to collaborate with this necessary process. Every Batteries PR has an automatically created [Mathlib Nightly Testing](https://github.com/leanprover-community/mathlib4-nightly-testing/) branch called `batteries-pr-testing-N` where `N` is the number of the Batteries PR. This is a clone of Mathlib where the Batteries requirement points to the Batteries PR branch instead of the main branch. Batteries uses this branch to check whether the Batteries PR needs Mathlib adaptations. A tag `builds-mathlib` will be issued when this branch needs no adaptation; a tag `breaks-mathlib` will be issued when the branch does need an adaptation. The first step in creating an adaptation PR is to switch to the `batteries-pr-testing-N` branch and push changes to that branch until the Mathlib CI process works. You may need to ask for write access to [Mathlib Nightly Testing](https://github.com/leanprover-community/mathlib4-nightly-testing/) to do that. Changes to the Batteries PR will be integrated automatically as you work on this process. Do not redirect the Batteries requirement to main until the Batteries PR is merged. Please ask questions to Batteries and Mathlib maintainers if you run into issues with this process. When everything works, create an adaptation PR on Mathlib from the `batteries-pr-testing-N` branch. You may need to ping a Mathlib maintainer to review the PR, ask if you don't know who to ping. Once the Mathlib adaptation PR and the original Batteries PR have been reviewed and accepted, the Batteries PR will be merged first. Then, the Mathlib PR's lakefile needs to be repointed to the Batteries main branch: change the Batteries line to ```lean require "leanprover-community" / "batteries" @ git "main" ``` Once CI once again checks out on Mathlib, the adaptation PR can be merged using the regular Mathlib process. ================================================ FILE: Shake/Main.lean ================================================ /- Copyright (c) 2023 Mario Carneiro. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Mario Carneiro -/ import Lake.CLI.Main /-! # `lake exe shake` command This command will check the current project (or a specified target module) and all dependencies for unused imports. This works by looking at generated `.olean` files to deduce required imports and ensuring that every import is used to contribute some constant. Because recompilation is not needed this is quite fast (about 8 seconds to check `Mathlib` and all dependencies), but it has some known limitations: * Tactics that are used during elaboration generally leave no trace in the proof term, so they will be incorrectly marked as unused. * Similarly, files that contribute only notations will not be detected. * Conversely, files that define tactics and notations are also likely to have false positives because the notation itself does not depend on the referenced constant (it elaborates to a name literal rather than an actual reference to the target constant). To mitigate this, the `scripts/noshake.json` file is used to suppress known false positives. See `ShakeCfg` for information regarding the file format. -/ /-- help string for the command line interface -/ def help : String := "Lean project tree shaking tool Usage: lake exe shake [OPTIONS] .. Arguments: A module path like `Mathlib`. All files transitively reachable from the provided module(s) will be checked. Options: --force Skips the `lake build --no-build` sanity check --fix Apply the suggested fixes directly. Make sure you have a clean checkout before running this, so you can review the changes. --cfg (default: scripts/noshake.json) Use FILE to specify which imports we should ignore. --update Assume that all issues we find are false positives and update the config file to include them. --no-downstream Unless disabled, shake will check downstream files that were transitively depending on the import we want to remove and re-add the import to these downstream files. # The noshake.json file The file passed in the --cfg argument is a JSON file with the following structure: { \"ignoreAll\": [NAME], \"ignoreImport\": [NAME], \"ignore\": {NAME: [NAME]} } The fields can be omitted if empty. They have the following interpretation: * ignoreAll: All imports in these files should be treated as necessary * ignore[X]: All imports in the list should be treated as necessary when processing X * ignoreImport: These files should be treated as necessary when imported into any other file. " open Lean /-- We use `Nat` as a bitset for doing efficient set operations. The bit indexes will usually be a module index. -/ abbrev Bitset := Nat /-- The main state of the checker, containing information on all loaded modules. -/ structure State where /-- Maps a module name to its index in the module list. -/ toIdx : Std.HashMap Name USize := {} /-- Maps a module index to the module name. -/ modNames : Array Name := #[] /-- Maps a module index to the module data. -/ mods : Array ModuleData := #[] /-- `j ∈ deps[i]` if module `j` is a direct dependency of module `i` -/ deps : Array (Array USize) := #[] /-- `j ∈ transDeps[i]` is the reflexive transitive closure of `deps` -/ transDeps : Array Bitset := #[] /-- `j ∈ needs[i]` if module `i` uses a constant declared in module `j`. Note: this is left empty if `args.downstream` is false, we calculate `needs` on demand -/ needs : Array Bitset := #[] /-- Maps a constant name to the module index containing it. A value of `none` means the constant was found in multiple modules, in which case we do not track it. -/ constToIdx : Std.HashMap Name (Option USize) := {} /-- Returns `true` if this is a constant whose body should not be considered for dependency tracking purposes. -/ def isBlacklisted (name : Name) : Bool := -- Compiler-produced definitions are skipped, because they can sometimes pick up spurious -- dependencies due to specializations in unrelated files. Even if we remove these modules -- from the import path, the compiler will still just find another way to compile the definition. if let .str _ "_cstage2" := name then true else if let .str _ "_cstage1" := name then true else false /-- Calculates the value of the `needs[i]` bitset for a given module `mod`. Bit `j` is set in the result if some constant from module `j` is used in this module. -/ def calcNeeds (constToIdx : Std.HashMap Name (Option USize)) (mod : ModuleData) : Bitset := mod.constants.foldl (init := 0) fun deps ci => if isBlacklisted ci.name then deps else let deps := visitExpr ci.type deps match ci.value? with | some e => visitExpr e deps | none => deps where /-- Accumulate the results from expression `e` into `deps`. -/ visitExpr e deps := Lean.Expr.foldConsts e deps fun c deps => match constToIdx[c]? with | some (some i) => deps ||| (1 <<< i.toNat) | _ => deps /-- Calculates the same as `calcNeeds` but tracing each module to a specific constant. -/ def getExplanations (constToIdx : Std.HashMap Name (Option USize)) (mod : ModuleData) : Std.HashMap USize (Name × Name) := mod.constants.foldl (init := {}) fun deps ci => if isBlacklisted ci.name then deps else let deps := visitExpr ci.name ci.type deps match ci.value? with | some e => visitExpr ci.name e deps | none => deps where /-- Accumulate the results from expression `e` into `deps`. -/ visitExpr name e deps := Lean.Expr.foldConsts e deps fun c deps => match constToIdx[c]? with | some (some i) => if if let some (name', _) := deps[i]? then decide (name.toString.length < name'.toString.length) else true then deps.insert i (name, c) else deps | _ => deps /-- Load all the modules in `imports` into the `State`, as well as their transitive dependencies. Returns a pair `(imps, transImps)` where: * `j ∈ imps` if `j` is one of the module indexes in `imports` * `j ∈ transImps` if module `j` is transitively reachable from `imports` -/ partial def loadModules (imports : Array Import) : StateT State IO (Array USize × Bitset) := do let mut imps := #[] let mut transImps := 0 for imp in imports do let s ← get if let some i := s.toIdx[imp.module]? then imps := imps.push i transImps := transImps ||| s.transDeps[i]! else let mFile ← findOLean imp.module unless (← mFile.pathExists) do throw <| IO.userError s!"object file '{mFile}' of module {imp.module} does not exist" let (mod, _) ← readModuleData mFile let (deps, transDeps) ← loadModules mod.imports let s ← get let n := s.mods.size.toUSize let transDeps := transDeps ||| (1 <<< n.toNat) imps := imps.push n transImps := transImps ||| transDeps set (σ := State) { toIdx := s.toIdx.insert imp.module n modNames := s.modNames.push imp.module mods := s.mods.push mod deps := s.deps.push deps transDeps := s.transDeps.push transDeps needs := s.needs constToIdx := mod.constNames.foldl (init := s.constToIdx) fun m a => match m.getThenInsertIfNew? a n with | (some (some _), m) => -- Note: If a constant is found in multiple modules, we assume it is an auto-generated -- definition which is created on demand, and therefore it is safe to ignore any -- dependencies via this definition because it will just be re-created in the current -- module if we don't import it. m.insert a none | (_, m) => m } return (imps, transImps) /-- The list of edits that will be applied in `--fix`. `edits[i] = (removed, added)` where: * If `j ∈ removed` then we want to delete module named `j` from the imports of `i` * If `j ∈ added` then we want to add module index `j` to the imports of `i`. We keep this as a bitset because we will do transitive reduction before applying it -/ abbrev Edits := Std.HashMap Name (NameSet × Bitset) /-- Register that we want to remove `tgt` from the imports of `src`. -/ def Edits.remove (ed : Edits) (src tgt : Name) : Edits := match ed.get? src with | none => ed.insert src (NameSet.insert ∅ tgt, 0) | some (a, b) => ed.insert src (a.insert tgt, b) /-- Register that we want to add `tgt` to the imports of `src`. -/ def Edits.add (ed : Edits) (src : Name) (tgt : Nat) : Edits := match ed.get? src with | none => ed.insert src (∅, 1 <<< tgt) | some (a, b) => ed.insert src (a, b ||| (1 <<< tgt)) /-- Parse a source file to extract the location of the import lines, for edits and error messages. Returns `(path, inputCtx, imports, endPos)` where `imports` is the `Lean.Parser.Module.import` list and `endPos` is the position of the end of the header. -/ def parseHeaderFromString (text path : String) : IO (System.FilePath × Parser.InputContext × TSyntaxArray ``Parser.Module.import × String.Pos.Raw) := do let inputCtx := Parser.mkInputContext text path let (header, parserState, msgs) ← Parser.parseHeader inputCtx if !msgs.toList.isEmpty then -- skip this file if there are parse errors msgs.forM fun msg => msg.toString >>= IO.println throw <| .userError "parse errors in file" -- the insertion point for `add` is the first newline after the imports let insertion := header.raw.getTailPos?.getD parserState.pos let insertion := (text.pos! insertion).find '\n' |>.next! pure (path, inputCtx, .mk header.raw[2].getArgs, insertion.offset) /-- Parse a source file to extract the location of the import lines, for edits and error messages. Returns `(path, inputCtx, imports, endPos)` where `imports` is the `Lean.Parser.Module.import` list and `endPos` is the position of the end of the header. -/ def parseHeader (srcSearchPath : SearchPath) (mod : Name) : IO (System.FilePath × Parser.InputContext × TSyntaxArray ``Parser.Module.import × String.Pos.Raw) := do -- Parse the input file let some path ← srcSearchPath.findModuleWithExt "lean" mod | throw <| .userError "error: failed to find source file for {mod}" let text ← IO.FS.readFile path parseHeaderFromString text path.toString /-- Gets the name `Foo` in `import Foo`. -/ def importId : TSyntax ``Parser.Module.import → Name | `(Parser.Module.import| import $id) => id.getId | stx => panic! s!"unexpected syntax {stx}" /-- Analyze and report issues from module `i`. Arguments: * `s`: The main state (contains all the modules and dependency information) * `srcSearchPath`: Used to find the path for error reporting purposes * `ignoreImps`: if `j ∈ ignoreImps` then it will be treated as used * `i`: the module index * `needs`: this is the same as `s.needs[i]`, except that this array may not be initialized if `downstream` mode is disabled so we pass it in here * `edits`: accumulates the list of edits to apply if `--fix` is true * `downstream`: if true, then we report downstream files that need to be fixed too -/ def visitModule (s : State) (srcSearchPath : SearchPath) (ignoreImps : Bitset) (i : Nat) (needs : Bitset) (edits : Edits) (downstream := true) (githubStyle := false) (explain := false) : IO Edits := do -- Do transitive reduction of `needs` in `deps` and transitive closure in `transDeps`. -- Include the `ignoreImps` in `transDeps` let mut deps := needs let mut transDeps := needs ||| ignoreImps for j in [0:s.mods.size] do if deps &&& (1 <<< j) != 0 then let deps2 := s.transDeps[j]! deps := deps ^^^ (deps &&& deps2) ^^^ (1 <<< j) transDeps := transDeps ||| deps2 -- Any import which is not in `transDeps` was unused. -- Also accumulate `newDeps` which is the transitive closure of the remaining imports let mut toRemove := #[] let mut newDeps := 0 for imp in s.mods[i]!.imports do let j := s.toIdx[imp.module]! if transDeps &&& (1 <<< j.toNat) == 0 then toRemove := toRemove.push j else newDeps := newDeps ||| s.transDeps[j]! if toRemove.isEmpty then return edits -- nothing to do -- If `newDeps` does not cover `needs`, then we have to add back some imports until it does. -- To minimize new imports we pick only new imports which are not transitively implied by -- another new import let mut toAdd := #[] for j in [0:s.mods.size] do if deps &&& (1 <<< j) != 0 && newDeps &&& (1 <<< j) == 0 then toAdd := toAdd.push j newDeps := newDeps ||| s.transDeps[j]! -- mark and report the removals let mut edits := toRemove.foldl (init := edits) fun edits n => edits.remove s.modNames[i]! s.modNames[n]! if githubStyle then try let (path, inputCtx, imports, endHeader) ← parseHeader srcSearchPath s.modNames[i]! for stx in imports do if toRemove.any fun i => s.modNames[i]! == importId stx then let pos := inputCtx.fileMap.toPosition stx.raw.getPos?.get! println! "{path}:{pos.line}:{pos.column+1}: warning: unused import \ (use `lake exe shake --fix` to fix this, or `lake exe shake --update` to ignore)" if !toAdd.isEmpty then -- we put the insert message on the beginning of the last import line let pos := inputCtx.fileMap.toPosition endHeader println! "{path}:{pos.line-1}:1: warning: \ import {toAdd.map (s.modNames[·]!)} instead" catch _ => pure () if let some path ← srcSearchPath.findModuleWithExt "lean" s.modNames[i]! then println! "{path}:" else println! "{s.modNames[i]!}:" println! " remove {toRemove.map (s.modNames[·]!)}" -- mark and report the additions if !toAdd.isEmpty then edits := toAdd.foldl (init := edits) fun edits n => edits.add s.modNames[i]! n println! " add {toAdd.map (s.modNames[·]!)}" if downstream && !toRemove.isEmpty then -- In `downstream` mode, we should also check all the other modules to find out if -- we have a situation like `A -> B -/> C -> D`, where we are removing the `B -> C` import -- but `D` depends on `A` and only directly imports `C`. -- This situation occurs when `A ∈ needs[D]`, `C ∈ transDeps[D]`, and `A ∉ newTransDeps[D]`, -- where `newTransDeps` is the result of recalculating `transDeps` after breaking the `B -> C` -- link. -- calculate `newTransDeps[C]`, removing all `B -> C` links from `toRemove` and adding `toAdd` let mut newTransDepsI := 1 <<< i for j in s.deps[i]! do if !toRemove.contains j then newTransDepsI := newTransDepsI ||| s.transDeps[j]! for j in toAdd do newTransDepsI := newTransDepsI ||| s.transDeps[j]! let mut newTransDeps := s.transDeps.set! i newTransDepsI -- deep copy let mut reAdded := #[] for j in [i+1:s.mods.size] do -- for each module `D` if s.transDeps[j]! &&& (1 <<< i) != 0 then -- which imports `C` -- calculate `newTransDeps[D]` assuming no change to the imports of `D` let mut newTransDepsJ := s.deps[j]!.foldl (init := 1 <<< j) fun d k => d ||| newTransDeps[k]! let diff := s.transDeps[j]! ^^^ newTransDepsJ if diff != 0 then -- if the dependency closure of `D` changed let mut reAdd := diff &&& s.needs[j]! if reAdd != 0 then -- and there are things from `needs[D]` which were lost: -- Add them back. -- `reAdd` is the set of all files `A` which have to be added back -- to the closure of `D`, but some of them might be importing others, -- so we take the transitive reduction of `reAdd`. let mut reAddArr := [] let mut k := j while reAdd != 0 do -- note: this loop terminates because `reAdd ⊆ [0:k]` k := k - 1 if reAdd &&& (1 <<< k) != 0 then reAddArr := k :: reAddArr reAdd := reAdd ^^^ (reAdd &&& newTransDeps[k]!) -- add these to `newTransDeps[D]` so that files downstream of `D` -- (later in the `for j` loop) will take this into account newTransDepsJ := newTransDepsJ ||| newTransDeps[k]! edits := reAddArr.foldl (init := edits) (·.add s.modNames[j]! ·) reAdded := reAdded.push (j, reAddArr) newTransDeps := newTransDeps.set! j newTransDepsJ if !reAdded.isEmpty then println! " instead" for (j, reAddArr) in reAdded do println! " import {reAddArr.map (s.modNames[·]!)} in {s.modNames[j]!}" if explain then let explanation := getExplanations s.constToIdx s.mods[i]! let sanitize n := if n.hasMacroScopes then (sanitizeName n).run' { options := {} } else n let run (j : USize) := do if let some (n, c) := explanation[j]? then println! " note: {s.modNames[i]!} requires {s.modNames[j]!}\ \n because {sanitize n} refers to {sanitize c}" for imp in s.mods[i]!.imports do run <| s.toIdx[imp.module]! for i in toAdd do run i.toUSize return edits /-- Convert a list of module names to a bitset of module indexes -/ def toBitset (s : State) (ns : List Name) : Bitset := ns.foldl (init := 0) fun c name => match s.toIdx[name]? with | some i => c ||| (1 <<< i.toNat) | none => c /-- The parsed CLI arguments. See `help` for more information -/ structure Args where /-- `--help`: shows the help -/ help : Bool := false /-- `--force`: skips the `lake build --no-build` sanity check -/ force : Bool := false /-- `--no-downstream`: disables downstream mode -/ downstream : Bool := true /-- `--gh-style`: output messages that can be parsed by `gh-problem-matcher-wrap` -/ githubStyle : Bool := false /-- `--explain`: give constants explaining why each module is needed -/ explain : Bool := false /-- `--fix`: apply the fixes directly -/ fix : Bool := false /-- `--update`: update the config file -/ update : Bool := false /-- `--global`: with `--update`, add imports to `ignoreImport` instead of `ignore` -/ global : Bool := false /-- `--cfg FILE`: choose a custom location for the config file -/ cfg : Option String := none /-- `..`: the list of root modules to check -/ mods : Array Name := #[] instance {α} [FromJson α] : FromJson (NameMap α) where fromJson? j := do (← j.getObj?).foldlM (init := mkNameMap _) fun m a b => do m.insert a.toName <$> fromJson? b instance {α} [ToJson α] : ToJson (NameMap α) where toJson m := Json.obj <| m.foldl (init := ∅) fun m a b => m.insert (toString a) (toJson b) /-- The config file format, which we both read and write. -/ structure ShakeCfg where /-- All imports from modules in this list will be ignored -/ ignoreAll? : Option (List Name) := none /-- The modules in this list will be ignored as imports of any other file -/ ignoreImport? : Option (List Name) := [`Init, `Lean] /-- If `X` maps to `Y` then an import of `Y` in module `X` will be ignored -/ ignore? : Option (NameMap (Array Name)) := none deriving FromJson, ToJson /-- The main entry point. See `help` for more information on arguments. -/ def main (args : List String) : IO UInt32 := do initSearchPath (← findSysroot) -- Parse the arguments let rec parseArgs (args : Args) : List String → Args | [] => args | "--help" :: rest => parseArgs { args with help := true } rest | "--force" :: rest => parseArgs { args with force := true } rest | "--no-downstream" :: rest => parseArgs { args with downstream := false } rest | "--fix" :: rest => parseArgs { args with fix := true } rest | "--explain" :: rest => parseArgs { args with explain := true } rest | "--gh-style" :: rest => parseArgs { args with githubStyle := true } rest | "--update" :: rest => parseArgs { args with update := true } rest | "--global" :: rest => parseArgs { args with global := true } rest | "--cfg" :: cfg :: rest => parseArgs { args with cfg := cfg } rest | "--" :: rest => { args with mods := args.mods ++ rest.map (·.toName) } | other :: rest => parseArgs { args with mods := args.mods.push other.toName } rest let args := parseArgs {} args -- Bail if `--help` is passed if args.help then IO.println help IO.Process.exit 0 if !args.force then if (← IO.Process.output { cmd := "lake", args := #["build", "--no-build"] }).exitCode != 0 then IO.println "There are out of date oleans. Run `lake build` or `lake exe cache get` first" IO.Process.exit 1 -- Determine default module(s) to run shake on let defaultTargetModules : Array Name ← try let (elanInstall?, leanInstall?, lakeInstall?) ← Lake.findInstall? let config ← Lake.MonadError.runEIO <| Lake.mkLoadConfig { elanInstall?, leanInstall?, lakeInstall? } let some workspace ← Lake.loadWorkspace config |>.toBaseIO | throw <| IO.userError "failed to load Lake workspace" let defaultTargetModules := workspace.root.defaultTargets.flatMap fun target => if let some lib := workspace.root.findLeanLib? target then lib.roots else if let some exe := workspace.root.findLeanExe? target then #[exe.config.root] else #[] pure defaultTargetModules catch _ => pure #[] -- Parse the `--cfg` argument let srcSearchPath ← getSrcSearchPath let cfgFile ← if let some cfg := args.cfg then pure (some ⟨cfg⟩) else if let some mod := defaultTargetModules[0]? then if let some path ← srcSearchPath.findModuleWithExt "lean" mod then pure (some (path.parent.get! / "scripts" / "noshake.json")) else pure none else pure none -- Read the config file -- `isValidCfgFile` is `false` if and only if the config file is present and invalid. let (cfg, isValidCfgFile) ← if let some file := cfgFile then try pure (← IO.ofExcept (Json.parse (← IO.FS.readFile file) >>= fromJson? (α := ShakeCfg)), true) catch e => -- The `cfgFile` is invalid, so we print the error and return `isValidCfgFile = false`. println! "{e.toString}" pure ({}, false) else pure ({}, true) if !isValidCfgFile then IO.println s!"Invalid config file '{cfgFile.get!}'" IO.Process.exit 1 else -- the list of root modules let mods := if args.mods.isEmpty then defaultTargetModules else args.mods -- Only submodules of `pkg` will be edited or have info reported on them let pkg := mods[0]!.components.head! -- Load all the modules let mut (_, s) ← (loadModules (mods.map ({module := ·}))).run {} -- Parse the config file let ignoreMods := toBitset s (cfg.ignoreAll?.getD []) let ignoreImps := toBitset s (cfg.ignoreImport?.getD []) let ignore := (cfg.ignore?.getD {}).foldl (init := (∅ : Std.HashMap _ _)) fun m a v => m.insert a (toBitset s v.toList) let noIgnore (i : Nat) := !s.mods[i]!.constNames.isEmpty && -- skip import-only mods ignoreMods &&& (1 <<< i) == 0 && pkg.isPrefixOf s.modNames[i]! -- Run the calculation of the `needs` array in parallel let needs := s.mods.mapIdx fun i mod => if args.downstream || noIgnore i then some <| Task.spawn fun _ => -- remove the module from its own `needs` (calcNeeds s.constToIdx mod ||| (1 <<< i)) ^^^ (1 <<< i) else none if args.downstream then s := { s with needs := needs.map (·.get!.get) } if args.fix then println! "The following changes will be made automatically:" -- Check all selected modules let mut edits : Edits := ∅ for i in [0:s.mods.size], t in needs do if let some t := t then if noIgnore i then let ignoreImps := ignoreImps ||| ignore.getD s.modNames[i]! 0 edits ← visitModule s srcSearchPath ignoreImps i t.get edits args.downstream args.githubStyle args.explain -- Write the config file if args.update then if let some cfgFile := cfgFile then let mut ignore := cfg.ignore?.getD {} let ignoreImport := cfg.ignoreImport?.getD {} let mut ignoreImportSet : NameSet := ignoreImport.foldl .insert {} -- if `args.fix` is true then we assume the errors will be fixed after, -- so it's just reformatting the existing file if !args.fix then if args.global then -- in global mode all the edits are added to `ignoreImport` ignoreImportSet := edits.fold (init := ignoreImportSet) (fun ignore _ (remove, _) => ignore.append remove) else -- in local mode all the edits are added to `ignore` ignore := edits.fold (init := ignore) fun ignore mod (remove, _) => let ns := (ignore.getD mod #[]).foldl (init := remove) (·.insert ·) if ns.isEmpty then ignore.erase mod else ignore.insert mod ns.toArray -- If an entry is in `ignoreAll`, the `ignore` key is redundant for i in cfg.ignoreAll?.getD {} do if ignore.contains i then ignore := ignore.erase i -- If an entry is in `ignoreImport`, the `ignore` value is redundant ignore := ignore.foldl (init := {}) fun ignore mod ns => let ns := ns.filter (!ignoreImportSet.contains ·) if ns.isEmpty then ignore else ignore.insert mod (ns.qsort (·.toString < ·.toString)) -- Sort the lists alphabetically let ignoreImport := (ignoreImportSet.toArray.qsort (·.toString < ·.toString)).toList let cfg : ShakeCfg := { ignoreAll? := cfg.ignoreAll?.filter (!·.isEmpty) ignoreImport? := (some ignoreImport).filter (!·.isEmpty) ignore? := (some ignore).filter (!·.isEmpty) } IO.FS.writeFile cfgFile <| toJson cfg |>.pretty.push '\n' if !args.fix then -- return error if any issues were found return if edits.isEmpty then 0 else 1 -- Apply the edits to existing files let count ← edits.foldM (init := 0) fun count mod (remove, add) => do -- Only edit files in the current package if !pkg.isPrefixOf mod then return count -- Compute the transitive reduction of `add` and convert to a list of names let add := if add == 0 then #[] else Id.run do let mut val := add for i in [0:s.mods.size] do if val &&& (1 <<< i) != 0 then val := val ^^^ (val &&& s.transDeps[i]!) ^^^ (1 <<< i) let mut out := #[] for i in [0:s.mods.size] do if val &&& (1 <<< i) != 0 then out := out.push s.modNames[i]! out.qsort Name.lt -- Parse the input file let (path, inputCtx, imports, insertion) ← try parseHeader srcSearchPath mod catch e => println! e.toString; return count let text := String.Pos.Raw.extract inputCtx.inputString 0 inputCtx.endPos let insertion := text.pos! insertion -- Calculate the edit result let mut pos : text.Pos := text.startPos let mut out : String := "" let mut seen : NameSet := {} for stx in imports do let startPos : text.Pos := text.pos! stx.raw.getPos?.get! let mod := importId stx if remove.contains mod || seen.contains mod then out := out ++ startPos.extract pos -- We use the end position of the syntax, but include whitespace up to the first newline pos := startPos.find '\n' |>.next! seen := seen.insert mod out := out ++ pos.extract insertion for mod in add do if !seen.contains mod then seen := seen.insert mod out := out ++ s!"import {mod}\n" out := out ++ insertion.extract text.endPos IO.FS.writeFile path out return count + 1 -- Since we throw an error upon encountering issues, we can be sure that everything worked -- if we reach this point of the script. if count > 0 then println! "Successfully applied {count} suggestions." else println! "No edits required." return 0 -- self-test so that future grammar changes cause a build failure /-- info: #[`Lake.CLI.Main] -/ #guard_msgs (whitespace := lax) in #eval show MetaM _ from do let (_, _, imports, _) ← parseHeaderFromString (← getFileMap).source (← getFileName) return imports.map importId ================================================ FILE: bors.toml ================================================ status = ["Build"] use_squash_merge = true timeout_sec = 28800 block_labels = ["not-ready-to-merge", "WIP", "blocked-by-other-PR", "merge-conflict"] delete_merged_branches = true cut_body_after = "---" ================================================ FILE: docs/lakefile.toml ================================================ name = "docs" reservoir = false packagesDir = "../.lake/packages" buildDir = "." [[require]] scope = "leanprover" name = "doc-gen4" rev = "main" [[require]] name = "batteries" path = ".." ================================================ FILE: lake-manifest.json ================================================ {"version": "1.2.0", "packagesDir": ".lake/packages", "packages": [], "name": "batteries", "lakeDir": ".lake", "fixedToolchain": false} ================================================ FILE: lakefile.toml ================================================ name = "batteries" testDriver = "BatteriesTest" lintDriver = "runLinter" defaultTargets = ["Batteries", "runLinter"] [leanOptions] linter.missingDocs = true [[lean_lib]] name = "Batteries" [[lean_lib]] name = "BatteriesTest" globs = ["BatteriesTest.+"] leanOptions = {linter.missingDocs = false} [[lean_exe]] name = "runLinter" srcDir = "scripts" supportInterpreter = true [[lean_exe]] name = "test" srcDir = "scripts" # `lake exe shake` checks files for unnecessary imports. [[lean_exe]] name = "shake" root = "Shake.Main" supportInterpreter = true ================================================ FILE: lean-toolchain ================================================ leanprover/lean4:v4.30.0-rc2 ================================================ FILE: scripts/check_imports.lean ================================================ /- Copyright (c) 2024 Joe Hendrix. All rights reserved. Released under Apache 2.0 license as described in the file LICENSE. Authors: Joe Hendrix -/ import Batteries /-! This test checks that all directories in `Batteries/Data/` have corresponding `Batteries.Data.` modules imported by `Batteries` that import all of the submodules under that directory. It will also check that `Batteries` imports all the expected modules. It has a flag (`autofix` below) to automatically fix the errors found. This command may need to be rerun to fix all errors; it tries to avoid overwriting existing files. -/ open Lean System /-- Monad to log errors to stderr while record error count. -/ abbrev LogIO := StateRefT (Bool × Bool) IO def runLogIO (act : LogIO Unit) : MetaM Unit := do let ((), (warnings, _)) ← act.run (false, false) if warnings then throwError "Fatal error" def warn (fixable : Bool) (msg : String) : LogIO Unit := do modify (fun (_, u) => (true, u || not fixable)) liftM (IO.eprintln msg) -- | Predicate indicates if warnings are present and if they fixable. def getWarningInfo : LogIO (Bool × Bool) := get def createModuleHashmap (env : Environment) : Std.HashMap Name ModuleData := Id.run do let mut nameMap := {} for i in [0:env.header.moduleNames.size] do let nm := env.header.moduleNames[i]! let md := env.header.moduleData[i]! nameMap := nameMap.insert nm md pure nameMap /-- Get the imports we expect in a directory of `Batteries.Data`. -/ partial def addModulesIn (recurse : Bool) (prev : Array Name) (root : Name := .anonymous) (path : FilePath) : IO (Array Name) := do let mut r := prev for entry in ← path.readDir do if ← entry.path.isDir then if recurse then r ← addModulesIn recurse r (root.mkStr entry.fileName) entry.path else let .some mod := FilePath.fileStem entry.fileName | continue r := r.push (root.mkStr mod) pure r def modulePath (name : Name) : FilePath := let path := name.toString.replace "." FilePath.pathSeparator.toString s!"{path}.lean" def writeImportModule (path : FilePath) (imports : Array Name) : IO Unit := do let imports := imports.qsort (·.toString < ·.toString) let lines := imports.map (s!"public import {·}\n") let contents := String.join ("module\n" :: "\n" :: lines.toList) IO.println s!"Generating {path}" IO.FS.writeFile path contents /-- Check for imports and return true if warnings issued. -/ def checkMissingImports (modName : Name) (modData : ModuleData) (reqImports : Array Name) : LogIO Bool := do let names : Std.HashSet Name := Std.HashSet.ofArray (modData.imports.map (·.module)) let mut warned := false for req in reqImports do if !names.contains req then warn true s!"Missing import {req} in {modName}" warned := true pure warned /-- Check directory entry in `Batteries/Data/` -/ def checkBatteriesDataDir (modMap : Std.HashMap Name ModuleData) (entry : IO.FS.DirEntry) (autofix : Bool := false) : LogIO Unit := do let moduleName := `Batteries.Data ++ .mkSimple entry.fileName let requiredImports ← addModulesIn (recurse := true) #[] (root := moduleName) entry.path let .some module := modMap[moduleName]? | warn true s!"Could not find {moduleName}; Not imported into Batteries." let path := modulePath moduleName -- We refuse to generate imported modules whose path doesn't exist. -- The import failure will be fixed later and the file rerun if autofix then if ← path.pathExists then warn false s!"Skipping writing of {moduleName}: rerun after {moduleName} imported." else writeImportModule path requiredImports return let hasDecls : Bool := module.constants.size > 0 if hasDecls then warn false s!"Expected {moduleName} to not contain additional declarations.\n\ Declarations should be moved out.\n\ This error cannot be automatically fixed." let warned ← checkMissingImports moduleName module requiredImports if autofix && warned && !hasDecls then writeImportModule (modulePath moduleName) requiredImports /-- Compute imports expected by `Batteries.lean` -/ def expectedBatteriesImports : IO (Array Name) := do let mut needed := #[] for top in ← FilePath.readDir "Batteries" do if top.fileName == "Data" then needed ← addModulesIn (recurse := false) needed `Batteries.Data top.path else let nm := `Batteries let rootname := FilePath.withExtension top.fileName "" let root := nm.mkStr rootname.toString if ← top.path.isDir then needed ← addModulesIn (recurse := true) needed (root := root) top.path else needed := needed.push root pure needed def checkBatteriesDataImports : MetaM Unit := do -- N.B. This can be used to automatically fix Batteries.lean as well as -- other import files. -- It uses an environment variable to do that. -- The easiest way to use this is run `./scripts/updateBatteries.sh.` let autofix := (← IO.getEnv "__LEAN_BATTERIES_AUTOFIX_IMPORTS").isSome let env ← getEnv let modMap := createModuleHashmap env runLogIO do for entry in ← FilePath.readDir ("Batteries" / "Data") do if ← entry.path.isDir then checkBatteriesDataDir (autofix := autofix) modMap entry let batteriesImports ← expectedBatteriesImports let .some batteriesMod := modMap[`Batteries]? | warn false "Missing Batteries module!; Run `lake build`." let warned ← checkMissingImports `Batteries batteriesMod batteriesImports if autofix && warned then writeImportModule "Batteries.lean" batteriesImports match ← getWarningInfo with | (false, _) => pure () | (_, true) => IO.eprintln s!"Found errors that cannot be automatically fixed.\n\ Address unfixable issues and rerun lake build && ./scripts/updateBatteries.sh." | _ => if autofix then IO.eprintln s!"Found missing imports and attempted fixes.\n\ Run lake build && ./scripts/updateBatteries.sh to verify.\n\ Multiple runs may be needed." else IO.eprintln s!"Found missing imports.\n\ Run lake build && ./scripts/updateBatteries.sh to attempt automatic fixes." run_meta checkBatteriesDataImports ================================================ FILE: scripts/create-adaptation-pr.sh ================================================ #!/usr/bin/env bash # Make this script robust against unintentional errors. # See e.g. http://redsymbol.net/articles/unofficial-bash-strict-mode/ for explanation. set -euo pipefail IFS=$'\n\t' # We need to make the script robust against changes on disk # that might have happened during the script execution, e.g. from switching branches. # We do that by making sure the entire script is parsed before execution starts # using the following pattern # { # # script content # exit # } # (see https://stackoverflow.com/a/2358432). # So please do not delete the following line, or the final two lines of this script. { # Default values AUTO="no" # Function to display usage usage() { echo "Usage: $0 " echo " or" echo " $0 --bumpversion= --nightlydate= --nightlysha= [--auto=]" echo "BUMPVERSION: The upcoming release that we are targeting, e.g., 'v4.10.0'" echo "NIGHTLYDATE: The date of the nightly toolchain currently used on 'nightly-testing'" echo "NIGHTLYSHA: The SHA of the nightly toolchain that we want to adapt to" echo "AUTO: Optional flag to specify automatic mode, default is 'no'" exit 1 } # Parse arguments if [ $# -eq 2 ] && [[ $1 != --* ]] && [[ $2 != --* ]]; then BUMPVERSION=$1 NIGHTLYDATE=$2 elif [ $# -ge 2 ]; then for arg in "$@"; do case $arg in --bumpversion=*) BUMPVERSION="${arg#*=}" shift ;; --nightlydate=*) NIGHTLYDATE="${arg#*=}" shift ;; --nightlysha=*) NIGHTLYSHA="${arg#*=}" shift ;; --auto=*) AUTO="${arg#*=}" shift ;; *) usage ;; esac done else usage fi # Validate required arguments if [ -z "$BUMPVERSION" ] || [ -z "$NIGHTLYDATE" ]; then usage fi # Check if 'gh' command is available if ! command -v gh &> /dev/null; then echo "'gh' (GitHub CLI) is not installed. Please install it and try again." exit 1 fi echo "### Creating a PR for the nightly adaptation for $NIGHTLYDATE" echo echo "### [auto] save the current branch name" usr_branch=$(git branch --show-current) echo echo "### [auto] checkout main and pull the latest changes" git checkout main git pull echo echo "### [auto] checkout 'bump/$BUMPVERSION' and merge the latest changes from 'origin/main'" git checkout "bump/$BUMPVERSION" git pull git merge --no-edit origin/main || true # ignore error if there are conflicts # Check if there are merge conflicts if git diff --name-only --diff-filter=U | grep -q .; then echo echo "### [auto] Conflict resolution" echo "### Automatically choosing 'lean-toolchain' and 'lake-manifest.json' from the newer branch" echo "### In this case, the newer branch is 'bump/$BUMPVERSION'" git checkout "bump/$BUMPVERSION" -- lean-toolchain lake-manifest.json git add lean-toolchain lake-manifest.json # Check if there are more merge conflicts after auto-resolution if ! git diff --name-only --diff-filter=U | grep -q .; then # Auto-commit the resolved conflicts if no other conflicts remain git commit -m "Auto-resolved conflicts in lean-toolchain and lake-manifest.json" fi fi if git diff --name-only --diff-filter=U | grep -q . || ! git diff-index --quiet HEAD --; then if [ "$AUTO" = "yes" ]; then echo "Auto mode enabled. Bailing out due to unresolved conflicts or uncommitted changes." exit 1 fi fi # Loop until all conflicts are resolved and committed while git diff --name-only --diff-filter=U | grep -q . || ! git diff-index --quiet HEAD --; do echo echo "### [user] Conflict resolution" echo "We are merging the latest changes from 'origin/main' into 'bump/$BUMPVERSION'" echo "There seem to be conflicts or uncommitted files" echo "" echo " 1) Open $(pwd) in a new terminal and run 'git status'" echo " 2) Make sure to commit the resolved conflicts, but do not push them" read -rp " 3) Press enter to continue, when you are done" done echo "All conflicts resolved and committed." echo "Proceeding with git push..." git push echo echo "### [auto] create a new branch 'bump/nightly-$NIGHTLYDATE' and merge the latest changes from 'origin/nightly-testing'" git checkout -b "bump/nightly-$NIGHTLYDATE" || git checkout "bump/nightly-$NIGHTLYDATE" git merge --no-edit "$NIGHTLYSHA" || true # ignore error if there are conflicts # Check if there are merge conflicts if git diff --name-only --diff-filter=U | grep -q .; then echo echo "### [auto] Conflict resolution" echo "### Automatically choosing 'lean-toolchain' and 'lake-manifest.json' from 'nightly-testing'" git checkout "$NIGHTLYSHA" -- lean-toolchain lake-manifest.json git add lean-toolchain lake-manifest.json fi if git diff --name-only --diff-filter=U | grep -q .; then if [ "$AUTO" = "yes" ]; then echo "Auto mode enabled. Bailing out due to unresolved conflicts or uncommitted changes." exit 1 fi fi # Check if there are more merge conflicts if git diff --name-only --diff-filter=U | grep -q .; then echo echo "### [user] Conflict resolution" echo "We are merging the latest changes from 'origin/nightly-testing' into 'bump/nightly-$NIGHTLYDATE'" echo "Specifically, we are merging the following version of 'origin/nightly-testing':" echo "$NIGHTLYSHA" echo "There seem to be conflicts: please resolve them" echo "" echo " 1) Open $(pwd) in a new terminal and run 'git status'" echo " 2) Run 'git add' on the resolved files, but do not commit" read -rp " 3) Press enter to continue, when you are done" fi echo echo "### [auto] commit the changes and push the branch" pr_title="chore: adaptations for nightly-$NIGHTLYDATE" # Create a commit with the PR title # We allow an empty commit, # as the user might have inadvertently already committed changes # In general, we do not want this command to fail. git commit --allow-empty -m "$pr_title" git push --set-upstream origin "bump/nightly-$NIGHTLYDATE" # Check if there is a diff between bump/nightly-$NIGHTLYDATE and bump/$BUMPVERSION if git diff --name-only "bump/$BUMPVERSION" "bump/nightly-$NIGHTLYDATE" | grep -q .; then echo echo "### [auto] create a PR for the new branch" echo "Creating a pull request. Setting the base of the PR to 'bump/$BUMPVERSION'" echo "Running the following 'gh' command to do this:" gh_command="gh pr create -t \"$pr_title\" -b '' -B bump/$BUMPVERSION" echo "> $gh_command" gh_output=$(eval "$gh_command") # Extract the PR number from the output pr_number=$(echo "$gh_output" | sed 's/.*\/pull\/\([0-9]*\).*/\1/') echo echo "### [auto] post a link to the PR on Zulip" zulip_title="batteries#$pr_number adaptations for nightly-$NIGHTLYDATE" zulip_body=$(printf "> %s\n\nPlease review this PR. At the end of the month this diff will land in 'main'." "$pr_title batteries#$pr_number") echo "Posting the link to the PR in a new thread on the #nightly-testing-batteries channel on Zulip" echo "Here is the message:" echo "Title: $zulip_title" echo " Body: $zulip_body" if command -v zulip-send >/dev/null 2>&1; then zulip_command="zulip-send --stream nightly-testing-batteries --subject \"$zulip_title\" --message \"$zulip_body\"" echo "Running the following 'zulip-send' command to do this:" echo "> $zulip_command" eval "$zulip_command" else echo "Zulip CLI is not installed. Install it to send messages automatically." if [ "$AUTO" = "yes" ]; then exit 1 else echo "Please send the message manually." read -rp "Press enter to continue" fi fi # else, let the user know that no PR is needed else echo echo "### [auto] No PR needed" echo "The changes in 'bump/nightly-$NIGHTLYDATE' are the same as in 'bump/$BUMPVERSION'" echo "No PR is needed" fi echo echo "### [auto] checkout the 'nightly-testing' branch and merge the new branch into it" git checkout nightly-testing git pull git merge --no-edit "bump/nightly-$NIGHTLYDATE" || true # ignore error if there are conflicts # Check if there are merge conflicts if git diff --name-only --diff-filter=U | grep -q .; then echo echo "### [auto] Conflict resolution" echo "### Automatically choosing lean-toolchain and lake-manifest.json from the newer branch" echo "### In this case, the newer branch is 'bump/nightly-$NIGHTLYDATE'" git checkout "bump/nightly-$NIGHTLYDATE" -- lean-toolchain lake-manifest.json git add lean-toolchain lake-manifest.json # Check if there are more merge conflicts after auto-resolution if ! git diff --name-only --diff-filter=U | grep -q .; then # Auto-commit the resolved conflicts if no other conflicts remain git commit -m "Auto-resolved conflicts in lean-toolchain and lake-manifest.json" fi fi if git diff --name-only --diff-filter=U | grep -q . || ! git diff-index --quiet HEAD --; then if [ "$AUTO" = "yes" ]; then echo "Auto mode enabled. Bailing out due to unresolved conflicts or uncommitted changes." echo "PR has been created, and message posted to Zulip." echo "Error occurred while merging the new branch into 'nightly-testing'." exit 2 fi fi # Loop until all conflicts are resolved and committed while git diff --name-only --diff-filter=U | grep -q . || ! git diff-index --quiet HEAD --; do echo echo "### [user] Conflict resolution" echo "We are merging the new PR bump/nightly-$NIGHTLYDATE into 'nightly-testing'" echo "There seem to be conflicts or uncommitted files" echo "" echo " 1) Open $(pwd) in a new terminal and run 'git status'" echo " 2) Make sure to commit the resolved conflicts, but do not push them" read -rp " 3) Press enter to continue, when you are done" done echo "All conflicts resolved and committed." echo "Proceeding with git push..." git push echo echo "### [auto] finished: checkout the original branch" git checkout "$usr_branch" # These last two lines are needed to make the script robust against changes on disk # that might have happened during the script execution, e.g. from switching branches # See the top of the file for more details. exit } ================================================ FILE: scripts/lintWhitespace.sh ================================================ #!/bin/bash tmpfile=$(mktemp) issues_found=0 find Batteries -type f -name "*.lean" | while IFS= read -r file; do # Check for trailing whitespace and print line number if found while IFS=: read -r line_num line; do echo "Trailing whitespace found in $file at line $line_num: $line" echo 1 > "$tmpfile" done < <(grep -n "[[:blank:]]$" "$file") # Check if the last line ends with a new line if [ "$(tail -c 1 "$file" | od -c | awk 'NR==1 {print $2}')" != "\n" ]; then echo "Last line does not end with a new line in: $file" echo 1 > "$tmpfile" fi done if [ -f "$tmpfile" ]; then issues_found=$(<"$tmpfile") fi rm -f "$tmpfile" exit $issues_found ================================================ FILE: scripts/merge-lean-testing-pr.sh ================================================ #!/usr/bin/env bash set -eu # This scripts merges a `lean-pr-testing-NNNN` branch into `nightly-testing`. # This script is a copy of the same script in mathlib4, and should be kept in sync. # Note that Mathlib uses `lakefile.lean`, while Batteries uses `lakefile.toml` if [ "$#" -ne 1 ]; then echo "Usage: $0 " exit 1 fi PR_NUMBER=$1 BRANCH_NAME="lean-pr-testing-$PR_NUMBER" git checkout nightly-testing git pull --ff-only if ! git merge origin/$BRANCH_NAME; then echo "Merge conflicts detected. Resolving conflicts in favor of current version..." git checkout --ours lean-toolchain lakefile.toml lake-manifest.json git add lean-toolchain lakefile.toml lake-manifest.json fi sed "s/$BRANCH_NAME/nightly-testing/g" < lakefile.toml > lakefile.toml.new mv lakefile.toml.new lakefile.toml git add lakefile.toml # Check for merge conflicts if git ls-files -u | grep -q '^'; then echo "Merge conflicts detected. Please resolve conflicts manually." git status exit 1 fi if ! lake update; then echo "Lake update failed. Please resolve conflicts manually." git status exit 1 fi # Add files touched by lake update git add lakefile.toml lake-manifest.json # Attempt to commit. This will fail if there are conflicts. if git commit -m "merge $BRANCH_NAME"; then echo "Merge successful." # Note: This script does NOT push. The caller is responsible for pushing. # This allows the nightly_bump_and_merge.yml workflow to batch multiple # merges into a single push, avoiding spurious CI failures. exit 0 else echo "Merge failed. Please resolve conflicts manually." git status exit 1 fi ================================================ FILE: scripts/nolints.json ================================================ [["unusedArguments", "imp_intro"]] ================================================ FILE: scripts/noshake.json ================================================ {"ignoreImport": ["Init", "Lean"], "ignore": {"Batteries.Tactic.Lint.Simp": ["Batteries.Tactic.OpenPrivate", "Batteries.Util.LibraryNote"], "Batteries.Tactic.Exact": ["Batteries.Tactic.Alias"], "Batteries.Logic": ["Batteries.Tactic.Alias"], "Batteries.Linter.UnreachableTactic": ["Batteries.Tactic.Unreachable", "Lean.Parser.Syntax"], "Batteries.Lean.Util.EnvSearch": ["Batteries.Tactic.Lint.Misc"], "Batteries.Lean.Meta.Simp": ["Batteries.Tactic.OpenPrivate"], "Batteries.Data.UnionFind.Basic": ["Batteries.Tactic.Lint.Misc", "Batteries.Tactic.SeqFocus"], "Batteries.Data.String.Matcher": ["Batteries.Data.String.Basic"], "Batteries.Data.String.Lemmas": ["Batteries.Data.String.Basic", "Batteries.Tactic.Lint.Misc", "Std.Classes.Ord.String"], "Batteries.Data.Rat.Lemmas": ["Batteries.Tactic.SeqFocus"], "Batteries.Data.Range.Lemmas": ["Batteries.Tactic.Alias", "Batteries.Tactic.SeqFocus"], "Batteries.Data.RBMap.Lemmas": ["Batteries.Tactic.Basic"], "Batteries.Data.RBMap.Basic": ["Batteries.Tactic.Lint.Misc"], "Batteries.Data.Nat.Lemmas": ["Batteries.Tactic.Alias"], "Batteries.Data.Nat.Bisect": ["Batteries.Tactic.Basic"], "Batteries.Data.List.Lemmas": ["Batteries.Tactic.Alias"], "Batteries.Data.HashMap.Lemmas": ["Batteries.Tactic.Alias"], "Batteries.Data.HashMap.Basic": ["Batteries.Tactic.Alias"], "Batteries.Data.Fin.Lemmas": ["Batteries.Util.ProofWanted"], "Batteries.Data.Fin.Fold": ["Batteries.Tactic.Alias"], "Batteries.Data.Char.AsciiCasing": ["Batteries.Tactic.Basic"], "Batteries.Data.BitVec.Lemmas": ["Batteries.Tactic.Alias"], "Batteries.Data.Array.Pairwise": ["Batteries.Tactic.Alias"], "Batteries.Data.Array.Monadic": ["Batteries.Util.ProofWanted"], "Batteries.Data.Array.Lemmas": ["Batteries.Data.List.Lemmas"], "Batteries.Control.Nondet.Basic": ["Batteries.Tactic.Lint.Misc"], "Batteries.Control.Monad": ["Batteries.Tactic.Alias"], "Batteries.Control.AlternativeMonad": ["Batteries.Control.Lemmas"], "Batteries.CodeAction.Misc": ["Lean.Server.CodeActions.Provider"], "Batteries.Classes.Order": ["Batteries.Tactic.Basic", "Batteries.Tactic.SeqFocus"]}} ================================================ FILE: scripts/runLinter.lean ================================================ import Batteries.Tactic.Lint import Batteries.Data.Array.Basic import Lake.CLI.Main open Lean Core Elab Command Batteries.Tactic.Lint open System (FilePath) /-- The list of `nolints` pulled from the `nolints.json` file -/ abbrev NoLints := Array (Name × Name) /-- Read the given file path and deserialize it as JSON. -/ def readJsonFile (α) [FromJson α] (path : System.FilePath) : IO α := do let _ : MonadExceptOf String IO := ⟨throw ∘ IO.userError, fun x _ => x⟩ liftExcept <| fromJson? <|← liftExcept <| Json.parse <|← IO.FS.readFile path /-- Serialize the given value `a : α` to the file as JSON. -/ def writeJsonFile [ToJson α] (path : System.FilePath) (a : α) : IO Unit := IO.FS.writeFile path <| toJson a |>.pretty.push '\n' open Lake /-- Returns the root modules of `lean_exe` or `lean_lib` default targets in the Lake workspace. -/ def resolveDefaultRootModules : IO (Array Name) := do -- load the Lake workspace let (elanInstall?, leanInstall?, lakeInstall?) ← findInstall? let config ← MonadError.runEIO <| mkLoadConfig { elanInstall?, leanInstall?, lakeInstall? } let some workspace ← loadWorkspace config |>.toBaseIO | throw <| IO.userError "failed to load Lake workspace" -- build an array of all root modules of `lean_exe` and `lean_lib` default targets let defaultTargetModules := workspace.root.defaultTargets.flatMap fun target => if let some lib := workspace.root.findLeanLib? target then lib.roots else if let some exe := workspace.root.findLeanExe? target then #[exe.config.root] else #[] return defaultTargetModules /-- Arguments for `runLinter`. -/ structure LinterConfig where /-- Whether to update nolints. Default is `false`; set to `true` with `--update`. -/ updateNoLints : Bool := false /-- Whether to throw an error if necessary oleans are not already present (as opposed to building them). Default is `false`; set to `true` with `--no-build`. -/ noBuild : Bool := false /-- Whether to enable tracing. Default is `false`; set to `true` with `--trace` or `-v`. -/ trace := false @[always_inline, inline] private def Except.consError (e : ε) : Except (List ε) α → Except (List ε) α | Except.error errs => Except.error <| e :: errs | Except.ok _ => Except.error [e] /-- Parse args list for `runLinter` and return the config and specified module arguments. Default config settings are determined by the default values for fields of `LinterConfig`. Throws an exception if unable to parse the arguments. Returns `none` for the specified module if no modules are specified.-/ def parseLinterArgs (args : List String) : Except (List String) (LinterConfig × List Name) := go {} [] args where /-- Traverses the list, handling the non-flag elements as modules and erroring if parsing fails. -/ go (parsed : LinterConfig) (mods: List Name) : List String → Except (List String) (LinterConfig × List Name) | arg :: rest => if let some parsed := parseArg parsed arg then go parsed mods rest else match arg.toName with | .anonymous => Except.error [s!"could not parse argument '{arg}'"] | mod => go parsed (mod :: mods) rest | [] => Except.ok (parsed, mods.reverse) /-- Parses a single config argument. -/ parseArg (parsed : LinterConfig) : String → Option LinterConfig | "--update" => some { parsed with updateNoLints := true } | "--no-build" => some { parsed with noBuild := true } | "--trace" | "-v" => some { parsed with trace := true } | _ => none /-- Return an array of the modules to lint. If `specifiedModules` is not empty, return an array containing only `specifiedModule`. Otherwise, resolve the default root modules from the Lake workspace. -/ def determineModulesToLint (specifiedModules : List Name) : IO (Array Name) := do match specifiedModules with | [] => println!"Automatically detecting modules to lint" let defaultModules ← resolveDefaultRootModules println!"Default modules: {defaultModules}" return defaultModules | modules => println!"Running linter on specified modules: {modules}" return modules.toArray /-- Run the Batteries linter on a given module and update the linter if `update` is `true`. -/ unsafe def runLinterOnModule (cfg : LinterConfig) (module : Name) : IO Unit := do let { updateNoLints, noBuild, trace } := cfg initSearchPath (← findSysroot) let rec /-- Builds `module` if the filepath `olean` does not exist. Throws if olean is not found and `noBuild := true`. -/ buildIfNeeded (module : Name) : IO Unit := do let olean ← findOLean module unless (← olean.pathExists) do if noBuild then IO.eprintln s!"[{module}] Could not find olean for module `{module}` at given path:\n \ {olean}" IO.Process.exit 1 else if trace then IO.println s!"[{module}] Could not find olean for module `{module}` at given path:\n \ {olean}\n\ [{module}] Building `{module}`." -- run `lake build +module` (and ignore result) if the file hasn't been built yet let child ← IO.Process.spawn { cmd := (← IO.getEnv "LAKE").getD "lake" args := #["build", s!"+{module}"] stdin := .null } _ ← child.wait -- No need to trace on completion, lake's "Build completed successfully" reaches stdout buildIfNeeded module -- If the linter is being run on a target that doesn't import `Batteries.Tactic.List`, -- the linters are ineffective. So we import it here. let lintModule := `Batteries.Tactic.Lint buildIfNeeded lintModule let nolintsFile : FilePath := "scripts/nolints.json" let nolints ← if ← nolintsFile.pathExists then readJsonFile NoLints nolintsFile else pure #[] unsafe Lean.enableInitializersExecution let env ← importModules #[module, lintModule] {} (trustLevel := 1024) (loadExts := true) let mut opts : Options := {} -- Propagate `trace` to `CoreM` if trace then opts := opts.setBool `trace.Batteries.Lint true let ctx := { fileName := "" fileMap := default options := opts } let state := { env } Prod.fst <$> (CoreM.toIO · ctx state) do traceLint s!"Starting lint..." (inIO := true) (currentModule := module) let decls ← getDeclsInPackage module.getRoot let linters ← getChecks (slow := true) (runAlways := none) (runOnly := none) let results ← lintCore decls linters (inIO := true) (currentModule := module) if updateNoLints then traceLint s!"Updating nolints file at {nolintsFile}" (inIO := true) (currentModule := module) writeJsonFile (α := NoLints) nolintsFile <| .qsort (lt := fun (a, b) (c, d) => a.lt c || (a == c && b.lt d)) <| .flatten <| results.map fun (linter, decls) => decls.fold (fun res decl _ => res.push (linter.name, decl)) #[] if trace then let mut nolintTally : Std.HashMap Name Nat := {} for (linter, _) in nolints do nolintTally := nolintTally.alter linter fun | none => some 1 | some n => some (n+1) let msgs := nolintTally.toList.map fun (linter, n) => s!"{linter}: {n}" IO.println s!"[{module}] {nolintsFile} summary (number of nolints per linter):\n \ {"\n ".intercalate msgs}" let results := results.map fun (linter, decls) => .mk linter <| nolints.foldl (init := decls) fun decls (linter', decl') => if linter.name == linter' then decls.erase decl' else decls let failed := results.any (!·.2.isEmpty) if failed then let fmtResults ← formatLinterResults results decls (groupByFilename := true) (useErrorFormat := true) s!"in {module}" (runSlowLinters := true) .medium linters.size IO.print (← fmtResults.toString) IO.Process.exit 1 else IO.println s!"-- Linting passed for {module}." /-- Usage: `runLinter [--update] [--trace | -v] [--no-build] [Batteries.Data.Nat.Basic]...` Runs the linters on all declarations in the given modules (or all root modules of Lake `lean_lib` and `lean_exe` default targets if no module is specified). If `--update` is set, the `nolints` file is updated to remove any declarations that no longer need to be nolinted. If `--trace` (or, synonymously, `-v`) is set, tracing will be enabled and logged to stdout. If `--no-build` is set, `runLinter` will throw if either the oleans to be linted or the oleans which drive the linting itself are not present. -/ unsafe def main (args : List String) : IO Unit := do let linterArgs := parseLinterArgs args let (cfg, mods) ← match linterArgs with | Except.ok args => pure args | Except.error msgs => do IO.eprintln s!"Error parsing args:\n {"\n ".intercalate msgs}" IO.eprintln "Usage: \ runLinter [--update] [--trace | -v] [--no-build] [Batteries.Data.Nat.Basic]..." IO.Process.exit 1 let modulesToLint ← determineModulesToLint mods modulesToLint.forM <| runLinterOnModule cfg -- TODO: Remove manual Process.exit -- We are doing this to shortcut around a race in Lean's IO finalizers that we have observed in Mathlib CI -- (https://leanprover.zulipchat.com/#narrow/channel/287929-mathlib4/topic/slow.20linting.20step.20CI.3F/with/568830914) IO.Process.exit 0 ================================================ FILE: scripts/updateBatteries.sh ================================================ #!/bin/sh set -e # This command updates the `Batteries.lean` file to include a list of all files # in the `Batteries` directory. __LEAN_BATTERIES_AUTOFIX_IMPORTS=true lake env lean scripts/check_imports.lean