Compare commits

..

3 Commits

Author SHA1 Message Date
Kim Morrison
cdcb5780b9 fix 2025-01-12 20:57:26 +11:00
Kim Morrison
fa78cf7275 fix 2025-01-12 20:56:48 +11:00
Kim Morrison
f276a7c4db feat: lemma about Array.append 2025-01-12 19:40:22 +11:00
319 changed files with 1685 additions and 12986 deletions

View File

@@ -238,7 +238,7 @@ jobs:
"name": "Linux 32bit",
"os": "ubuntu-latest",
// Use 32bit on stage0 and stage1 to keep oleans compatible
"CMAKE_OPTIONS": "-DSTAGE0_USE_GMP=OFF -DSTAGE0_LEAN_EXTRA_CXX_FLAGS='-m32' -DSTAGE0_LEANC_OPTS='-m32' -DSTAGE0_MMAP=OFF -DUSE_GMP=OFF -DLEAN_EXTRA_CXX_FLAGS='-m32' -DLEANC_OPTS='-m32' -DMMAP=OFF -DLEAN_INSTALL_SUFFIX=-linux_x86 -DCMAKE_LIBRARY_PATH=/usr/lib/i386-linux-gnu/ -DSTAGE0_CMAKE_LIBRARY_PATH=/usr/lib/i386-linux-gnu/ -DPKG_CONFIG_EXECUTABLE=/usr/bin/i386-linux-gnu-pkg-config",
"CMAKE_OPTIONS": "-DSTAGE0_USE_GMP=OFF -DSTAGE0_LEAN_EXTRA_CXX_FLAGS='-m32' -DSTAGE0_LEANC_OPTS='-m32' -DSTAGE0_MMAP=OFF -DUSE_GMP=OFF -DLEAN_EXTRA_CXX_FLAGS='-m32' -DLEANC_OPTS='-m32' -DMMAP=OFF -DLEAN_INSTALL_SUFFIX=-linux_x86 -DCMAKE_LIBRARY_PATH=/usr/lib/i386-linux-gnu/ -DSTAGE0_CMAKE_LIBRARY_PATH=/usr/lib/i386-linux-gnu/",
"cmultilib": true,
"release": true,
"check-level": 2,
@@ -327,7 +327,7 @@ jobs:
run: |
sudo dpkg --add-architecture i386
sudo apt-get update
sudo apt-get install -y gcc-multilib g++-multilib ccache libuv1-dev:i386 pkgconf:i386
sudo apt-get install -y gcc-multilib g++-multilib ccache libuv1-dev:i386
if: matrix.cmultilib
- name: Cache
uses: actions/cache@v4

View File

@@ -18,9 +18,6 @@ foreach(var ${vars})
if("${var}" MATCHES "LLVM*")
list(APPEND STAGE0_ARGS "-D${var}=${${var}}")
endif()
if("${var}" MATCHES "PKG_CONFIG*")
list(APPEND STAGE0_ARGS "-D${var}=${${var}}")
endif()
elseif(("${var}" MATCHES "CMAKE_.*") AND NOT ("${var}" MATCHES "CMAKE_BUILD_TYPE") AND NOT ("${var}" MATCHES "CMAKE_HOME_DIRECTORY"))
list(APPEND PLATFORM_ARGS "-D${var}=${${var}}")
endif()

View File

@@ -33,9 +33,6 @@ Format of the commit message
- chore (maintain, ex: travis-ci)
- perf (performance improvement, optimization, ...)
Every `feat` or `fix` commit must have a `changelog-*` label, and a commit message
beginning with "This PR " that will be included in the changelog.
``<subject>`` has the following constraints:
- use imperative, present tense: "change" not "changed" nor "changes"
@@ -47,7 +44,6 @@ beginning with "This PR " that will be included in the changelog.
- just as in ``<subject>``, use imperative, present tense
- includes motivation for the change and contrasts with previous
behavior
- If a `changelog-*` label is present, the body must begin with "This PR ".
``<footer>`` is optional and may contain two items:
@@ -64,21 +60,17 @@ Examples
fix: add declarations for operator<<(std::ostream&, expr const&) and operator<<(std::ostream&, context const&) in the kernel
This PR adds declarations `operator<<` for raw printing.
The actual implementation of these two operators is outside of the
kernel. They are implemented in the file 'library/printer.cpp'.
We declare them in the kernel to prevent the following problem.
Suppose there is a file 'foo.cpp' that does not include 'library/printer.h',
kernel. They are implemented in the file 'library/printer.cpp'. We
declare them in the kernel to prevent the following problem. Suppose
there is a file 'foo.cpp' that does not include 'library/printer.h',
but contains
```cpp
expr a;
...
std::cout << a << "\n";
...
```
expr a;
...
std::cout << a << "\n";
...
The compiler does not generate an error message. It silently uses the
operator bool() to coerce the expression into a Boolean. This produces
counter-intuitive behavior, and may confuse developers.

View File

@@ -80,10 +80,3 @@ Unlike most Lean projects, all submodules of the `Lean` module begin with the
`prelude` keyword. This disables the automated import of `Init`, meaning that
developers need to figure out their own subset of `Init` to import. This is done
such that changing files in `Init` doesn't force a full rebuild of `Lean`.
### Testing against Mathlib/Batteries
You can test a Lean PR against Mathlib and Batteries by rebasing your PR
on to `nightly-with-mathlib` branch. (It is fine to force push after rebasing.)
CI will generate a branch of Mathlib and Batteries called `lean-pr-testing-NNNN`
that uses the toolchain for your PR, and will report back to the Lean PR with results from Mathlib CI.
See https://leanprover-community.github.io/contribute/tags_and_branches.html for more details.

View File

@@ -32,13 +32,12 @@ following to use `g++`.
cmake -DCMAKE_CXX_COMPILER=g++ ...
```
## Required Packages: CMake, GMP, libuv, pkgconf
## Required Packages: CMake, GMP, libuv
```bash
brew install cmake
brew install gmp
brew install libuv
brew install pkgconf
```
## Recommended Packages: CCache

View File

@@ -8,5 +8,5 @@ follow the [generic build instructions](index.md).
## Basic packages
```bash
sudo apt-get install git libgmp-dev libuv1-dev cmake ccache clang pkgconf
sudo apt-get install git libgmp-dev libuv1-dev cmake ccache clang
```

View File

@@ -28,7 +28,7 @@
stdenv = pkgs.overrideCC pkgs.stdenv lean-packages.llvmPackages.clang;
} ({
buildInputs = with pkgs; [
cmake gmp libuv ccache cadical pkg-config
cmake gmp libuv ccache cadical
lean-packages.llvmPackages.llvm # llvm-symbolizer for asan/lsan
gdb
tree # for CI

View File

@@ -1,12 +1,12 @@
{ src, debug ? false, stage0debug ? false, extraCMakeFlags ? [],
stdenv, lib, cmake, pkg-config, gmp, libuv, cadical, git, gnumake, bash, buildLeanPackage, writeShellScriptBin, runCommand, symlinkJoin, lndir, perl, gnused, darwin, llvmPackages, linkFarmFromDrvs,
stdenv, lib, cmake, gmp, libuv, cadical, git, gnumake, bash, buildLeanPackage, writeShellScriptBin, runCommand, symlinkJoin, lndir, perl, gnused, darwin, llvmPackages, linkFarmFromDrvs,
... } @ args:
with builtins;
lib.warn "The Nix-based build is deprecated" rec {
inherit stdenv;
sourceByRegex = p: rs: lib.sourceByRegex p (map (r: "(/src/)?${r}") rs);
buildCMake = args: stdenv.mkDerivation ({
nativeBuildInputs = [ cmake pkg-config ];
nativeBuildInputs = [ cmake ];
buildInputs = [ gmp libuv llvmPackages.llvm ];
# https://github.com/NixOS/nixpkgs/issues/60919
hardeningDisable = [ "all" ];

View File

@@ -1,69 +0,0 @@
#!/usr/bin/env python3
import sys
import subprocess
import requests
def main():
if len(sys.argv) != 4:
print("Usage: ./push_repo_release_tag.py <repo> <branch> <version_tag>")
sys.exit(1)
repo, branch, version_tag = sys.argv[1], sys.argv[2], sys.argv[3]
if branch not in {"master", "main"}:
print(f"Error: Branch '{branch}' is not 'master' or 'main'.")
sys.exit(1)
# Get the `lean-toolchain` file content
lean_toolchain_url = f"https://raw.githubusercontent.com/{repo}/{branch}/lean-toolchain"
try:
response = requests.get(lean_toolchain_url)
response.raise_for_status()
except requests.exceptions.RequestException as e:
print(f"Error fetching 'lean-toolchain' file: {e}")
sys.exit(1)
lean_toolchain_content = response.text.strip()
expected_prefix = "leanprover/lean4:"
if not lean_toolchain_content.startswith(expected_prefix) or lean_toolchain_content != f"{expected_prefix}{version_tag}":
print(f"Error: 'lean-toolchain' content does not match '{expected_prefix}{version_tag}'.")
sys.exit(1)
# Create and push the tag using `gh`
try:
# Check if the tag already exists
list_tags_cmd = ["gh", "api", f"repos/{repo}/git/matching-refs/tags/v4", "--jq", ".[].ref"]
list_tags_output = subprocess.run(list_tags_cmd, capture_output=True, text=True)
if list_tags_output.returncode == 0:
existing_tags = list_tags_output.stdout.strip().splitlines()
if f"refs/tags/{version_tag}" in existing_tags:
print(f"Error: Tag '{version_tag}' already exists.")
print("Existing tags starting with 'v4':")
for tag in existing_tags:
print(tag.replace("refs/tags/", ""))
sys.exit(1)
# Get the SHA of the branch
get_sha_cmd = [
"gh", "api", f"repos/{repo}/git/ref/heads/{branch}", "--jq", ".object.sha"
]
sha_result = subprocess.run(get_sha_cmd, capture_output=True, text=True, check=True)
sha = sha_result.stdout.strip()
# Create the tag
create_tag_cmd = [
"gh", "api", f"repos/{repo}/git/refs",
"-X", "POST",
"-F", f"ref=refs/tags/{version_tag}",
"-F", f"sha={sha}"
]
subprocess.run(create_tag_cmd, capture_output=True, text=True, check=True)
print(f"Successfully created and pushed tag '{version_tag}' to {repo}.")
except subprocess.CalledProcessError as e:
print(f"Error while creating/pushing tag: {e.stderr.strip() if e.stderr else e}")
sys.exit(1)
if __name__ == "__main__":
main()

View File

@@ -22,36 +22,6 @@ def get_github_token():
print("Warning: 'gh' CLI not found. Some API calls may be rate-limited.")
return None
def strip_rc_suffix(toolchain):
"""Remove -rcX suffix from the toolchain."""
return toolchain.split("-")[0]
def branch_exists(repo_url, branch, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/branches/{branch}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
response = requests.get(api_url, headers=headers)
return response.status_code == 200
def tag_exists(repo_url, tag_name, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/git/refs/tags/{tag_name}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
response = requests.get(api_url, headers=headers)
return response.status_code == 200
def release_page_exists(repo_url, tag_name, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/releases/tags/{tag_name}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
response = requests.get(api_url, headers=headers)
return response.status_code == 200
def get_release_notes(repo_url, tag_name, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/releases/tags/{tag_name}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
response = requests.get(api_url, headers=headers)
if response.status_code == 200:
return response.json().get("body", "").strip()
return None
def get_branch_content(repo_url, branch, file_path, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/contents/{file_path}?ref={branch}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
@@ -65,20 +35,11 @@ def get_branch_content(repo_url, branch, file_path, github_token):
return None
return None
def parse_version(version_str):
# Remove 'v' prefix and extract version and release candidate suffix
if ':' in version_str:
version_str = version_str.split(':')[1]
version = version_str.lstrip('v')
parts = version.split('-')
base_version = tuple(map(int, parts[0].split('.')))
rc_part = parts[1] if len(parts) > 1 and parts[1].startswith('rc') else None
rc_number = int(rc_part[2:]) if rc_part else float('inf') # Treat non-rc as higher than rc
return base_version + (rc_number,)
def is_version_gte(version1, version2):
"""Check if version1 >= version2, including proper handling of release candidates."""
return parse_version(version1) >= parse_version(version2)
def tag_exists(repo_url, tag_name, github_token):
api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/git/refs/tags/{tag_name}"
headers = {'Authorization': f'token {github_token}'} if github_token else {}
response = requests.get(api_url, headers=headers)
return response.status_code == 200
def is_merged_into_stable(repo_url, tag_name, stable_branch, github_token):
# First get the commit SHA for the tag
@@ -103,38 +64,23 @@ def is_merged_into_stable(repo_url, tag_name, stable_branch, github_token):
stable_commits = [commit['sha'] for commit in commits_response.json()]
return tag_sha in stable_commits
def parse_version(version_str):
# Remove 'v' prefix and split into components
# Handle Lean toolchain format (leanprover/lean4:v4.x.y)
if ':' in version_str:
version_str = version_str.split(':')[1]
version = version_str.lstrip('v')
# Handle release candidates by removing -rc part for comparison
version = version.split('-')[0]
return tuple(map(int, version.split('.')))
def is_version_gte(version1, version2):
"""Check if version1 >= version2"""
return parse_version(version1) >= parse_version(version2)
def is_release_candidate(version):
return "-rc" in version
def check_cmake_version(repo_url, branch, version_major, version_minor, github_token):
"""Verify the CMake version settings in src/CMakeLists.txt."""
cmake_file_path = "src/CMakeLists.txt"
content = get_branch_content(repo_url, branch, cmake_file_path, github_token)
if content is None:
print(f" ❌ Could not retrieve {cmake_file_path} from {branch}")
return False
expected_lines = [
f"set(LEAN_VERSION_MAJOR {version_major})",
f"set(LEAN_VERSION_MINOR {version_minor})",
f"set(LEAN_VERSION_PATCH 0)",
f"set(LEAN_VERSION_IS_RELEASE 1)"
]
for line in expected_lines:
if not any(l.strip().startswith(line) for l in content.splitlines()):
print(f" ❌ Missing or incorrect line in {cmake_file_path}: {line}")
return False
print(f" ✅ CMake version settings are correct in {cmake_file_path}")
return True
def extract_org_repo_from_url(repo_url):
"""Extract the 'org/repo' part from a GitHub URL."""
if repo_url.startswith("https://github.com/"):
return repo_url.replace("https://github.com/", "").rstrip("/")
return repo_url
def main():
github_token = get_github_token()
@@ -143,47 +89,6 @@ def main():
sys.exit(1)
toolchain = sys.argv[1]
stripped_toolchain = strip_rc_suffix(toolchain)
lean_repo_url = "https://github.com/leanprover/lean4"
# Preliminary checks
print("\nPerforming preliminary checks...")
# Check for branch releases/v4.Y.0
version_major, version_minor, _ = map(int, stripped_toolchain.lstrip('v').split('.'))
branch_name = f"releases/v{version_major}.{version_minor}.0"
if branch_exists(lean_repo_url, branch_name, github_token):
print(f" ✅ Branch {branch_name} exists")
# Check CMake version settings
check_cmake_version(lean_repo_url, branch_name, version_major, version_minor, github_token)
else:
print(f" ❌ Branch {branch_name} does not exist")
# Check for tag v4.X.Y(-rcZ)
if tag_exists(lean_repo_url, toolchain, github_token):
print(f" ✅ Tag {toolchain} exists")
else:
print(f" ❌ Tag {toolchain} does not exist.")
# Check for release page
if release_page_exists(lean_repo_url, toolchain, github_token):
print(f" ✅ Release page for {toolchain} exists")
# Check the first line of the release notes
release_notes = get_release_notes(lean_repo_url, toolchain, github_token)
if release_notes and release_notes.splitlines()[0].strip() == toolchain:
print(f" ✅ Release notes look good.")
else:
previous_minor_version = version_minor - 1
previous_stable_branch = f"releases/v{version_major}.{previous_minor_version}.0"
previous_release = f"v{version_major}.{previous_minor_version}.0"
print(f" ❌ Release notes not published. Please run `script/release_notes.py {previous_release}` on branch `{previous_stable_branch}`.")
else:
print(f" ❌ Release page for {toolchain} does not exist")
# Load repositories and perform further checks
print("\nChecking repositories...")
with open(os.path.join(os.path.dirname(__file__), "release_repos.yml")) as f:
repos = yaml.safe_load(f)["repositories"]
@@ -212,7 +117,7 @@ def main():
# Only check for tag if toolchain-tag is true
if check_tag:
if not tag_exists(url, toolchain, github_token):
print(f" ❌ Tag {toolchain} does not exist. Run `script/push_repo_release_tag.py {extract_org_repo_from_url(url)} {branch} {toolchain}`.")
print(f" ❌ Tag {toolchain} does not exist")
continue
print(f" ✅ Tag {toolchain} exists")

View File

@@ -295,15 +295,14 @@ index 5e8e0166..f3b29134 100644
PATCH_COMMAND git reset --hard HEAD && printf "${LIBUV_PATCH}" > patch.diff && git apply patch.diff
BUILD_IN_SOURCE ON
INSTALL_COMMAND "")
set(LIBUV_INCLUDE_DIRS "${CMAKE_BINARY_DIR}/libuv/src/libuv/include")
set(LIBUV_LDFLAGS "${CMAKE_BINARY_DIR}/libuv/src/libuv/libuv.a")
set(LIBUV_INCLUDE_DIR "${CMAKE_BINARY_DIR}/libuv/src/libuv/include")
set(LIBUV_LIBRARIES "${CMAKE_BINARY_DIR}/libuv/src/libuv/libuv.a")
else()
find_package(LibUV 1.0.0 REQUIRED)
endif()
include_directories(${LIBUV_INCLUDE_DIRS})
include_directories(${LIBUV_INCLUDE_DIR})
if(NOT LEAN_STANDALONE)
string(JOIN " " LIBUV_LDFLAGS ${LIBUV_LDFLAGS})
string(APPEND LEAN_EXTRA_LINKER_FLAGS " ${LIBUV_LDFLAGS}")
string(APPEND LEAN_EXTRA_LINKER_FLAGS " ${LIBUV_LIBRARIES}")
endif()
# Windows SDK (for ICU)

View File

@@ -161,10 +161,7 @@ def pop (a : Array α) : Array α where
| [] => rfl
| a::as => simp [pop, Nat.succ_sub_succ_eq_sub, size]
def replicate {α : Type u} (n : Nat) (v : α) : Array α where
toList := List.replicate n v
@[extern "lean_mk_array", deprecated replicate (since := "2025-01-16")]
@[extern "lean_mk_array"]
def mkArray {α : Type u} (n : Nat) (v : α) : Array α where
toList := List.replicate n v
@@ -579,12 +576,6 @@ def foldl {α : Type u} {β : Type v} (f : β → α → β) (init : β) (as : A
def foldr {α : Type u} {β : Type v} (f : α β β) (init : β) (as : Array α) (start := as.size) (stop := 0) : β :=
Id.run <| as.foldrM f init start stop
/-- Sum of an array.
`Array.sum #[a, b, c] = a + (b + (c + 0))` -/
def sum {α} [Add α] [Zero α] : Array α α :=
foldr (· + ·) 0
@[inline]
def map {α : Type u} {β : Type v} (f : α β) (as : Array α) : Array β :=
Id.run <| as.mapM f

View File

@@ -81,18 +81,12 @@ theorem foldrM_eq_reverse_foldlM_toList [Monad m] (f : α → β → m β) (init
@[simp] theorem toList_empty : (#[] : Array α).toList = [] := rfl
@[simp] theorem append_empty (as : Array α) : as ++ #[] = as := by
@[simp] theorem append_nil (as : Array α) : as ++ #[] = as := by
apply ext'; simp only [toList_append, toList_empty, List.append_nil]
@[deprecated append_empty (since := "2025-01-13")]
abbrev append_nil := @append_empty
@[simp] theorem empty_append (as : Array α) : #[] ++ as = as := by
@[simp] theorem nil_append (as : Array α) : #[] ++ as = as := by
apply ext'; simp only [toList_append, toList_empty, List.nil_append]
@[deprecated empty_append (since := "2025-01-13")]
abbrev nil_append := @empty_append
@[simp] theorem append_assoc (as bs cs : Array α) : as ++ bs ++ cs = as ++ (bs ++ cs) := by
apply ext'; simp only [toList_append, List.append_assoc]

View File

@@ -74,12 +74,12 @@ theorem findSome?_append {l₁ l₂ : Array α} : (l₁ ++ l₂).findSome? f = (
theorem getElem?_zero_flatten (L : Array (Array α)) :
(flatten L)[0]? = L.findSome? fun l => l[0]? := by
cases L using array_induction
cases L using array_array_induction
simp [ List.head?_eq_getElem?, List.head?_flatten, List.findSome?_map, Function.comp_def]
theorem getElem_zero_flatten.proof {L : Array (Array α)} (h : 0 < L.flatten.size) :
(L.findSome? fun l => l[0]?).isSome := by
cases L using array_induction
cases L using array_array_induction
simp only [List.findSome?_toArray, List.findSome?_map, Function.comp_def, List.getElem?_toArray,
List.findSome?_isSome_iff, isSome_getElem?]
simp only [flatten_toArray_map_toArray, size_toArray, List.length_flatten,
@@ -95,29 +95,24 @@ theorem getElem_zero_flatten {L : Array (Array α)} (h) :
theorem back?_flatten {L : Array (Array α)} :
(flatten L).back? = (L.findSomeRev? fun l => l.back?) := by
cases L using array_induction
cases L using array_array_induction
simp [List.getLast?_flatten, List.map_reverse, List.findSome?_map, Function.comp_def]
theorem findSome?_replicate : findSome? f (replicate n a) = if n = 0 then none else f a := by
theorem findSome?_mkArray : findSome? f (mkArray n a) = if n = 0 then none else f a := by
simp [ List.toArray_replicate, List.findSome?_replicate]
@[simp] theorem findSome?_replicate_of_pos (h : 0 < n) : findSome? f (replicate n a) = f a := by
simp [findSome?_replicate, Nat.ne_of_gt h]
@[simp] theorem findSome?_mkArray_of_pos (h : 0 < n) : findSome? f (mkArray n a) = f a := by
simp [findSome?_mkArray, Nat.ne_of_gt h]
-- Argument is unused, but used to decide whether `simp` should unfold.
@[simp] theorem findSome?_replicate_of_isSome (_ : (f a).isSome) :
findSome? f (replicate n a) = if n = 0 then none else f a := by
simp [findSome?_replicate]
@[simp] theorem findSome?_mkArray_of_isSome (_ : (f a).isSome) :
findSome? f (mkArray n a) = if n = 0 then none else f a := by
simp [findSome?_mkArray]
@[simp] theorem findSome?_replicate_of_isNone (h : (f a).isNone) :
findSome? f (replicate n a) = none := by
@[simp] theorem findSome?_mkArray_of_isNone (h : (f a).isNone) :
findSome? f (mkArray n a) = none := by
rw [Option.isNone_iff_eq_none] at h
simp [findSome?_replicate, h]
@[deprecated findSome?_replicate (since := "2025-01-16")] abbrev findSome?_mkArray := @findSome?_replicate
@[deprecated findSome?_replicate_of_pos (since := "2025-01-16")] abbrev findSome?_mkArray_of_pos := @findSome?_replicate_of_pos
@[deprecated findSome?_replicate_of_isSome (since := "2025-01-16")] abbrev findSome?_mkArray_of_isSome := @findSome?_replicate_of_isSome
@[deprecated findSome?_replicate_of_isNone (since := "2025-01-16")] abbrev findSome?_mkArray_of_isNone := @findSome?_replicate_of_isNone
simp [findSome?_mkArray, h]
/-! ### find? -/
@@ -208,7 +203,7 @@ theorem get_find?_mem {xs : Array α} (h) : (xs.find? p).get h ∈ xs := by
@[simp] theorem find?_flatten (xs : Array (Array α)) (p : α Bool) :
xs.flatten.find? p = xs.findSome? (·.find? p) := by
cases xs using array_induction
cases xs using array_array_induction
simp [List.findSome?_map, Function.comp_def]
theorem find?_flatten_eq_none {xs : Array (Array α)} {p : α Bool} :
@@ -225,7 +220,7 @@ theorem find?_flatten_eq_some {xs : Array (Array α)} {p : α → Bool} {a : α}
p a (as : Array (Array α)) (ys zs : Array α) (bs : Array (Array α)),
xs = as.push (ys.push a ++ zs) ++ bs
( a as, x a, !p x) ( x ys, !p x) := by
cases xs using array_induction
cases xs using array_array_induction
simp only [flatten_toArray_map_toArray, List.find?_toArray, List.find?_flatten_eq_some]
simp only [Bool.not_eq_eq_eq_not, Bool.not_true, exists_and_right, and_congr_right_iff]
intro w
@@ -249,42 +244,34 @@ theorem find?_flatMap_eq_none {xs : Array α} {f : α → Array β} {p : β →
(xs.flatMap f).find? p = none x xs, y f x, !p y := by
simp
theorem find?_replicate :
find? p (replicate n a) = if n = 0 then none else if p a then some a else none := by
theorem find?_mkArray :
find? p (mkArray n a) = if n = 0 then none else if p a then some a else none := by
simp [ List.toArray_replicate, List.find?_replicate]
@[simp] theorem find?_replicate_of_length_pos (h : 0 < n) :
find? p (replicate n a) = if p a then some a else none := by
simp [find?_replicate, Nat.ne_of_gt h]
@[simp] theorem find?_mkArray_of_length_pos (h : 0 < n) :
find? p (mkArray n a) = if p a then some a else none := by
simp [find?_mkArray, Nat.ne_of_gt h]
@[simp] theorem find?_replicate_of_pos (h : p a) :
find? p (replicate n a) = if n = 0 then none else some a := by
simp [find?_replicate, h]
@[simp] theorem find?_mkArray_of_pos (h : p a) :
find? p (mkArray n a) = if n = 0 then none else some a := by
simp [find?_mkArray, h]
@[simp] theorem find?_replicate_of_neg (h : ¬ p a) : find? p (replicate n a) = none := by
simp [find?_replicate, h]
@[simp] theorem find?_mkArray_of_neg (h : ¬ p a) : find? p (mkArray n a) = none := by
simp [find?_mkArray, h]
-- This isn't a `@[simp]` lemma since there is already a lemma for `l.find? p = none` for any `l`.
theorem find?_replicate_eq_none {n : Nat} {a : α} {p : α Bool} :
(replicate n a).find? p = none n = 0 !p a := by
theorem find?_mkArray_eq_none {n : Nat} {a : α} {p : α Bool} :
(mkArray n a).find? p = none n = 0 !p a := by
simp [ List.toArray_replicate, List.find?_replicate_eq_none, Classical.or_iff_not_imp_left]
@[simp] theorem find?_replicate_eq_some {n : Nat} {a b : α} {p : α Bool} :
(replicate n a).find? p = some b n 0 p a a = b := by
@[simp] theorem find?_mkArray_eq_some {n : Nat} {a b : α} {p : α Bool} :
(mkArray n a).find? p = some b n 0 p a a = b := by
simp [ List.toArray_replicate]
@[simp] theorem get_find?_replicate (n : Nat) (a : α) (p : α Bool) (h) :
((replicate n a).find? p).get h = a := by
@[simp] theorem get_find?_mkArray (n : Nat) (a : α) (p : α Bool) (h) :
((mkArray n a).find? p).get h = a := by
simp [ List.toArray_replicate]
@[deprecated find?_replicate (since := "2025-01-16")] abbrev find?_mkArray := @find?_replicate
@[deprecated find?_replicate_of_length_pos (since := "2025-01-16")] abbrev find?_mkArray_of_length_pos := @find?_replicate_of_length_pos
@[deprecated find?_replicate_of_pos (since := "2025-01-16")] abbrev find?_mkArray_of_pos := @find?_replicate_of_pos
@[deprecated find?_replicate_of_neg (since := "2025-01-16")] abbrev find?_mkArray_of_neg := @find?_replicate_of_neg
@[deprecated find?_replicate_eq_none (since := "2025-01-16")] abbrev find?_mkArray_eq_none := @find?_replicate_eq_none
@[deprecated find?_replicate_eq_some (since := "2025-01-16")] abbrev find?_mkArray_eq_some := @find?_replicate_eq_some
@[deprecated get_find?_mkArray (since := "2025-01-16")] abbrev get_find?_mkArray := @get_find?_replicate
theorem find?_pmap {P : α Prop} (f : (a : α) P a β) (xs : Array α)
(H : (a : α), a xs P a) (p : β Bool) :
(xs.pmap f H).find? p = (xs.attach.find? (fun a, m => p (f a (H a m)))).map fun a, m => f a (H a m) := by

View File

@@ -38,14 +38,6 @@ namespace Array
@[simp] theorem length_toList {l : Array α} : l.toList.length = l.size := rfl
theorem eq_toArray : v = List.toArray a v.toList = a := by
cases v
simp
theorem toArray_eq : List.toArray a = v a = v.toList := by
cases v
simp
/-! ### empty -/
@[simp] theorem empty_eq {xs : Array α} : #[] = xs xs = #[] := by
@@ -160,38 +152,31 @@ theorem exists_push_of_size_eq_add_one {xs : Array α} (h : xs.size = n + 1) :
theorem singleton_inj : #[a] = #[b] a = b := by
simp
/-! ### replicate -/
/-! ### mkArray -/
@[simp] theorem size_replicate (n : Nat) (v : α) : (replicate n v).size = n :=
@[simp] theorem size_mkArray (n : Nat) (v : α) : (mkArray n v).size = n :=
List.length_replicate ..
@[simp] theorem toList_replicate : (replicate n a).toList = List.replicate n a := by
simp only [replicate]
@[simp] theorem toList_mkArray : (mkArray n a).toList = List.replicate n a := by
simp only [mkArray]
@[simp] theorem replicate_zero : replicate 0 a = #[] := rfl
@[simp] theorem mkArray_zero : mkArray 0 a = #[] := rfl
theorem replicate_succ : replicate (n + 1) a = (replicate n a).push a := by
theorem mkArray_succ : mkArray (n + 1) a = (mkArray n a).push a := by
apply toList_inj.1
simp [List.replicate_succ']
theorem replicate_inj : replicate n a = replicate m b n = m (n = 0 a = b) := by
theorem mkArray_inj : mkArray n a = mkArray m b n = m (n = 0 a = b) := by
rw [ List.replicate_inj, toList_inj]
simp
@[simp] theorem getElem_replicate (n : Nat) (v : α) (h : i < (replicate n v).size) :
(replicate n v)[i] = v := by simp [ getElem_toList]
@[simp] theorem getElem_mkArray (n : Nat) (v : α) (h : i < (mkArray n v).size) :
(mkArray n v)[i] = v := by simp [ getElem_toList]
theorem getElem?_replicate (n : Nat) (v : α) (i : Nat) :
(replicate n v)[i]? = if i < n then some v else none := by
theorem getElem?_mkArray (n : Nat) (v : α) (i : Nat) :
(mkArray n v)[i]? = if i < n then some v else none := by
simp [getElem?_def]
@[deprecated size_replicate (since := "2025-01-16")] abbrev size_mkArray := @size_replicate
@[deprecated replicate_zero (since := "2025-01-16")] abbrev replicate_mkArray_zero := @replicate_zero
@[deprecated replicate_succ (since := "2025-01-16")] abbrev replicate_mkArray_succ := @replicate_succ
@[deprecated replicate_inj (since := "2025-01-16")] abbrev replicate_mkArray_inj := @replicate_inj
@[deprecated getElem_replicate (since := "2025-01-16")] abbrev getElem_mkArray := @getElem_replicate
@[deprecated getElem?_replicate (since := "2025-01-16")] abbrev getElem?_mkArray := @getElem?_replicate
/-! ## L[i] and L[i]? -/
@[simp] theorem getElem?_eq_none_iff {a : Array α} : a[i]? = none a.size i := by
@@ -271,11 +256,6 @@ theorem getElem?_push {a : Array α} {x} : (a.push x)[i]? = if i = a.size then s
theorem getElem?_singleton (a : α) (i : Nat) : #[a][i]? = if i = 0 then some a else none := by
simp [List.getElem?_singleton]
theorem ext_getElem? {l₁ l₂ : Array α} (h : i : Nat, l₁[i]? = l₂[i]?) : l₁ = l₂ := by
rcases l₁ with l₁
rcases l₂ with l₂
simpa using List.ext_getElem? (by simpa using h)
/-! ### mem -/
theorem not_mem_empty (a : α) : ¬ a #[] := by simp
@@ -969,17 +949,15 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
cases ys
simp [List.length_eq_of_beq (by simpa using h)]
@[simp] theorem replicate_beq_replicate [BEq α] {a b : α} {n : Nat} :
(replicate n a == replicate n b) = (n == 0 || a == b) := by
@[simp] theorem mkArray_beq_mkArray [BEq α] {a b : α} {n : Nat} :
(mkArray n a == mkArray n b) = (n == 0 || a == b) := by
cases n with
| zero => simp
| succ n =>
rw [replicate_succ, replicate_succ, push_beq_push, replicate_beq_replicate]
rw [mkArray_succ, mkArray_succ, push_beq_push, mkArray_beq_mkArray]
rw [Bool.eq_iff_iff]
simp +contextual
@[deprecated replicate_beq_replicate (since := "2025-01-16")] abbrev mkArray_beq_mkArray := @replicate_beq_replicate
private theorem beq_of_beq_singleton [BEq α] {a b : α} : #[a] == #[b] a == b := by
intro h
have : isEqv #[a] #[b] BEq.beq = true := h
@@ -1111,21 +1089,9 @@ theorem forall_mem_map {f : α → β} {l : Array α} {P : β → Prop} :
( (i) (_ : i l.map f), P i) (j) (_ : j l), P (f j) := by
simp
@[simp] theorem map_eq_empty_iff {f : α β} {l : Array α} : map f l = #[] l = #[] := by
cases l
simp
theorem eq_empty_of_map_eq_empty {f : α β} {l : Array α} (h : map f l = #[]) : l = #[] :=
map_eq_empty_iff.mp h
@[simp] theorem map_inj_left {f g : α β} : map f l = map g l a l, f a = g a := by
cases l <;> simp_all
theorem map_inj_right {f : α β} (w : x y, f x = f y x = y) : map f l = map f l' l = l' := by
cases l
cases l'
simp [List.map_inj_right w]
theorem map_congr_left (h : a l, f a = g a) : map f l = map g l :=
map_inj_left.2 h
@@ -1134,6 +1100,13 @@ theorem map_inj : map f = map g ↔ f = g := by
· intro h; ext a; replace h := congrFun h #[a]; simpa using h
· intro h; subst h; rfl
@[simp] theorem map_eq_empty_iff {f : α β} {l : Array α} : map f l = #[] l = #[] := by
cases l
simp
theorem eq_empty_of_map_eq_empty {f : α β} {l : Array α} (h : map f l = #[]) : l = #[] :=
map_eq_empty_iff.mp h
theorem map_eq_push_iff {f : α β} {l : Array α} {l₂ : Array β} {b : β} :
map f l = l₂.push b l₁ a, l = l₁.push a map f l₁ = l₂ f a = b := by
rcases l with l
@@ -1216,30 +1189,6 @@ theorem mapM_map_eq_foldl (as : Array α) (f : α → β) (i) :
rfl
termination_by as.size - i
/--
Use this as `induction ass using array₂_induction` on a hypothesis of the form `ass : Array (Array α)`.
The hypothesis `ass` will be replaced with a hypothesis `ass : List (List α)`,
and former appearances of `ass` in the goal will be replaced with `(ass.map List.toArray).toArray`.
-/
-- We can't use `@[cases_eliminator]` here as
-- `Lean.Meta.getCustomEliminator?` only looks at the top-level constant.
theorem array₂_induction (P : Array (Array α) Prop) (of : (xss : List (List α)), P (xss.map List.toArray).toArray)
(ass : Array (Array α)) : P ass := by
specialize of (ass.toList.map toList)
simpa [ toList_map, Function.comp_def, map_id] using of
/--
Use this as `induction ass using array₃_induction` on a hypothesis of the form `ass : Array (Array (Array α))`.
The hypothesis `ass` will be replaced with a hypothesis `ass : List (List (List α))`,
and former appearances of `ass` in the goal will be replaced with
`((ass.map (fun xs => xs.map List.toArray)).map List.toArray).toArray`.
-/
theorem array₃_induction (P : Array (Array (Array α)) Prop)
(of : (xss : List (List (List α))), P ((xss.map (fun xs => xs.map List.toArray)).map List.toArray).toArray)
(ass : Array (Array (Array α))) : P ass := by
specialize of ((ass.toList.map toList).map (fun as => as.map toList))
simpa [ toList_map, Function.comp_def, map_id] using of
/-! ### filter -/
@[congr]
@@ -1555,25 +1504,14 @@ theorem filterMap_eq_push_iff {f : α → Option β} {l : Array α} {l' : Array
· rintro l₁, a, l₂, h₁, h₂, h₃, h₄
refine l₂.reverse, a, l₁.reverse, by simp_all
/-! Content below this point has not yet been aligned with `List`. -/
/-! ### singleton -/
@[simp] theorem singleton_def (v : α) : Array.singleton v = #[v] := rfl
/-! ### append -/
@[simp] theorem size_append (as bs : Array α) : (as ++ bs).size = as.size + bs.size := by
simp only [size, toList_append, List.length_append]
@[simp] theorem append_push {as bs : Array α} {a : α} : as ++ bs.push a = (as ++ bs).push a := by
cases as
cases bs
simp
theorem toArray_append {xs : List α} {ys : Array α} :
xs.toArray ++ ys = (xs ++ ys.toList).toArray := by
rcases ys with ys
simp
@[simp] theorem toArray_eq_append_iff {xs : List α} {as bs : Array α} :
xs.toArray = as ++ bs xs = as.toList ++ bs.toList := by
cases as
@@ -1601,24 +1539,12 @@ theorem mem_append_left {a : α} {l₁ : Array α} (l₂ : Array α) (h : a ∈
theorem mem_append_right {a : α} (l₁ : Array α) {l₂ : Array α} (h : a l₂) : a l₁ ++ l₂ :=
mem_append.2 (Or.inr h)
theorem not_mem_append {a : α} {s t : Array α} (h₁ : a s) (h₂ : a t) : a s ++ t :=
mt mem_append.1 $ not_or.mpr h₁, h₂
@[simp] theorem size_append (as bs : Array α) : (as ++ bs).size = as.size + bs.size := by
simp only [size, toList_append, List.length_append]
/--
See also `eq_push_append_of_mem`, which proves a stronger version
in which the initial array must not contain the element.
-/
theorem append_of_mem {a : α} {l : Array α} (h : a l) : s t : Array α, l = s.push a ++ t := by
obtain s, t, w := List.append_of_mem (l := l.toList) (by simpa using h)
replace w := congrArg List.toArray w
refine s.toArray, t.toArray, by simp_all
theorem empty_append (as : Array α) : #[] ++ as = as := by simp
theorem mem_iff_append {a : α} {l : Array α} : a l s t : Array α, l = s.push a ++ t :=
append_of_mem, fun s, t, e => e by simp
theorem forall_mem_append {p : α Prop} {l₁ l₂ : Array α} :
( (x) (_ : x l₁ ++ l₂), p x) ( (x) (_ : x l₁), p x) ( (x) (_ : x l₂), p x) := by
simp only [mem_append, or_imp, forall_and]
theorem append_empty (as : Array α) : as ++ #[] = as := by simp
theorem getElem_append {as bs : Array α} (h : i < (as ++ bs).size) :
(as ++ bs)[i] = if h' : i < as.size then as[i] else bs[i - as.size]'(by simp at h; omega) := by
@@ -1673,478 +1599,6 @@ theorem getElem_of_append {l l₁ l₂ : Array α} (eq : l = l₁.push a ++ l₂
rw [ getElem?_eq_getElem, eq, getElem?_append_left (by simp; omega), h]
simp
@[simp 1100] theorem append_singleton {a : α} {as : Array α} : as ++ #[a] = as.push a := by
cases as
simp
theorem append_inj {s₁ s₂ t₁ t₂ : Array α} (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : s₁.size = s₂.size) :
s₁ = s₂ t₁ = t₂ := by
rcases s₁ with s₁
rcases s₂ with s₂
rcases t₁ with t₁
rcases t₂ with t₂
simpa using List.append_inj (by simpa using h) (by simpa using hl)
theorem append_inj_right {s₁ s₂ t₁ t₂ : Array α}
(h : s₁ ++ t₁ = s₂ ++ t₂) (hl : s₁.size = s₂.size) : t₁ = t₂ :=
(append_inj h hl).right
theorem append_inj_left {s₁ s₂ t₁ t₂ : Array α}
(h : s₁ ++ t₁ = s₂ ++ t₂) (hl : s₁.size = s₂.size) : s₁ = s₂ :=
(append_inj h hl).left
/-- Variant of `append_inj` instead requiring equality of the sizes of the second arrays. -/
theorem append_inj' {s₁ s₂ t₁ t₂ : Array α} (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : t₁.size = t₂.size) :
s₁ = s₂ t₁ = t₂ :=
append_inj h <| @Nat.add_right_cancel _ t₁.size _ <| by
let hap := congrArg size h; simp only [size_append, hl] at hap; exact hap
/-- Variant of `append_inj_right` instead requiring equality of the sizes of the second arrays. -/
theorem append_inj_right' {s₁ s₂ t₁ t₂ : Array α}
(h : s₁ ++ t₁ = s₂ ++ t₂) (hl : t₁.size = t₂.size) : t₁ = t₂ :=
(append_inj' h hl).right
/-- Variant of `append_inj_left` instead requiring equality of the sizes of the second arrays. -/
theorem append_inj_left' {s₁ s₂ t₁ t₂ : Array α}
(h : s₁ ++ t₁ = s₂ ++ t₂) (hl : t₁.size = t₂.size) : s₁ = s₂ :=
(append_inj' h hl).left
theorem append_right_inj {t₁ t₂ : Array α} (s) : s ++ t₁ = s ++ t₂ t₁ = t₂ :=
fun h => append_inj_right h rfl, congrArg _
theorem append_left_inj {s₁ s₂ : Array α} (t) : s₁ ++ t = s₂ ++ t s₁ = s₂ :=
fun h => append_inj_left' h rfl, congrArg (· ++ _)
@[simp] theorem append_left_eq_self {x y : Array α} : x ++ y = y x = #[] := by
rw [ append_left_inj (s₁ := x), empty_append]
@[simp] theorem self_eq_append_left {x y : Array α} : y = x ++ y x = #[] := by
rw [eq_comm, append_left_eq_self]
@[simp] theorem append_right_eq_self {x y : Array α} : x ++ y = x y = #[] := by
rw [ append_right_inj (t₁ := y), append_empty]
@[simp] theorem self_eq_append_right {x y : Array α} : x = x ++ y y = #[] := by
rw [eq_comm, append_right_eq_self]
@[simp] theorem append_eq_empty_iff : p ++ q = #[] p = #[] q = #[] := by
cases p <;> simp
@[simp] theorem empty_eq_append_iff : #[] = a ++ b a = #[] b = #[] := by
rw [eq_comm, append_eq_empty_iff]
theorem append_ne_empty_of_left_ne_empty {s : Array α} (h : s #[]) (t : Array α) :
s ++ t #[] := by
simp_all
theorem append_ne_empty_of_right_ne_empty (s : Array α) : t #[] s ++ t #[] := by
simp_all
theorem append_eq_push_iff {a b c : Array α} {x : α} :
a ++ b = c.push x (b = #[] a = c.push x) ( b', b = b'.push x c = a ++ b') := by
rcases a with a
rcases b with b
rcases c with c
simp only [List.append_toArray, List.push_toArray, mk.injEq, List.append_eq_append_iff,
toArray_eq_append_iff]
constructor
· rintro (a', rfl, rfl | b', rfl, h)
· right; exact a', by simp
· rw [List.singleton_eq_append_iff] at h
obtain (rfl, rfl | rfl, rfl) := h
· right; exact #[], by simp
· left; simp
· rintro (rfl, rfl | b', h, rfl)
· right; exact [x], by simp
· left; refine b'.toList, ?_
replace h := congrArg Array.toList h
simp_all
theorem push_eq_append_iff {a b c : Array α} {x : α} :
c.push x = a ++ b (b = #[] a = c.push x) ( b', b = b'.push x c = a ++ b') := by
rw [eq_comm, append_eq_push_iff]
theorem append_eq_singleton_iff {a b : Array α} {x : α} :
a ++ b = #[x] (a = #[] b = #[x]) (a = #[x] b = #[]) := by
rcases a with a
rcases b with b
simp only [List.append_toArray, mk.injEq, List.append_eq_singleton_iff, toArray_eq_append_iff]
theorem singleton_eq_append_iff {a b : Array α} {x : α} :
#[x] = a ++ b (a = #[] b = #[x]) (a = #[x] b = #[]) := by
rw [eq_comm, append_eq_singleton_iff]
theorem append_eq_append_iff {a b c d : Array α} :
a ++ b = c ++ d ( a', c = a ++ a' b = a' ++ d) c', a = c ++ c' d = c' ++ b := by
rcases a with a
rcases b with b
rcases c with c
rcases d with d
simp only [List.append_toArray, mk.injEq, List.append_eq_append_iff, toArray_eq_append_iff]
constructor
· rintro (a', rfl, rfl | c', rfl, rfl)
· left; exact a', by simp
· right; exact c', by simp
· rintro (a', rfl, rfl | c', rfl, rfl)
· left; exact a'.toList, by simp
· right; exact c'.toList, by simp
theorem set_append {s t : Array α} {i : Nat} {x : α} (h : i < (s ++ t).size) :
(s ++ t).set i x =
if h' : i < s.size then
s.set i x ++ t
else
s ++ t.set (i - s.size) x (by simp at h; omega) := by
rcases s with s
rcases t with t
simp only [List.append_toArray, List.set_toArray, List.set_append]
split <;> simp
@[simp] theorem set_append_left {s t : Array α} {i : Nat} {x : α} (h : i < s.size) :
(s ++ t).set i x (by simp; omega) = s.set i x ++ t := by
simp [set_append, h]
@[simp] theorem set_append_right {s t : Array α} {i : Nat} {x : α}
(h' : i < (s ++ t).size) (h : s.size i) :
(s ++ t).set i x = s ++ t.set (i - s.size) x (by simp at h'; omega) := by
rw [set_append, dif_neg (by omega)]
theorem setIfInBounds_append {s t : Array α} {i : Nat} {x : α} :
(s ++ t).setIfInBounds i x =
if i < s.size then
s.setIfInBounds i x ++ t
else
s ++ t.setIfInBounds (i - s.size) x := by
rcases s with s
rcases t with t
simp only [List.append_toArray, List.setIfInBounds_toArray, List.set_append]
split <;> simp
@[simp] theorem setIfInBounds_append_left {s t : Array α} {i : Nat} {x : α} (h : i < s.size) :
(s ++ t).setIfInBounds i x = s.setIfInBounds i x ++ t := by
simp [setIfInBounds_append, h]
@[simp] theorem setIfInBounds_append_right {s t : Array α} {i : Nat} {x : α} (h : s.size i) :
(s ++ t).setIfInBounds i x = s ++ t.setIfInBounds (i - s.size) x := by
rw [setIfInBounds_append, if_neg (by omega)]
theorem filterMap_eq_append_iff {f : α Option β} :
filterMap f l = L₁ ++ L₂ l₁ l₂, l = l₁ ++ l₂ filterMap f l₁ = L₁ filterMap f l₂ = L₂ := by
rcases l with l
rcases L₁ with L₁
rcases L₂ with L₂
simp only [size_toArray, List.filterMap_toArray', List.append_toArray, mk.injEq,
List.filterMap_eq_append_iff, toArray_eq_append_iff]
constructor
· rintro l₁, l₂, rfl, rfl, rfl
exact l₁, l₂, by simp
· rintro l₁, l₂, rfl, h₁, h₂
exact l₁, l₂, by simp_all
theorem append_eq_filterMap_iff {f : α Option β} :
L₁ ++ L₂ = filterMap f l
l₁ l₂, l = l₁ ++ l₂ filterMap f l₁ = L₁ filterMap f l₂ = L₂ := by
rw [eq_comm, filterMap_eq_append_iff]
@[simp] theorem map_append (f : α β) (l₁ l₂ : Array α) :
map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ := by
cases l₁
cases l₂
simp
theorem map_eq_append_iff {f : α β} :
map f l = L₁ ++ L₂ l₁ l₂, l = l₁ ++ l₂ map f l₁ = L₁ map f l₂ = L₂ := by
rw [ filterMap_eq_map, filterMap_eq_append_iff]
theorem append_eq_map_iff {f : α β} :
L₁ ++ L₂ = map f l l₁ l₂, l = l₁ ++ l₂ map f l₁ = L₁ map f l₂ = L₂ := by
rw [eq_comm, map_eq_append_iff]
/-! ### flatten -/
@[simp] theorem flatten_empty : (#[] : Array (Array α)).flatten = #[] := by simp [flatten]; rfl
@[simp] theorem toList_flatten {l : Array (Array α)} :
l.flatten.toList = (l.toList.map toList).flatten := by
dsimp [flatten]
simp only [ foldl_toList]
generalize l.toList = l
have : a : Array α, (List.foldl ?_ a l).toList = a.toList ++ ?_ := ?_
exact this #[]
induction l with
| nil => simp
| cons h => induction h.toList <;> simp [*]
@[simp] theorem flatten_map_toArray (l : List (List α)) :
(l.toArray.map List.toArray).flatten = l.flatten.toArray := by
apply ext'
simp [Function.comp_def]
@[simp] theorem flatten_toArray_map (l : List (List α)) :
(l.map List.toArray).toArray.flatten = l.flatten.toArray := by
rw [ flatten_map_toArray]
simp
theorem flatten_toArray (l : List (Array α)) :
l.toArray.flatten = (l.map Array.toList).flatten.toArray := by
apply ext'
simp
@[simp] theorem size_flatten (L : Array (Array α)) : L.flatten.size = (L.map size).sum := by
cases L using array₂_induction
simp [Function.comp_def]
@[simp] theorem flatten_singleton (l : Array α) : #[l].flatten = l := by simp [flatten]; rfl
theorem mem_flatten : {L : Array (Array α)}, a L.flatten l, l L a l := by
simp only [mem_def, toList_flatten, List.mem_flatten, List.mem_map]
intro l
constructor
· rintro _, s, m, rfl, h
exact s, m, h
· rintro s, h₁, h₂
refine s.toList, s, h₁, rfl, h₂
@[simp] theorem flatten_eq_empty_iff {L : Array (Array α)} : L.flatten = #[] l L, l = #[] := by
induction L using array₂_induction
simp
@[simp] theorem empty_eq_flatten_iff {L : Array (Array α)} : #[] = L.flatten l L, l = #[] := by
rw [eq_comm, flatten_eq_empty_iff]
theorem flatten_ne_empty_iff {xs : Array (Array α)} : xs.flatten #[] x, x xs x #[] := by
simp
theorem exists_of_mem_flatten : a flatten L l, l L a l := mem_flatten.1
theorem mem_flatten_of_mem (lL : l L) (al : a l) : a flatten L := mem_flatten.2 l, lL, al
theorem forall_mem_flatten {p : α Prop} {L : Array (Array α)} :
( (x) (_ : x flatten L), p x) (l) (_ : l L) (x) (_ : x l), p x := by
simp only [mem_flatten, forall_exists_index, and_imp]
constructor <;> (intros; solve_by_elim)
theorem flatten_eq_flatMap {L : Array (Array α)} : flatten L = L.flatMap id := by
induction L using array₂_induction
rw [flatten_toArray_map, List.flatten_eq_flatMap]
simp [List.flatMap_map]
@[simp] theorem map_flatten (f : α β) (L : Array (Array α)) :
(flatten L).map f = (map (map f) L).flatten := by
induction L using array₂_induction with
| of xss =>
simp only [flatten_toArray_map, List.map_toArray, List.map_flatten, List.map_map,
Function.comp_def]
rw [ Function.comp_def, List.map_map, flatten_toArray_map]
@[simp] theorem filterMap_flatten (f : α Option β) (L : Array (Array α)) :
filterMap f (flatten L) = flatten (map (filterMap f) L) := by
induction L using array₂_induction
simp only [flatten_toArray_map, size_toArray, List.length_flatten, List.filterMap_toArray',
List.filterMap_flatten, List.map_toArray, List.map_map, Function.comp_def]
rw [ Function.comp_def, List.map_map, flatten_toArray_map]
@[simp] theorem filter_flatten (p : α Bool) (L : Array (Array α)) :
filter p (flatten L) = flatten (map (filter p) L) := by
induction L using array₂_induction
simp only [flatten_toArray_map, size_toArray, List.length_flatten, List.filter_toArray',
List.filter_flatten, List.map_toArray, List.map_map, Function.comp_def]
rw [ Function.comp_def, List.map_map, flatten_toArray_map]
theorem flatten_filter_not_isEmpty {L : Array (Array α)} :
flatten (L.filter fun l => !l.isEmpty) = L.flatten := by
induction L using array₂_induction
simp [List.filter_map, Function.comp_def, List.flatten_filter_not_isEmpty]
theorem flatten_filter_ne_empty [DecidablePred fun l : Array α => l #[]] {L : Array (Array α)} :
flatten (L.filter fun l => l #[]) = L.flatten := by
simp only [ne_eq, isEmpty_iff, Bool.not_eq_true, Bool.decide_eq_false,
flatten_filter_not_isEmpty]
@[simp] theorem flatten_append (L₁ L₂ : Array (Array α)) :
flatten (L₁ ++ L₂) = flatten L₁ ++ flatten L₂ := by
induction L₁ using array₂_induction
induction L₂ using array₂_induction
simp [ List.map_append]
theorem flatten_push (L : Array (Array α)) (l : Array α) :
flatten (L.push l) = flatten L ++ l := by
induction L using array₂_induction
rcases l with l
have this : [l.toArray] = [l].map List.toArray := by simp
simp only [List.push_toArray, flatten_toArray_map, List.append_toArray]
rw [this, List.map_append, flatten_toArray_map]
simp
theorem flatten_flatten {L : Array (Array (Array α))} : flatten (flatten L) = flatten (map flatten L) := by
induction L using array₃_induction with
| of xss =>
rw [flatten_toArray_map]
have : (xss.map (fun xs => xs.map List.toArray)).flatten = xss.flatten.map List.toArray := by
induction xss with
| nil => simp
| cons xs xss ih =>
simp only [List.map_cons, List.flatten_cons, ih, List.map_append]
rw [this, flatten_toArray_map, List.flatten_flatten, List.map_toArray, Array.map_map,
List.map_toArray, map_map, Function.comp_def]
simp only [Function.comp_apply, flatten_toArray_map]
rw [List.map_toArray, Function.comp_def, List.map_map, flatten_toArray_map]
theorem flatten_eq_push_iff {xs : Array (Array α)} {ys : Array α} {y : α} :
xs.flatten = ys.push y
(as : Array (Array α)) (bs : Array α) (cs : Array (Array α)),
xs = as.push (bs.push y) ++ cs ( l, l cs l = #[]) ys = as.flatten ++ bs := by
induction xs using array₂_induction with
| of xs =>
rcases ys with ys
rw [flatten_toArray_map, List.push_toArray, mk.injEq, List.flatten_eq_append_iff]
constructor
· rintro (as, bs, rfl, rfl, h | as, bs, c, cs, ds, rfl, rfl, h)
· rw [List.singleton_eq_flatten_iff] at h
obtain xs, ys, rfl, h₁, h₂ := h
exact ((as ++ xs).map List.toArray).toArray, #[], (ys.map List.toArray).toArray, by simp,
by simpa using h₂, by rw [flatten_toArray_map]; simpa
· rw [List.singleton_eq_append_iff] at h
obtain (h₁, h₂ | h₁, h₂) := h
· simp at h₁
· simp at h₁ h₂
obtain rfl, rfl := h₁
exact (as.map List.toArray).toArray, bs.toArray, (ds.map List.toArray).toArray, by simpa
· rintro as, bs, cs, h₁, h₂, h₃
replace h₁ := congrArg (List.map Array.toList) (congrArg Array.toList h₁)
simp [Function.comp_def] at h₁
subst h₁
replace h₃ := congrArg Array.toList h₃
simp at h₃
subst h₃
right
exact (as.map Array.toList).toList, bs.toList, y, [], (cs.map Array.toList).toList, by simpa
theorem push_eq_flatten_iff {xs : Array (Array α)} {ys : Array α} {y : α} :
ys.push y = xs.flatten
(as : Array (Array α)) (bs : Array α) (cs : Array (Array α)),
xs = as.push (bs.push y) ++ cs ( l, l cs l = #[]) ys = as.flatten ++ bs := by
rw [eq_comm, flatten_eq_push_iff]
-- For now we omit `flatten_eq_append_iff`,
-- because it is not easily obtainable from `List.flatten_eq_append_iff`.
-- theorem flatten_eq_append_iff {xs : Array (Array α)} {ys zs : Array α} :
-- xs.flatten = ys ++ zs ↔
-- (∃ as bs, xs = as ++ bs ∧ ys = as.flatten ∧ zs = bs.flatten)
-- ∃ (as : Array (Array α)) (bs : Array α) (c : α) (cs : Array α) (ds : Array (Array α)),
-- xs = as.push ((bs.push c ++ cs)) ++ ds ∧ ys = as.flatten ++ bs.push c ∧
-- zs = cs ++ ds.flatten := by sorry
/-- Two arrays of subarrays are equal iff their flattens coincide, as well as the sizes of the
subarrays. -/
theorem eq_iff_flatten_eq {L L' : Array (Array α)} :
L = L' L.flatten = L'.flatten map size L = map size L' := by
cases L using array₂_induction with
| of L =>
cases L' using array₂_induction with
| of L' =>
simp [Function.comp_def, List.eq_iff_flatten_eq]
rw [List.map_inj_right]
simp +contextual
/-! ### flatMap -/
theorem flatMap_def (l : Array α) (f : α Array β) : l.flatMap f = flatten (map f l) := by
rcases l with l
simp [flatten_toArray, Function.comp_def, List.flatMap_def]
theorem flatMap_toList (l : Array α) (f : α List β) :
l.toList.flatMap f = (l.flatMap (fun a => (f a).toArray)).toList := by
rcases l with l
simp
@[simp] theorem flatMap_id (l : Array (Array α)) : l.flatMap id = l.flatten := by simp [flatMap_def]
@[simp] theorem flatMap_id' (l : Array (Array α)) : l.flatMap (fun a => a) = l.flatten := by simp [flatMap_def]
@[simp]
theorem size_flatMap (l : Array α) (f : α Array β) :
(l.flatMap f).size = sum (map (fun a => (f a).size) l) := by
rcases l with l
simp [Function.comp_def]
@[simp] theorem mem_flatMap {f : α Array β} {b} {l : Array α} : b l.flatMap f a, a l b f a := by
simp [flatMap_def, mem_flatten]
exact fun _, a, h₁, rfl, h₂ => a, h₁, h₂, fun a, h₁, h₂ => _, a, h₁, rfl, h₂
theorem exists_of_mem_flatMap {b : β} {l : Array α} {f : α Array β} :
b l.flatMap f a, a l b f a := mem_flatMap.1
theorem mem_flatMap_of_mem {b : β} {l : Array α} {f : α Array β} {a} (al : a l) (h : b f a) :
b l.flatMap f := mem_flatMap.2 a, al, h
@[simp]
theorem flatMap_eq_empty_iff {l : Array α} {f : α Array β} : l.flatMap f = #[] x l, f x = #[] := by
rw [flatMap_def, flatten_eq_empty_iff]
simp
theorem forall_mem_flatMap {p : β Prop} {l : Array α} {f : α Array β} :
( (x) (_ : x l.flatMap f), p x) (a) (_ : a l) (b) (_ : b f a), p b := by
simp only [mem_flatMap, forall_exists_index, and_imp]
constructor <;> (intros; solve_by_elim)
theorem flatMap_singleton (f : α Array β) (x : α) : #[x].flatMap f = f x := by
simp
@[simp] theorem flatMap_singleton' (l : Array α) : (l.flatMap fun x => #[x]) = l := by
rcases l with l
simp
@[simp] theorem flatMap_append (xs ys : Array α) (f : α Array β) :
(xs ++ ys).flatMap f = xs.flatMap f ++ ys.flatMap f := by
rcases xs with xs
rcases ys with ys
simp
theorem flatMap_assoc {α β} (l : Array α) (f : α Array β) (g : β Array γ) :
(l.flatMap f).flatMap g = l.flatMap fun x => (f x).flatMap g := by
rcases l with l
simp [List.flatMap_assoc, flatMap_toList]
theorem map_flatMap (f : β γ) (g : α Array β) (l : Array α) :
(l.flatMap g).map f = l.flatMap fun a => (g a).map f := by
rcases l with l
simp [List.map_flatMap]
theorem flatMap_map (f : α β) (g : β Array γ) (l : Array α) :
(map f l).flatMap g = l.flatMap (fun a => g (f a)) := by
rcases l with l
simp [List.flatMap_map]
theorem map_eq_flatMap {α β} (f : α β) (l : Array α) : map f l = l.flatMap fun x => #[f x] := by
simp only [ map_singleton]
rw [ flatMap_singleton' l, map_flatMap, flatMap_singleton']
theorem filterMap_flatMap {β γ} (l : Array α) (g : α Array β) (f : β Option γ) :
(l.flatMap g).filterMap f = l.flatMap fun a => (g a).filterMap f := by
rcases l with l
simp [List.filterMap_flatMap]
theorem filter_flatMap (l : Array α) (g : α Array β) (f : β Bool) :
(l.flatMap g).filter f = l.flatMap fun a => (g a).filter f := by
rcases l with l
simp [List.filter_flatMap]
theorem flatMap_eq_foldl (f : α Array β) (l : Array α) :
l.flatMap f = l.foldl (fun acc a => acc ++ f a) #[] := by
rcases l with l
simp only [List.flatMap_toArray, List.flatMap_eq_foldl, size_toArray, List.foldl_toArray']
suffices l', (List.foldl (fun acc a => acc ++ (f a).toList) l' l).toArray =
List.foldl (fun acc a => acc ++ f a) l'.toArray l by
simpa using this []
induction l with
| nil => simp
| cons a l ih =>
intro l'
simp [ih ((l' ++ (f a).toList)), toArray_append]
/-! Content below this point has not yet been aligned with `List`. -/
-- This is a duplicate of `List.toArray_toList`.
-- It's confusing to guess which namespace this theorem should live in,
@@ -2758,6 +2212,28 @@ theorem getElem?_modify {as : Array α} {i : Nat} {f : αα} {j : Nat} :
theorem size_empty : (#[] : Array α).size = 0 := rfl
/-! ### flatten -/
@[simp] theorem toList_flatten {l : Array (Array α)} :
l.flatten.toList = (l.toList.map toList).flatten := by
dsimp [flatten]
simp only [ foldl_toList]
generalize l.toList = l
have : a : Array α, (List.foldl ?_ a l).toList = a.toList ++ ?_ := ?_
exact this #[]
induction l with
| nil => simp
| cons h => induction h.toList <;> simp [*]
theorem mem_flatten : {L : Array (Array α)}, a L.flatten l, l L a l := by
simp only [mem_def, toList_flatten, List.mem_flatten, List.mem_map]
intro l
constructor
· rintro _, s, m, rfl, h
exact s, m, h
· rintro s, h₁, h₂
refine s.toList, s, h₁, rfl, h₂
/-! ### extract -/
theorem extract_loop_zero (as bs : Array α) (start : Nat) : extract.loop as 0 start bs = bs := by
@@ -2774,16 +2250,16 @@ theorem extract_loop_of_ge (as bs : Array α) (size start : Nat) (h : start ≥
theorem extract_loop_eq_aux (as bs : Array α) (size start : Nat) :
extract.loop as size start bs = bs ++ extract.loop as size start #[] := by
induction size using Nat.recAux generalizing start bs with
| zero => rw [extract_loop_zero, extract_loop_zero, append_empty]
| zero => rw [extract_loop_zero, extract_loop_zero, append_nil]
| succ size ih =>
if h : start < as.size then
rw [extract_loop_succ (h:=h), ih (bs.push _), push_eq_append_singleton]
rw [extract_loop_succ (h:=h), ih (#[].push _), push_eq_append_singleton, empty_append]
rw [extract_loop_succ (h:=h), ih (#[].push _), push_eq_append_singleton, nil_append]
rw [append_assoc]
else
rw [extract_loop_of_ge (h:=Nat.le_of_not_lt h)]
rw [extract_loop_of_ge (h:=Nat.le_of_not_lt h)]
rw [append_empty]
rw [append_nil]
theorem extract_loop_eq (as bs : Array α) (size start : Nat) (h : start + size as.size) :
extract.loop as size start bs = bs ++ as.extract start (start + size) := by
@@ -3139,6 +2615,11 @@ namespace Array
/-! ### map -/
theorem array_array_induction (P : Array (Array α) Prop) (h : (xss : List (List α)), P (xss.map List.toArray).toArray)
(ass : Array (Array α)) : P ass := by
specialize h (ass.toList.map toList)
simpa [ toList_map, Function.comp_def, map_id] using h
theorem foldl_map (f : β₁ β₂) (g : α β₂ α) (l : Array β₁) (init : α) :
(l.map f).foldl g init = l.foldl (fun x y => g x (f y)) init := by
cases l; simp [List.foldl_map]
@@ -3175,6 +2656,8 @@ theorem foldr_map' (g : α → β) (f : ααα) (f' : β → β → β
/-! ### flatten -/
@[simp] theorem flatten_empty : flatten (#[] : Array (Array α)) = #[] := rfl
@[simp] theorem flatten_toArray_map_toArray (xss : List (List α)) :
(xss.map List.toArray).toArray.flatten = xss.flatten.toArray := by
simp [flatten]
@@ -3185,54 +2668,12 @@ theorem foldr_map' (g : α → β) (f : ααα) (f' : β → β → β
| nil => simp
| cons xs xss ih => simp [ih]
/-! ### sum -/
/-! ### mkArray -/
theorem sum_eq_sum_toList [Add α] [Zero α] (as : Array α) : as.sum = as.toList.sum := by
cases as
simp [Array.sum, List.sum]
/-! ### replicate -/
theorem eq_replicate_of_mem {a : α} {l : Array α} (h : (b) (_ : b l), b = a) : l = replicate l.size a := by
rcases l with l
have := List.eq_replicate_of_mem (by simpa using h)
rw [this]
@[simp] theorem mem_mkArray (a : α) (n : Nat) : b mkArray n a n 0 b = a := by
rw [mkArray, mem_toArray]
simp
theorem eq_replicate_iff {a : α} {n} {l : Array α} :
l = replicate n a l.size = n (b) (_ : b l), b = a := by
rcases l with l
simp [ List.eq_replicate_iff, toArray_eq]
theorem map_eq_replicate_iff {l : Array α} {f : α β} {b : β} :
l.map f = replicate l.size b x l, f x = b := by
simp [eq_replicate_iff]
@[simp] theorem mem_replicate (a : α) (n : Nat) : b replicate n a n 0 b = a := by
rw [replicate, mem_toArray]
simp
@[simp] theorem map_const (l : Array α) (b : β) : map (Function.const α b) l = replicate l.size b :=
map_eq_replicate_iff.mpr fun _ _ => rfl
@[simp] theorem map_const_fun (x : β) : map (Function.const α x) = (replicate ·.size x) := by
funext l
simp
/-- Variant of `map_const` using a lambda rather than `Function.const`. -/
-- This can not be a `@[simp]` lemma because it would fire on every `Array.map`.
theorem map_const' (l : Array α) (b : β) : map (fun _ => b) l = replicate l.size b :=
map_const l b
@[simp] theorem sum_replicate_nat (n : Nat) (a : Nat) : (replicate n a).sum = n * a := by
simp [sum_eq_sum_toList, List.sum_replicate_nat]
@[deprecated eq_replicate_of_mem (since := "2025-01-16")] abbrev eq_mkArray_of_mem := @eq_replicate_of_mem
@[deprecated eq_replicate_iff (since := "2025-01-16")] abbrev eq_mkArray_iff := @eq_replicate_iff
@[deprecated map_eq_replicate_iff (since := "2025-01-16")] abbrev map_eq_mkArray_iff := @map_eq_replicate_iff
@[deprecated mem_replicate (since := "2025-01-16")] abbrev mem_mkArray := @mem_replicate
@[deprecated sum_replicate_nat (since := "2025-01-16")] abbrev sum_mkArray_nat := @sum_replicate_nat
/-! ### reverse -/
@[simp] theorem mem_reverse {x : α} {as : Array α} : x as.reverse x as := by

View File

@@ -3539,7 +3539,7 @@ theorem getLsbD_intMax (w : Nat) : (intMax w).getLsbD i = decide (i + 1 < w) :=
/-! ### Non-overflow theorems -/
/-- If `x.toNat + y.toNat < 2^w`, then the addition `(x + y)` does not overflow. -/
/-- If `x.toNat * y.toNat < 2^w`, then the multiplication `(x * y)` does not overflow. -/
theorem toNat_add_of_lt {w} {x y : BitVec w} (h : x.toNat + y.toNat < 2^w) :
(x + y).toNat = x.toNat + y.toNat := by
rw [BitVec.toNat_add, Nat.mod_eq_of_lt h]

View File

@@ -606,11 +606,11 @@ set_option linter.missingDocs false in
to get a list of lists, and then concatenates them all together.
* `[2, 3, 2].bind range = [0, 1, 0, 1, 2, 0, 1]`
-/
@[inline] def flatMap {α : Type u} {β : Type v} (b : α List β) (a : List α) : List β := flatten (map b a)
@[inline] def flatMap {α : Type u} {β : Type v} (a : List α) (b : α List β) : List β := flatten (map b a)
@[simp] theorem flatMap_nil (f : α List β) : List.flatMap f [] = [] := by simp [flatten, List.flatMap]
@[simp] theorem flatMap_nil (f : α List β) : List.flatMap [] f = [] := by simp [flatten, List.flatMap]
@[simp] theorem flatMap_cons x xs (f : α List β) :
List.flatMap f (x :: xs) = f x ++ List.flatMap f xs := by simp [flatten, List.flatMap]
List.flatMap (x :: xs) f = f x ++ List.flatMap xs f := by simp [flatten, List.flatMap]
set_option linter.missingDocs false in
@[deprecated flatMap (since := "2024-10-16")] abbrev bind := @flatMap

View File

@@ -96,14 +96,14 @@ The following operations are given `@[csimp]` replacements below:
/-! ### flatMap -/
/-- Tail recursive version of `List.flatMap`. -/
@[inline] def flatMapTR (f : α List β) (as : List α) : List β := go as #[] where
@[inline] def flatMapTR (as : List α) (f : α List β) : List β := go as #[] where
/-- Auxiliary for `flatMap`: `flatMap.go f as = acc.toList ++ bind f as` -/
@[specialize] go : List α Array β List β
| [], acc => acc.toList
| x::xs, acc => go xs (acc ++ f x)
@[csimp] theorem flatMap_eq_flatMapTR : @List.flatMap = @flatMapTR := by
funext α β f as
funext α β as f
let rec go : as acc, flatMapTR.go f as acc = acc.toList ++ as.flatMap f
| [], acc => by simp [flatMapTR.go, flatMap]
| x::xs, acc => by simp [flatMapTR.go, flatMap, go xs]
@@ -112,7 +112,7 @@ The following operations are given `@[csimp]` replacements below:
/-! ### flatten -/
/-- Tail recursive version of `List.flatten`. -/
@[inline] def flattenTR (l : List (List α)) : List α := l.flatMapTR id
@[inline] def flattenTR (l : List (List α)) : List α := flatMapTR l id
@[csimp] theorem flatten_eq_flattenTR : @flatten = @flattenTR := by
funext α l; rw [ List.flatMap_id, List.flatMap_eq_flatMapTR]; rfl

View File

@@ -1076,31 +1076,9 @@ theorem forall_mem_map {f : α → β} {l : List α} {P : β → Prop} :
@[deprecated forall_mem_map (since := "2024-07-25")] abbrev forall_mem_map_iff := @forall_mem_map
@[simp] theorem map_eq_nil_iff {f : α β} {l : List α} : map f l = [] l = [] := by
constructor <;> exact fun _ => match l with | [] => rfl
@[deprecated map_eq_nil_iff (since := "2024-09-05")] abbrev map_eq_nil := @map_eq_nil_iff
theorem eq_nil_of_map_eq_nil {f : α β} {l : List α} (h : map f l = []) : l = [] :=
map_eq_nil_iff.mp h
@[simp] theorem map_inj_left {f g : α β} : map f l = map g l a l, f a = g a := by
induction l <;> simp_all
theorem map_inj_right {f : α β} (w : x y, f x = f y x = y) : map f l = map f l' l = l' := by
induction l generalizing l' with
| nil => simp
| cons a l ih =>
simp only [map_cons]
cases l' with
| nil => simp
| cons a' l' =>
simp only [map_cons, cons.injEq, ih, and_congr_left_iff]
intro h
constructor
· apply w
· simp +contextual
theorem map_congr_left (h : a l, f a = g a) : map f l = map g l :=
map_inj_left.2 h
@@ -1109,6 +1087,14 @@ theorem map_inj : map f = map g ↔ f = g := by
· intro h; ext a; replace h := congrFun h [a]; simpa using h
· intro h; subst h; rfl
@[simp] theorem map_eq_nil_iff {f : α β} {l : List α} : map f l = [] l = [] := by
constructor <;> exact fun _ => match l with | [] => rfl
@[deprecated map_eq_nil_iff (since := "2024-09-05")] abbrev map_eq_nil := @map_eq_nil_iff
theorem eq_nil_of_map_eq_nil {f : α β} {l : List α} (h : map f l = []) : l = [] :=
map_eq_nil_iff.mp h
theorem map_eq_cons_iff {f : α β} {l : List α} :
map f l = b :: l₂ a l₁, l = a :: l₁ f a = b map f l₁ = l₂ := by
cases l
@@ -1508,34 +1494,6 @@ theorem filterMap_eq_cons_iff {l} {b} {bs} :
@[simp] theorem cons_append_fun (a : α) (as : List α) :
(fun bs => ((a :: as) ++ bs)) = fun bs => a :: (as ++ bs) := rfl
@[simp] theorem mem_append {a : α} {s t : List α} : a s ++ t a s a t := by
induction s <;> simp_all [or_assoc]
theorem not_mem_append {a : α} {s t : List α} (h₁ : a s) (h₂ : a t) : a s ++ t :=
mt mem_append.1 $ not_or.mpr h₁, h₂
@[deprecated mem_append (since := "2025-01-13")]
theorem mem_append_eq (a : α) (s t : List α) : (a s ++ t) = (a s a t) :=
propext mem_append
@[deprecated mem_append_left (since := "2024-11-20")] abbrev mem_append_of_mem_left := @mem_append_left
@[deprecated mem_append_right (since := "2024-11-20")] abbrev mem_append_of_mem_right := @mem_append_right
/--
See also `eq_append_cons_of_mem`, which proves a stronger version
in which the initial list must not contain the element.
-/
theorem append_of_mem {a : α} {l : List α} : a l s t : List α, l = s ++ a :: t
| .head l => [], l, rfl
| .tail b h => let s, t, h' := append_of_mem h; b::s, t, by rw [h', cons_append]
theorem mem_iff_append {a : α} {l : List α} : a l s t : List α, l = s ++ a :: t :=
append_of_mem, fun s, t, e => e by simp
theorem forall_mem_append {p : α Prop} {l₁ l₂ : List α} :
( (x) (_ : x l₁ ++ l₂), p x) ( (x) (_ : x l₁), p x) ( (x) (_ : x l₂), p x) := by
simp only [mem_append, or_imp, forall_and]
theorem getElem_append {l₁ l₂ : List α} (i : Nat) (h : i < (l₁ ++ l₂).length) :
(l₁ ++ l₂)[i] = if h' : i < l₁.length then l₁[i] else l₂[i - l₁.length]'(by simp at h h'; exact Nat.sub_lt_left_of_lt_add h' h) := by
split <;> rename_i h'
@@ -1603,6 +1561,14 @@ theorem get_of_append {l : List α} (eq : l = l₁ ++ a :: l₂) (h : l₁.lengt
l.get i, get_of_append_proof eq h = a := Option.some.inj <| by
rw [ get?_eq_get, eq, get?_append_right (h Nat.le_refl _), h, Nat.sub_self]; rfl
/--
See also `eq_append_cons_of_mem`, which proves a stronger version
in which the initial list must not contain the element.
-/
theorem append_of_mem {a : α} {l : List α} : a l s t : List α, l = s ++ a :: t
| .head l => [], l, rfl
| .tail b h => let s, t, h' := append_of_mem h; b::s, t, by rw [h', cons_append]
@[simp 1100] theorem singleton_append : [x] ++ l = x :: l := rfl
theorem append_inj :
@@ -1619,8 +1585,8 @@ theorem append_inj_left (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length s₁ = le
/-- Variant of `append_inj` instead requiring equality of the lengths of the second lists. -/
theorem append_inj' (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length t₁ = length t₂) : s₁ = s₂ t₁ = t₂ :=
append_inj h <| @Nat.add_right_cancel _ t₁.length _ <| by
let hap := congrArg length h; simp only [length_append, hl] at hap; exact hap
append_inj h <| @Nat.add_right_cancel _ (length t₁) _ <| by
let hap := congrArg length h; simp only [length_append, hl] at hap; exact hap
/-- Variant of `append_inj_right` instead requiring equality of the lengths of the second lists. -/
theorem append_inj_right' (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length t₁ = length t₂) : t₁ = t₂ :=
@@ -1648,6 +1614,9 @@ theorem append_left_inj {s₁ s₂ : List α} (t) : s₁ ++ t = s₂ ++ t ↔ s
@[simp] theorem self_eq_append_right {x y : List α} : x = x ++ y y = [] := by
rw [eq_comm, append_right_eq_self]
@[simp] theorem append_eq_nil : p ++ q = [] p = [] q = [] := by
cases p <;> simp
theorem getLast_concat {a : α} : (l : List α), getLast (l ++ [a]) (by simp) = a
| [] => rfl
| a::t => by
@@ -1673,54 +1642,6 @@ theorem get?_append {l₁ l₂ : List α} {n : Nat} (hn : n < l₁.length) :
(l₁ ++ l₂).get? n = l₁.get? n := by
simp [getElem?_append_left hn]
@[simp] theorem append_eq_nil_iff : p ++ q = [] p = [] q = [] := by
cases p <;> simp
@[deprecated append_eq_nil_iff (since := "2025-01-13")] abbrev append_eq_nil := @append_eq_nil_iff
@[simp] theorem nil_eq_append_iff : [] = a ++ b a = [] b = [] := by
rw [eq_comm, append_eq_nil_iff]
@[deprecated nil_eq_append_iff (since := "2024-07-24")] abbrev nil_eq_append := @nil_eq_append_iff
theorem append_ne_nil_of_left_ne_nil {s : List α} (h : s []) (t : List α) : s ++ t [] := by simp_all
theorem append_ne_nil_of_right_ne_nil (s : List α) : t [] s ++ t [] := by simp_all
@[deprecated append_ne_nil_of_left_ne_nil (since := "2024-07-24")]
theorem append_ne_nil_of_ne_nil_left {s : List α} (h : s []) (t : List α) : s ++ t [] := by simp_all
@[deprecated append_ne_nil_of_right_ne_nil (since := "2024-07-24")]
theorem append_ne_nil_of_ne_nil_right (s : List α) : t [] s ++ t [] := by simp_all
theorem append_eq_cons_iff :
a ++ b = x :: c (a = [] b = x :: c) ( a', a = x :: a' c = a' ++ b) := by
cases a with simp | cons a as => ?_
exact fun h => as, by simp [h], fun a', aeq, aseq, h => aeq, by rw [aseq, h]
@[deprecated append_eq_cons_iff (since := "2024-07-24")] abbrev append_eq_cons := @append_eq_cons_iff
theorem cons_eq_append_iff :
x :: c = a ++ b (a = [] b = x :: c) ( a', a = x :: a' c = a' ++ b) := by
rw [eq_comm, append_eq_cons_iff]
@[deprecated cons_eq_append_iff (since := "2024-07-24")] abbrev cons_eq_append := @cons_eq_append_iff
theorem append_eq_singleton_iff :
a ++ b = [x] (a = [] b = [x]) (a = [x] b = []) := by
cases a <;> cases b <;> simp
theorem singleton_eq_append_iff :
[x] = a ++ b (a = [] b = [x]) (a = [x] b = []) := by
cases a <;> cases b <;> simp [eq_comm]
theorem append_eq_append_iff {a b c d : List α} :
a ++ b = c ++ d ( a', c = a ++ a' b = a' ++ d) c', a = c ++ c' d = c' ++ b := by
induction a generalizing c with
| nil => simp_all
| cons a as ih => cases c <;> simp [eq_comm, and_assoc, ih, and_or_left]
@[deprecated append_inj (since := "2024-07-24")] abbrev append_inj_of_length_left := @append_inj
@[deprecated append_inj' (since := "2024-07-24")] abbrev append_inj_of_length_right := @append_inj'
@[simp] theorem head_append_of_ne_nil {l : List α} {w₁} (w₂) :
head (l ++ l') w₁ = head l w₂ := by
match l, w₂ with
@@ -1770,6 +1691,60 @@ theorem tail_append {l l' : List α} : (l ++ l').tail = if l.isEmpty then l'.tai
@[deprecated tail_append_of_ne_nil (since := "2024-07-24")] abbrev tail_append_left := @tail_append_of_ne_nil
theorem nil_eq_append_iff : [] = a ++ b a = [] b = [] := by
rw [eq_comm, append_eq_nil]
@[deprecated nil_eq_append_iff (since := "2024-07-24")] abbrev nil_eq_append := @nil_eq_append_iff
theorem append_ne_nil_of_left_ne_nil {s : List α} (h : s []) (t : List α) : s ++ t [] := by simp_all
theorem append_ne_nil_of_right_ne_nil (s : List α) : t [] s ++ t [] := by simp_all
@[deprecated append_ne_nil_of_left_ne_nil (since := "2024-07-24")]
theorem append_ne_nil_of_ne_nil_left {s : List α} (h : s []) (t : List α) : s ++ t [] := by simp_all
@[deprecated append_ne_nil_of_right_ne_nil (since := "2024-07-24")]
theorem append_ne_nil_of_ne_nil_right (s : List α) : t [] s ++ t [] := by simp_all
theorem append_eq_cons_iff :
a ++ b = x :: c (a = [] b = x :: c) ( a', a = x :: a' c = a' ++ b) := by
cases a with simp | cons a as => ?_
exact fun h => as, by simp [h], fun a', aeq, aseq, h => aeq, by rw [aseq, h]
@[deprecated append_eq_cons_iff (since := "2024-07-24")] abbrev append_eq_cons := @append_eq_cons_iff
theorem cons_eq_append_iff :
x :: c = a ++ b (a = [] b = x :: c) ( a', a = x :: a' c = a' ++ b) := by
rw [eq_comm, append_eq_cons_iff]
@[deprecated cons_eq_append_iff (since := "2024-07-24")] abbrev cons_eq_append := @cons_eq_append_iff
theorem append_eq_append_iff {a b c d : List α} :
a ++ b = c ++ d ( a', c = a ++ a' b = a' ++ d) c', a = c ++ c' d = c' ++ b := by
induction a generalizing c with
| nil => simp_all
| cons a as ih => cases c <;> simp [eq_comm, and_assoc, ih, and_or_left]
@[deprecated append_inj (since := "2024-07-24")] abbrev append_inj_of_length_left := @append_inj
@[deprecated append_inj' (since := "2024-07-24")] abbrev append_inj_of_length_right := @append_inj'
@[simp] theorem mem_append {a : α} {s t : List α} : a s ++ t a s a t := by
induction s <;> simp_all [or_assoc]
theorem not_mem_append {a : α} {s t : List α} (h₁ : a s) (h₂ : a t) : a s ++ t :=
mt mem_append.1 $ not_or.mpr h₁, h₂
theorem mem_append_eq (a : α) (s t : List α) : (a s ++ t) = (a s a t) :=
propext mem_append
@[deprecated mem_append_left (since := "2024-11-20")] abbrev mem_append_of_mem_left := @mem_append_left
@[deprecated mem_append_right (since := "2024-11-20")] abbrev mem_append_of_mem_right := @mem_append_right
theorem mem_iff_append {a : α} {l : List α} : a l s t : List α, l = s ++ a :: t :=
append_of_mem, fun s, t, e => e by simp
theorem forall_mem_append {p : α Prop} {l₁ l₂ : List α} :
( (x) (_ : x l₁ ++ l₂), p x) ( (x) (_ : x l₁), p x) ( (x) (_ : x l₂), p x) := by
simp only [mem_append, or_imp, forall_and]
theorem set_append {s t : List α} :
(s ++ t).set i x = if i < s.length then s.set i x ++ t else s ++ t.set (i - s.length) x := by
induction s generalizing i with
@@ -1898,7 +1873,7 @@ theorem eq_nil_or_concat : ∀ l : List α, l = [] ∃ L b, l = concat L b
/-! ### flatten -/
@[simp] theorem length_flatten (L : List (List α)) : L.flatten.length = (L.map length).sum := by
@[simp] theorem length_flatten (L : List (List α)) : (flatten L).length = (L.map length).sum := by
induction L with
| nil => rfl
| cons =>
@@ -1913,9 +1888,6 @@ theorem flatten_singleton (l : List α) : [l].flatten = l := by simp
@[simp] theorem flatten_eq_nil_iff {L : List (List α)} : L.flatten = [] l L, l = [] := by
induction L <;> simp_all
@[simp] theorem nil_eq_flatten_iff {L : List (List α)} : [] = L.flatten l L, l = [] := by
rw [eq_comm, flatten_eq_nil_iff]
theorem flatten_ne_nil_iff {xs : List (List α)} : xs.flatten [] x, x xs x [] := by
simp
@@ -1941,8 +1913,7 @@ theorem head?_flatten {L : List (List α)} : (flatten L).head? = L.findSome? fun
-- `getLast?_flatten` is proved later, after the `reverse` section.
-- `head_flatten` and `getLast_flatten` are proved in `Init.Data.List.Find`.
@[simp] theorem map_flatten (f : α β) (L : List (List α)) :
(flatten L).map f = (map (map f) L).flatten := by
@[simp] theorem map_flatten (f : α β) (L : List (List α)) : map f (flatten L) = flatten (map (map f) L) := by
induction L <;> simp_all
@[simp] theorem filterMap_flatten (f : α Option β) (L : List (List α)) :
@@ -1995,26 +1966,6 @@ theorem flatten_eq_cons_iff {xs : List (List α)} {y : α} {ys : List α} :
· rintro as, bs, cs, rfl, h₁, rfl
simp [flatten_eq_nil_iff.mpr h₁]
theorem cons_eq_flatten_iff {xs : List (List α)} {y : α} {ys : List α} :
y :: ys = xs.flatten
as bs cs, xs = as ++ (y :: bs) :: cs ( l, l as l = []) ys = bs ++ cs.flatten := by
rw [eq_comm, flatten_eq_cons_iff]
theorem flatten_eq_singleton_iff {xs : List (List α)} {y : α} :
xs.flatten = [y] as bs, xs = as ++ [y] :: bs ( l, l as l = []) ( l, l bs l = []) := by
rw [flatten_eq_cons_iff]
constructor
· rintro as, bs, cs, rfl, h₁, h₂
simp at h₂
obtain rfl, h₂ := h₂
exact as, cs, by simp, h₁, h₂
· rintro as, bs, rfl, h₁, h₂
exact as, [], bs, rfl, h₁, by simpa
theorem singleton_eq_flatten_iff {xs : List (List α)} {y : α} :
[y] = xs.flatten as bs, xs = as ++ [y] :: bs ( l, l as l = []) ( l, l bs l = []) := by
rw [eq_comm, flatten_eq_singleton_iff]
theorem flatten_eq_append_iff {xs : List (List α)} {ys zs : List α} :
xs.flatten = ys ++ zs
( as bs, xs = as ++ bs ys = as.flatten zs = bs.flatten)
@@ -2023,8 +1974,8 @@ theorem flatten_eq_append_iff {xs : List (List α)} {ys zs : List α} :
constructor
· induction xs generalizing ys with
| nil =>
simp only [flatten_nil, nil_eq, append_eq_nil_iff, and_false, cons_append, false_and,
exists_const, exists_false, or_false, and_imp, List.cons_ne_nil]
simp only [flatten_nil, nil_eq, append_eq_nil, and_false, cons_append, false_and, exists_const,
exists_false, or_false, and_imp, List.cons_ne_nil]
rintro rfl rfl
exact [], [], by simp
| cons x xs ih =>
@@ -2043,13 +1994,6 @@ theorem flatten_eq_append_iff {xs : List (List α)} {ys zs : List α} :
· simp
· simp
theorem append_eq_flatten_iff {xs : List (List α)} {ys zs : List α} :
ys ++ zs = xs.flatten
( as bs, xs = as ++ bs ys = as.flatten zs = bs.flatten)
as bs c cs ds, xs = as ++ (bs ++ c :: cs) :: ds ys = as.flatten ++ bs
zs = c :: cs ++ ds.flatten := by
rw [eq_comm, flatten_eq_append_iff]
/-- Two lists of sublists are equal iff their flattens coincide, as well as the lengths of the
sublists. -/
theorem eq_iff_flatten_eq : {L L' : List (List α)},
@@ -2070,14 +2014,12 @@ theorem eq_iff_flatten_eq : ∀ {L L' : List (List α)},
theorem flatMap_def (l : List α) (f : α List β) : l.flatMap f = flatten (map f l) := by rfl
@[simp] theorem flatMap_id (l : List (List α)) : l.flatMap id = l.flatten := by simp [flatMap_def]
@[simp] theorem flatMap_id' (l : List (List α)) : l.flatMap (fun a => a) = l.flatten := by simp [flatMap_def]
@[simp] theorem flatMap_id (l : List (List α)) : List.flatMap l id = l.flatten := by simp [flatMap_def]
@[simp]
theorem length_flatMap (l : List α) (f : α List β) :
length (l.flatMap f) = sum (map (fun a => (f a).length) l) := by
rw [List.flatMap, length_flatten, map_map, Function.comp_def]
length (l.flatMap f) = sum (map (length f) l) := by
rw [List.flatMap, length_flatten, map_map]
@[simp] theorem mem_flatMap {f : α List β} {b} {l : List α} : b l.flatMap f a, a l b f a := by
simp [flatMap_def, mem_flatten]
@@ -2090,7 +2032,7 @@ theorem mem_flatMap_of_mem {b : β} {l : List α} {f : α → List β} {a} (al :
b l.flatMap f := mem_flatMap.2 a, al, h
@[simp]
theorem flatMap_eq_nil_iff {l : List α} {f : α List β} : l.flatMap f = [] x l, f x = [] :=
theorem flatMap_eq_nil_iff {l : List α} {f : α List β} : List.flatMap l f = [] x l, f x = [] :=
flatten_eq_nil_iff.trans <| by
simp only [mem_map, forall_exists_index, and_imp, forall_apply_eq_imp_iff₂]
@@ -2395,9 +2337,6 @@ theorem replicateRecOn {α : Type _} {p : List α → Prop} (m : List α)
exact hi _ _ _ _ h hn (replicateRecOn (b :: l') h0 hr hi)
termination_by m.length
@[simp] theorem sum_replicate_nat (n : Nat) (a : Nat) : (replicate n a).sum = n * a := by
induction n <;> simp_all [replicate_succ, Nat.add_mul, Nat.add_comm]
/-! ### reverse -/
@[simp] theorem length_reverse (as : List α) : (as.reverse).length = as.length := by

View File

@@ -143,9 +143,6 @@ theorem forM_toArray [Monad m] (l : List α) (f : α → m PUnit) :
subst h
rw [foldl_toList]
@[simp] theorem sum_toArray [Add α] [Zero α] (l : List α) : l.toArray.sum = l.sum := by
simp [Array.sum, List.sum]
@[simp] theorem append_toArray (l₁ l₂ : List α) :
l₁.toArray ++ l₂.toArray = (l₁ ++ l₂).toArray := by
apply ext'
@@ -392,29 +389,9 @@ theorem takeWhile_go_toArray (p : α → Bool) (l : List α) (i : Nat) :
· simp
· simp_all [List.set_eq_of_length_le]
@[simp] theorem toArray_replicate (n : Nat) (v : α) : (List.replicate n v).toArray = Array.replicate n v := rfl
@[simp] theorem toArray_replicate (n : Nat) (v : α) : (List.replicate n v).toArray = mkArray n v := rfl
@[deprecated toArray_replicate (since := "2024-12-13")]
abbrev _root_.Array.mkArray_eq_toArray_replicate := @toArray_replicate
@[simp] theorem flatMap_empty {β} (f : α Array β) : (#[] : Array α).flatMap f = #[] := rfl
theorem flatMap_toArray_cons {β} (f : α Array β) (a : α) (as : List α) :
(a :: as).toArray.flatMap f = f a ++ as.toArray.flatMap f := by
simp [Array.flatMap]
suffices cs, List.foldl (fun bs a => bs ++ f a) (f a ++ cs) as =
f a ++ List.foldl (fun bs a => bs ++ f a) cs as by
erw [empty_append] -- Why doesn't this work via `simp`?
simpa using this #[]
intro cs
induction as generalizing cs <;> simp_all
@[simp] theorem flatMap_toArray {β} (f : α Array β) (as : List α) :
as.toArray.flatMap f = (as.flatMap (fun a => (f a).toList)).toArray := by
induction as with
| nil => simp
| cons a as ih =>
apply ext'
simp [ih, flatMap_toArray_cons]
end List

View File

@@ -203,11 +203,11 @@ theorem zipWith_eq_append_iff {f : α → β → γ} {l₁ : List α} {l₂ : Li
cases l₂ with
| nil =>
constructor
· simp only [zipWith_nil_right, nil_eq, append_eq_nil_iff, exists_and_left, and_imp]
· simp only [zipWith_nil_right, nil_eq, append_eq_nil, exists_and_left, and_imp]
rintro rfl rfl
exact [], x₁ :: l₁, [], by simp
· rintro w, x, y, z, h₁, _, h₃, rfl, rfl
simp only [nil_eq, append_eq_nil_iff] at h₃
simp only [nil_eq, append_eq_nil] at h₃
obtain rfl, rfl := h₃
simp
| cons x₂ l₂ =>

View File

@@ -208,15 +208,6 @@ theorem comp_map (h : β → γ) (g : α → β) (x : Option α) : x.map (h ∘
theorem mem_map_of_mem (g : α β) (h : a x) : g a Option.map g x := h.symm map_some' ..
theorem map_inj_right {f : α β} {o o' : Option α} (w : x y, f x = f y x = y) :
o.map f = o'.map f o = o' := by
cases o with
| none => cases o' <;> simp
| some a =>
cases o' with
| none => simp
| some a' => simpa using fun h => w _ _ h, fun h => congrArg f h
@[simp] theorem map_if {f : α β} [Decidable c] :
(if c then some a else none).map f = if c then some (f a) else none := by
split <;> rfl
@@ -638,15 +629,6 @@ theorem pbind_eq_some_iff {o : Option α} {f : (a : α) → a ∈ o → Option
· rintro h, rfl
rfl
@[simp]
theorem pmap_eq_map (p : α Prop) (f : α β) (o : Option α) (H) :
@pmap _ _ p (fun a _ => f a) o H = Option.map f o := by
cases o <;> simp
theorem map_pmap {p : α Prop} (g : β γ) (f : a, p a β) (o H) :
Option.map g (pmap f o H) = pmap (fun a h => g (f a h)) o H := by
cases o <;> simp
/-! ### pelim -/
@[simp] theorem pelim_none : pelim none b f = b := rfl

View File

@@ -13,17 +13,11 @@ macro "declare_bitwise_uint_theorems" typeName:ident bits:term:arg : command =>
`(
namespace $typeName
@[simp, int_toBitVec] protected theorem toBitVec_add {a b : $typeName} : (a + b).toBitVec = a.toBitVec + b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_sub {a b : $typeName} : (a - b).toBitVec = a.toBitVec - b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_mul {a b : $typeName} : (a * b).toBitVec = a.toBitVec * b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_div {a b : $typeName} : (a / b).toBitVec = a.toBitVec / b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_mod {a b : $typeName} : (a % b).toBitVec = a.toBitVec % b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_not {a : $typeName} : (~~~a).toBitVec = ~~~a.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_and (a b : $typeName) : (a &&& b).toBitVec = a.toBitVec &&& b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_or (a b : $typeName) : (a ||| b).toBitVec = a.toBitVec ||| b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_xor (a b : $typeName) : (a ^^^ b).toBitVec = a.toBitVec ^^^ b.toBitVec := rfl
@[simp, int_toBitVec] protected theorem toBitVec_shiftLeft (a b : $typeName) : (a <<< b).toBitVec = a.toBitVec <<< (b.toBitVec % $bits) := rfl
@[simp, int_toBitVec] protected theorem toBitVec_shiftRight (a b : $typeName) : (a >>> b).toBitVec = a.toBitVec >>> (b.toBitVec % $bits) := rfl
@[simp] protected theorem toBitVec_and (a b : $typeName) : (a &&& b).toBitVec = a.toBitVec &&& b.toBitVec := rfl
@[simp] protected theorem toBitVec_or (a b : $typeName) : (a ||| b).toBitVec = a.toBitVec ||| b.toBitVec := rfl
@[simp] protected theorem toBitVec_xor (a b : $typeName) : (a ^^^ b).toBitVec = a.toBitVec ^^^ b.toBitVec := rfl
@[simp] protected theorem toBitVec_shiftLeft (a b : $typeName) : (a <<< b).toBitVec = a.toBitVec <<< (b.toBitVec % $bits) := rfl
@[simp] protected theorem toBitVec_shiftRight (a b : $typeName) : (a >>> b).toBitVec = a.toBitVec >>> (b.toBitVec % $bits) := rfl
@[simp] protected theorem toNat_and (a b : $typeName) : (a &&& b).toNat = a.toNat &&& b.toNat := by simp [toNat]
@[simp] protected theorem toNat_or (a b : $typeName) : (a ||| b).toNat = a.toNat ||| b.toNat := by simp [toNat]
@@ -43,31 +37,3 @@ declare_bitwise_uint_theorems UInt16 16
declare_bitwise_uint_theorems UInt32 32
declare_bitwise_uint_theorems UInt64 64
declare_bitwise_uint_theorems USize System.Platform.numBits
@[simp, int_toBitVec]
theorem Bool.toBitVec_toUInt8 {b : Bool} :
b.toUInt8.toBitVec = (BitVec.ofBool b).setWidth 8 := by
cases b <;> simp [toUInt8]
@[simp, int_toBitVec]
theorem Bool.toBitVec_toUInt16 {b : Bool} :
b.toUInt16.toBitVec = (BitVec.ofBool b).setWidth 16 := by
cases b <;> simp [toUInt16]
@[simp, int_toBitVec]
theorem Bool.toBitVec_toUInt32 {b : Bool} :
b.toUInt32.toBitVec = (BitVec.ofBool b).setWidth 32 := by
cases b <;> simp [toUInt32]
@[simp, int_toBitVec]
theorem Bool.toBitVec_toUInt64 {b : Bool} :
b.toUInt64.toBitVec = (BitVec.ofBool b).setWidth 64 := by
cases b <;> simp [toUInt64]
@[simp, int_toBitVec]
theorem Bool.toBitVec_toUSize {b : Bool} :
b.toUSize.toBitVec = (BitVec.ofBool b).setWidth System.Platform.numBits := by
cases b
· simp [toUSize]
· apply BitVec.eq_of_toNat_eq
simp [toUSize]

View File

@@ -41,9 +41,9 @@ macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
theorem toNat_ofNat_of_lt {n : Nat} (h : n < size) : (ofNat n).toNat = n := by
rw [toNat, toBitVec_eq_of_lt h]
@[int_toBitVec] theorem le_def {a b : $typeName} : a b a.toBitVec b.toBitVec := .rfl
theorem le_def {a b : $typeName} : a b a.toBitVec b.toBitVec := .rfl
@[int_toBitVec] theorem lt_def {a b : $typeName} : a < b a.toBitVec < b.toBitVec := .rfl
theorem lt_def {a b : $typeName} : a < b a.toBitVec < b.toBitVec := .rfl
theorem le_iff_toNat_le {a b : $typeName} : a b a.toNat b.toNat := .rfl
@@ -74,11 +74,6 @@ macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
protected theorem toBitVec_inj {a b : $typeName} : a.toBitVec = b.toBitVec a = b :=
Iff.intro eq_of_toBitVec_eq toBitVec_eq_of_eq
open $typeName (eq_of_toBitVec_eq toBitVec_eq_of_eq) in
@[int_toBitVec]
protected theorem eq_iff_toBitVec_eq {a b : $typeName} : a = b a.toBitVec = b.toBitVec :=
Iff.intro toBitVec_eq_of_eq eq_of_toBitVec_eq
open $typeName (eq_of_toBitVec_eq) in
protected theorem eq_of_val_eq {a b : $typeName} (h : a.val = b.val) : a = b := by
rcases a with _; rcases b with _; simp_all [val]
@@ -87,19 +82,10 @@ macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
protected theorem val_inj {a b : $typeName} : a.val = b.val a = b :=
Iff.intro eq_of_val_eq (congrArg val)
open $typeName (eq_of_toBitVec_eq) in
protected theorem toBitVec_ne_of_ne {a b : $typeName} (h : a b) : a.toBitVec b.toBitVec :=
fun h' => h (eq_of_toBitVec_eq h')
open $typeName (toBitVec_eq_of_eq) in
protected theorem ne_of_toBitVec_ne {a b : $typeName} (h : a.toBitVec b.toBitVec) : a b :=
fun h' => absurd (toBitVec_eq_of_eq h') h
open $typeName (ne_of_toBitVec_ne toBitVec_ne_of_ne) in
@[int_toBitVec]
protected theorem ne_iff_toBitVec_ne {a b : $typeName} : a b a.toBitVec b.toBitVec :=
Iff.intro toBitVec_ne_of_ne ne_of_toBitVec_ne
open $typeName (ne_of_toBitVec_ne) in
protected theorem ne_of_lt {a b : $typeName} (h : a < b) : a b := by
apply ne_of_toBitVec_ne
@@ -173,7 +159,7 @@ macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
@[simp]
theorem val_ofNat (n : Nat) : val (no_index (OfNat.ofNat n)) = OfNat.ofNat n := rfl
@[simp, int_toBitVec]
@[simp]
theorem toBitVec_ofNat (n : Nat) : toBitVec (no_index (OfNat.ofNat n)) = BitVec.ofNat _ n := rfl
@[simp]

View File

@@ -52,15 +52,13 @@ def elimAsList {motive : Vector α n → Sort u}
@[inline] def mkEmpty (capacity : Nat) : Vector α 0 := .mkEmpty capacity, rfl
/-- Makes a vector of size `n` with all cells containing `v`. -/
@[inline] def replicate (n) (v : α) : Vector α n := Array.replicate n v, by simp
@[deprecated replicate (since := "2025-01-16")] abbrev mkVector := @replicate
@[inline] def mkVector (n) (v : α) : Vector α n := mkArray n v, by simp
/-- Returns a vector of size `1` with element `v`. -/
@[inline] def singleton (v : α) : Vector α 1 := #[v], rfl
instance [Inhabited α] : Inhabited (Vector α n) where
default := replicate n default
default := mkVector n default
/-- Get an element of a vector using a `Fin` index. -/
@[inline] def get (v : Vector α n) (i : Fin n) : α :=
@@ -172,13 +170,6 @@ result is empty. If `stop` is greater than the size of the vector, the size is u
@[inline] def map (f : α β) (v : Vector α n) : Vector β n :=
v.toArray.map f, by simp
@[inline] def flatten (v : Vector (Vector α n) m) : Vector α (m * n) :=
(v.toArray.map Vector.toArray).flatten,
by rcases v; simp_all [Function.comp_def, Array.map_const']
@[inline] def flatMap (v : Vector α n) (f : α Vector β m) : Vector β (n * m) :=
v.toArray.flatMap fun a => (f a).toArray, by simp [Array.map_const']
/-- Maps corresponding elements of two vectors of equal size using the function `f`. -/
@[inline] def zipWith (a : Vector α n) (b : Vector β n) (f : α β φ) : Vector φ n :=
Array.zipWith a.toArray b.toArray f, by simp

View File

@@ -5,7 +5,6 @@ Authors: Shreyas Srinivas, Francois Dorais, Kim Morrison
-/
prelude
import Init.Data.Vector.Basic
import Init.Data.Array.Attach
/-!
## Vectors
@@ -28,9 +27,6 @@ namespace Vector
theorem toArray_mk (a : Array α) (h : a.size = n) : (Vector.mk a h).toArray = a := rfl
@[simp] theorem mk_toArray (v : Vector α n) : mk v.toArray v.2 = v := by
rfl
@[simp] theorem getElem_mk {data : Array α} {size : data.size = n} {i : Nat} (h : i < n) :
(Vector.mk data size)[i] = data[i] := rfl
@@ -269,9 +265,7 @@ theorem toArray_mk (a : Array α) (h : a.size = n) : (Vector.mk a h).toArray = a
cases v
simp
@[simp] theorem toArray_replicate : (replicate n a).toArray = Array.replicate n a := rfl
@[deprecated toArray_replicate (since := "2025-01-16")] abbrev toArray_mkVector := @toArray_replicate
@[simp] theorem toArray_mkVector : (mkVector n a).toArray = mkArray n a := rfl
@[simp] theorem toArray_inj {v w : Vector α n} : v.toArray = w.toArray v = w := by
cases v
@@ -391,9 +385,7 @@ theorem toList_swap (a : Vector α n) (i j) (hi hj) :
cases v
simp
@[simp] theorem toList_replicate : (replicate n a).toList = List.replicate n a := rfl
@[deprecated toList_replicate (since := "2025-01-16")] abbrev toList_mkVector := @toList_replicate
@[simp] theorem toList_mkVector : (mkVector n a).toList = List.replicate n a := rfl
theorem toList_inj {v w : Vector α n} : v.toList = w.toList v = w := by
cases v
@@ -472,19 +464,15 @@ theorem exists_push {xs : Vector α (n + 1)} :
theorem singleton_inj : #v[a] = #v[b] a = b := by
simp
/-! ### replicate -/
/-! ### mkVector -/
@[simp] theorem replicate_zero : replicate 0 a = #v[] := rfl
@[simp] theorem mkVector_zero : mkVector 0 a = #v[] := rfl
theorem replicate_succ : replicate (n + 1) a = (replicate n a).push a := by
simp [replicate, Array.replicate_succ]
theorem mkVector_succ : mkVector (n + 1) a = (mkVector n a).push a := by
simp [mkVector, Array.mkArray_succ]
theorem replicate_inj : replicate n a = replicate n b n = 0 a = b := by
simp [ toArray_inj, toArray_replicate, Array.replicate_inj]
@[deprecated replicate_zero (since := "2025-01-16")] abbrev mkVector_zero := @replicate_zero
@[deprecated replicate_succ (since := "2025-01-16")] abbrev mkVector_succ := @replicate_succ
@[deprecated replicate_inj (since := "2025-01-16")] abbrev mkVector_inj := @replicate_inj
theorem mkVector_inj : mkVector n a = mkVector n b n = 0 a = b := by
simp [ toArray_inj, toArray_mkVector, Array.mkArray_inj]
/-! ## L[i] and L[i]? -/
@@ -705,24 +693,6 @@ theorem forall_getElem {l : Vector α n} {p : α → Prop} :
rcases l with l, rfl
simp [Array.forall_getElem]
/-! ### cast -/
@[simp] theorem getElem_cast (a : Vector α n) (h : n = m) (i : Nat) (hi : i < m) :
(a.cast h)[i] = a[i] := by
cases a
simp
@[simp] theorem getElem?_cast {l : Vector α n} {m : Nat} {w : n = m} {i : Nat} :
(l.cast w)[i]? = l[i]? := by
rcases l with l, rfl
simp
@[simp] theorem mem_cast {a : α} {l : Vector α n} {m : Nat} {w : n = m} :
a l.cast w a l := by
rcases l with l, rfl
simp
/-! ### Decidability of bounded quantifiers -/
instance {xs : Vector α n} {p : α Prop} [DecidablePred p] :
@@ -1013,17 +983,15 @@ theorem mem_setIfInBounds (v : Vector α n) (i : Nat) (hi : i < n) (a : α) :
cases w
simp
@[simp] theorem replicate_beq_replicate [BEq α] {a b : α} {n : Nat} :
(replicate n a == replicate n b) = (n == 0 || a == b) := by
@[simp] theorem mkVector_beq_mkVector [BEq α] {a b : α} {n : Nat} :
(mkVector n a == mkVector n b) = (n == 0 || a == b) := by
cases n with
| zero => simp
| succ n =>
rw [replicate_succ, replicate_succ, push_beq_push, replicate_beq_replicate]
rw [mkVector_succ, mkVector_succ, push_beq_push, mkVector_beq_mkVector]
rw [Bool.eq_iff_iff]
simp +contextual
@[deprecated replicate_beq_replicate (since := "2025-01-16")] abbrev mkVector_beq_mkVector := @replicate_beq_replicate
@[simp] theorem reflBEq_iff [BEq α] [NeZero n] : ReflBEq (Vector α n) ReflBEq α := by
match n, NeZero.ne n with
| n + 1, _ =>
@@ -1031,8 +999,8 @@ theorem mem_setIfInBounds (v : Vector α n) (i : Nat) (hi : i < n) (a : α) :
· intro h
constructor
intro a
suffices (replicate (n + 1) a == replicate (n + 1) a) = true by
rw [replicate_succ, push_beq_push, Bool.and_eq_true] at this
suffices (mkVector (n + 1) a == mkVector (n + 1) a) = true by
rw [mkVector_succ, push_beq_push, Bool.and_eq_true] at this
exact this.2
simp
· intro h
@@ -1047,15 +1015,15 @@ theorem mem_setIfInBounds (v : Vector α n) (i : Nat) (hi : i < n) (a : α) :
· intro h
constructor
· intro a b h
have := replicate_inj (n := n+1) (a := a) (b := b)
have := mkVector_inj (n := n+1) (a := a) (b := b)
simp only [Nat.add_one_ne_zero, false_or] at this
rw [ this]
apply eq_of_beq
rw [replicate_beq_replicate]
rw [mkVector_beq_mkVector]
simpa
· intro a
suffices (replicate (n + 1) a == replicate (n + 1) a) = true by
rw [replicate_beq_replicate] at this
suffices (mkVector (n + 1) a == mkVector (n + 1) a) = true by
rw [mkVector_beq_mkVector] at this
simpa
simp
· intro h
@@ -1129,11 +1097,6 @@ theorem forall_mem_map {f : α → β} {l : Vector α n} {P : β → Prop} :
@[simp] theorem map_inj_left {f g : α β} : map f l = map g l a l, f a = g a := by
cases l <;> simp_all
theorem map_inj_right {f : α β} (w : x y, f x = f y x = y) : map f l = map f l' l = l' := by
cases l
cases l'
simp [Array.map_inj_right w]
theorem map_congr_left (h : a l, f a = g a) : map f l = map g l :=
map_inj_left.2 h
@@ -1141,8 +1104,8 @@ theorem map_inj [NeZero n] : map (n := n) f = map g ↔ f = g := by
constructor
· intro h
ext a
replace h := congrFun h (replicate n a)
simp only [replicate, map_mk, mk.injEq, Array.map_inj_left, Array.mem_replicate, and_imp,
replace h := congrFun h (mkVector n a)
simp only [mkVector, map_mk, mk.injEq, Array.map_inj_left, Array.mem_mkArray, and_imp,
forall_eq_apply_imp_iff] at h
exact h (NeZero.ne n)
· intro h; subst h; rfl
@@ -1204,406 +1167,6 @@ theorem map_eq_iff {f : α → β} {l : Vector α n} {l' : Vector β n} :
cases as
simp
/--
Use this as `induction ass using vector₂_induction` on a hypothesis of the form `ass : Vector (Vector α n) m`.
The hypothesis `ass` will be replaced with a hypothesis `ass : Array (Array α)`
along with additional hypotheses `h₁ : ass.size = m` and `h₂ : ∀ xs ∈ ass, xs.size = n`.
Appearances of the original `ass` in the goal will be replaced with
`Vector.mk (xss.attach.map (fun ⟨xs, m⟩ => Vector.mk xs ⋯)) ⋯`.
-/
-- We can't use `@[cases_eliminator]` here as
-- `Lean.Meta.getCustomEliminator?` only looks at the top-level constant.
theorem vector₂_induction (P : Vector (Vector α n) m Prop)
(of : (xss : Array (Array α)) (h₁ : xss.size = m) (h₂ : xs xss, xs.size = n),
P (mk (xss.attach.map (fun xs, m => mk xs (h₂ xs m))) (by simpa using h₁)))
(ass : Vector (Vector α n) m) : P ass := by
specialize of (ass.map toArray).toArray (by simp) (by simp)
simpa [Array.map_attach, Array.pmap_map] using of
/--
Use this as `induction ass using vector₃_induction` on a hypothesis of the form `ass : Vector (Vector (Vector α n) m) k`.
The hypothesis `ass` will be replaced with a hypothesis `ass : Array (Array (Array α))`
along with additional hypotheses `h₁ : ass.size = k`, `h₂ : ∀ xs ∈ ass, xs.size = m`,
and `h₃ : ∀ xs ∈ ass, ∀ x ∈ xs, x.size = n`.
Appearances of the original `ass` in the goal will be replaced with
`Vector.mk (xss.attach.map (fun ⟨xs, m⟩ => Vector.mk (xs.attach.map (fun ⟨x, m'⟩ => Vector.mk x ⋯)) ⋯)) ⋯`.
-/
theorem vector₃_induction (P : Vector (Vector (Vector α n) m) k Prop)
(of : (xss : Array (Array (Array α))) (h₁ : xss.size = k) (h₂ : xs xss, xs.size = m)
(h₃ : xs xss, x xs, x.size = n),
P (mk (xss.attach.map (fun xs, m =>
mk (xs.attach.map (fun x, m' =>
mk x (h₃ xs m x m'))) (by simpa using h₂ xs m))) (by simpa using h₁)))
(ass : Vector (Vector (Vector α n) m) k) : P ass := by
specialize of (ass.map (fun as => (as.map toArray).toArray)).toArray (by simp) (by simp) (by simp)
simpa [Array.map_attach, Array.pmap_map] using of
/-! ### singleton -/
@[simp] theorem singleton_def (v : α) : Vector.singleton v = #v[v] := rfl
/-! ### append -/
@[simp] theorem append_push {as : Vector α n} {bs : Vector α m} {a : α} :
as ++ bs.push a = (as ++ bs).push a := by
cases as
cases bs
simp
theorem singleton_eq_toVector_singleton (a : α) : #v[a] = #[a].toVector := rfl
@[simp] theorem mem_append {a : α} {s : Vector α n} {t : Vector α m} :
a s ++ t a s a t := by
cases s
cases t
simp
theorem mem_append_left {a : α} {s : Vector α n} {t : Vector α m} (h : a s) : a s ++ t :=
mem_append.2 (Or.inl h)
theorem mem_append_right {a : α} {s : Vector α n} {t : Vector α m} (h : a t) : a s ++ t :=
mem_append.2 (Or.inr h)
theorem not_mem_append {a : α} {s : Vector α n} {t : Vector α m} (h₁ : a s) (h₂ : a t) :
a s ++ t :=
mt mem_append.1 $ not_or.mpr h₁, h₂
/--
See also `eq_push_append_of_mem`, which proves a stronger version
in which the initial array must not contain the element.
-/
theorem append_of_mem {a : α} {l : Vector α n} (h : a l) :
(m k : Nat) (w : m + 1 + k = n) (s : Vector α m) (t : Vector α k),
l = (s.push a ++ t).cast w := by
rcases l with l, rfl
obtain s, t, rfl := Array.append_of_mem (by simpa using h)
refine _, _, by simp, s.toVector, t.toVector, by simp_all
theorem mem_iff_append {a : α} {l : Vector α n} :
a l (m k : Nat) (w : m + 1 + k = n) (s : Vector α m) (t : Vector α k),
l = (s.push a ++ t).cast w :=
append_of_mem, by rintro m, k, rfl, s, t, rfl; simp
theorem forall_mem_append {p : α Prop} {l₁ : Vector α n} {l₂ : Vector α m} :
( (x) (_ : x l₁ ++ l₂), p x) ( (x) (_ : x l₁), p x) ( (x) (_ : x l₂), p x) := by
simp only [mem_append, or_imp, forall_and]
theorem empty_append (as : Vector α n) : (#v[] : Vector α 0) ++ as = as.cast (by omega) := by
rcases as with as, rfl
simp
theorem append_empty (as : Vector α n) : as ++ (#v[] : Vector α 0) = as := by
rw [ toArray_inj, toArray_append, Array.append_empty]
theorem getElem_append (a : Vector α n) (b : Vector α m) (i : Nat) (hi : i < n + m) :
(a ++ b)[i] = if h : i < n then a[i] else b[i - n] := by
rcases a with a, rfl
rcases b with b, rfl
simp [Array.getElem_append, hi]
theorem getElem_append_left {a : Vector α n} {b : Vector α m} {i : Nat} (hi : i < n) :
(a ++ b)[i] = a[i] := by simp [getElem_append, hi]
theorem getElem_append_right {a : Vector α n} {b : Vector α m} {i : Nat} (h : i < n + m) (hi : n i) :
(a ++ b)[i] = b[i - n] := by
rw [getElem_append, dif_neg (by omega)]
theorem getElem?_append_left {as : Vector α n} {bs : Vector α m} {i : Nat} (hn : i < n) :
(as ++ bs)[i]? = as[i]? := by
have hn' : i < n + m := by omega
simp_all [getElem?_eq_getElem, getElem_append]
theorem getElem?_append_right {as : Vector α n} {bs : Vector α m} {i : Nat} (h : n i) :
(as ++ bs)[i]? = bs[i - n]? := by
rcases as with as, rfl
rcases bs with bs, rfl
simp [Array.getElem?_append_right, h]
theorem getElem?_append {as : Vector α n} {bs : Vector α m} {i : Nat} :
(as ++ bs)[i]? = if i < n then as[i]? else bs[i - n]? := by
split <;> rename_i h
· exact getElem?_append_left h
· exact getElem?_append_right (by simpa using h)
/-- Variant of `getElem_append_left` useful for rewriting from the small array to the big array. -/
theorem getElem_append_left' (l₁ : Vector α m) {l₂ : Vector α n} {i : Nat} (hi : i < m) :
l₁[i] = (l₁ ++ l₂)[i] := by
rw [getElem_append_left] <;> simp
/-- Variant of `getElem_append_right` useful for rewriting from the small array to the big array. -/
theorem getElem_append_right' (l₁ : Vector α m) {l₂ : Vector α n} {i : Nat} (hi : i < n) :
l₂[i] = (l₁ ++ l₂)[i + m] := by
rw [getElem_append_right] <;> simp [*, Nat.le_add_left]
theorem getElem_of_append {l : Vector α n} {l₁ : Vector α m} {l₂ : Vector α k}
(w : m + 1 + k = n) (eq : l = (l₁.push a ++ l₂).cast w) :
l[m] = a := Option.some.inj <| by
rw [ getElem?_eq_getElem, eq, getElem?_cast, getElem?_append_left (by simp)]
simp
@[simp 1100] theorem append_singleton {a : α} {as : Vector α n} : as ++ #v[a] = as.push a := by
cases as
simp
theorem append_inj {s₁ s₂ : Vector α n} {t₁ t₂ : Vector α m} (h : s₁ ++ t₁ = s₂ ++ t₂) :
s₁ = s₂ t₁ = t₂ := by
rcases s₁ with s₁, rfl
rcases s₂ with s₂, hs
rcases t₁ with t₁, rfl
rcases t₂ with t₂, ht
simpa using Array.append_inj (by simpa using h) (by omega)
theorem append_inj_right {s₁ s₂ : Vector α n} {t₁ t₂ : Vector α m}
(h : s₁ ++ t₁ = s₂ ++ t₂) : t₁ = t₂ :=
(append_inj h).right
theorem append_inj_left {s₁ s₂ : Vector α n} {t₁ t₂ : Vector α m}
(h : s₁ ++ t₁ = s₂ ++ t₂) : s₁ = s₂ :=
(append_inj h).left
theorem append_right_inj {t₁ t₂ : Vector α m} (s : Vector α n) : s ++ t₁ = s ++ t₂ t₁ = t₂ :=
fun h => append_inj_right h, congrArg _
theorem append_left_inj {s₁ s₂ : Vector α n} (t : Vector α m) : s₁ ++ t = s₂ ++ t s₁ = s₂ :=
fun h => append_inj_left h, congrArg (· ++ _)
theorem append_eq_append_iff {a : Vector α n} {b : Vector α m} {c : Vector α k} {d : Vector α l}
(w : k + l = n + m) :
a ++ b = (c ++ d).cast w
if h : n k then
a' : Vector α (k - n), c = (a ++ a').cast (by omega) b = (a' ++ d).cast (by omega)
else
c' : Vector α (n - k), a = (c ++ c').cast (by omega) d = (c' ++ b).cast (by omega) := by
rcases a with a, rfl
rcases b with b, rfl
rcases c with c, rfl
rcases d with d, rfl
simp only [mk_append_mk, Array.append_eq_append_iff, mk_eq, toArray_cast]
constructor
· rintro (a', rfl, rfl | c', rfl, rfl)
· rw [dif_pos (by simp)]
exact a'.toVector.cast (by simp; omega), by simp
· split <;> rename_i h
· have hc : c'.size = 0 := by simp at h; omega
simp at hc
exact #v[].cast (by simp; omega), by simp_all
· exact c'.toVector.cast (by simp; omega), by simp
· split <;> rename_i h
· rintro a', hc, rfl
left
refine a'.toArray, hc, rfl
· rintro c', ha, rfl
right
refine c'.toArray, ha, rfl
theorem set_append {s : Vector α n} {t : Vector α m} {i : Nat} {x : α} (h : i < n + m) :
(s ++ t).set i x =
if h' : i < n then
s.set i x ++ t
else
s ++ t.set (i - n) x := by
rcases s with s, rfl
rcases t with t, rfl
simp only [mk_append_mk, set_mk, Array.set_append]
split <;> simp
@[simp] theorem set_append_left {s : Vector α n} {t : Vector α m} {i : Nat} {x : α} (h : i < n) :
(s ++ t).set i x = s.set i x ++ t := by
simp [set_append, h]
@[simp] theorem set_append_right {s : Vector α n} {t : Vector α m} {i : Nat} {x : α}
(h' : i < n + m) (h : n i) :
(s ++ t).set i x = s ++ t.set (i - n) x := by
rw [set_append, dif_neg (by omega)]
theorem setIfInBounds_append {s : Vector α n} {t : Vector α m} {i : Nat} {x : α} :
(s ++ t).setIfInBounds i x =
if i < n then
s.setIfInBounds i x ++ t
else
s ++ t.setIfInBounds (i - n) x := by
rcases s with s, rfl
rcases t with t, rfl
simp only [mk_append_mk, setIfInBounds_mk, Array.setIfInBounds_append]
split <;> simp
@[simp] theorem setIfInBounds_append_left {s : Vector α n} {t : Vector α m} {i : Nat} {x : α} (h : i < n) :
(s ++ t).setIfInBounds i x = s.setIfInBounds i x ++ t := by
simp [setIfInBounds_append, h]
@[simp] theorem setIfInBounds_append_right {s : Vector α n} {t : Vector α m} {i : Nat} {x : α}
(h : n i) :
(s ++ t).setIfInBounds i x = s ++ t.setIfInBounds (i - n) x := by
rw [setIfInBounds_append, if_neg (by omega)]
@[simp] theorem map_append (f : α β) (l₁ : Vector α n) (l₂ : Vector α m) :
map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ := by
rcases l₁ with l₁, rfl
rcases l₂ with l₂, rfl
simp
theorem map_eq_append_iff {f : α β} :
map f l = L₁ ++ L₂ l₁ l₂, l = l₁ ++ l₂ map f l₁ = L₁ map f l₂ = L₂ := by
rcases l with l, h
rcases L₁ with L₁, rfl
rcases L₂ with L₂, rfl
simp only [map_mk, mk_append_mk, eq_mk, Array.map_eq_append_iff, mk_eq, toArray_append,
toArray_map]
constructor
· rintro l₁, l₂, rfl, rfl, rfl
exact l₁.toVector.cast (by simp), l₂.toVector.cast (by simp), by simp
· rintro l₁, l₂, rfl, h₁, h₂
exact l₁, l₂, by simp_all
theorem append_eq_map_iff {f : α β} :
L₁ ++ L₂ = map f l l₁ l₂, l = l₁ ++ l₂ map f l₁ = L₁ map f l₂ = L₂ := by
rw [eq_comm, map_eq_append_iff]
/-! ### flatten -/
@[simp] theorem flatten_mk (L : Array (Vector α n)) (h : L.size = m) :
(mk L h).flatten =
mk (L.map toArray).flatten (by simp [Function.comp_def, Array.map_const', h]) := by
simp [flatten]
@[simp] theorem flatten_singleton (l : Vector α n) : #v[l].flatten = l.cast (by simp) := by
simp [flatten]
theorem mem_flatten {L : Vector (Vector α n) m} : a L.flatten l, l L a l := by
rcases L with L, rfl
simp [Array.mem_flatten]
constructor
· rintro _, l, h₁, rfl, h₂
exact l, h₁, by simpa using h₂
· rintro l, h₁, h₂
exact l.toArray, l, h₁, rfl, by simpa using h₂
theorem exists_of_mem_flatten : a flatten L l, l L a l := mem_flatten.1
theorem mem_flatten_of_mem (lL : l L) (al : a l) : a flatten L := mem_flatten.2 l, lL, al
theorem forall_mem_flatten {p : α Prop} {L : Vector (Vector α n) m} :
( (x) (_ : x flatten L), p x) (l) (_ : l L) (x) (_ : x l), p x := by
simp only [mem_flatten, forall_exists_index, and_imp]
constructor <;> (intros; solve_by_elim)
@[simp] theorem map_flatten (f : α β) (L : Vector (Vector α n) m) :
(flatten L).map f = (map (map f) L).flatten := by
induction L using vector₂_induction with
| of xss h₁ h₂ => simp
@[simp] theorem flatten_append (L₁ : Vector (Vector α n) m₁) (L₂ : Vector (Vector α n) m₂) :
flatten (L₁ ++ L₂) = (flatten L₁ ++ flatten L₂).cast (by simp [Nat.add_mul]) := by
induction L₁ using vector₂_induction
induction L₂ using vector₂_induction
simp
theorem flatten_push (L : Vector (Vector α n) m) (l : Vector α n) :
flatten (L.push l) = (flatten L ++ l).cast (by simp [Nat.add_mul]) := by
induction L using vector₂_induction
rcases l with l
simp [Array.flatten_push]
theorem flatten_flatten {L : Vector (Vector (Vector α n) m) k} :
flatten (flatten L) = (flatten (map flatten L)).cast (by simp [Nat.mul_assoc]) := by
induction L using vector₃_induction with
| of xss h₁ h₂ h₃ =>
-- simp [Array.flatten_flatten] -- FIXME: `simp` produces a bad proof here!
simp [Array.map_attach, Array.flatten_flatten, Array.map_pmap]
/-- Two vectors of constant length vectors are equal iff their flattens coincide. -/
theorem eq_iff_flatten_eq {L L' : Vector (Vector α n) m} :
L = L' L.flatten = L'.flatten := by
induction L using vector₂_induction with | of L h₁ h₂ =>
induction L' using vector₂_induction with | of L' h₁' h₂' =>
simp only [eq_mk, flatten_mk, Array.map_map, Function.comp_apply, Array.map_subtype,
Array.unattach_attach, Array.map_id_fun', id_eq]
constructor
· intro h
suffices L = L' by simp_all
apply Array.ext_getElem?
intro i
replace h := congrArg (fun x => x[i]?.map (fun x => x.toArray)) h
simpa [Option.map_pmap] using h
· intro h
have w : L.map Array.size = L'.map Array.size := by
ext i h h'
· simp_all
· simp only [Array.getElem_map]
rw [h₂ _ (by simp), h₂' _ (by simp)]
have := Array.eq_iff_flatten_eq.mpr h, w
subst this
rfl
/-! ### flatMap -/
@[simp] theorem flatMap_mk (l : Array α) (h : l.size = m) (f : α Vector β n) :
(mk l h).flatMap f =
mk (l.flatMap (fun a => (f a).toArray)) (by simp [Array.map_const', h]) := by
simp [flatMap]
@[simp] theorem flatMap_toArray (l : Vector α n) (f : α Vector β m) :
l.toArray.flatMap (fun a => (f a).toArray) = (l.flatMap f).toArray := by
rcases l with l, rfl
simp
theorem flatMap_def (l : Vector α n) (f : α Vector β m) : l.flatMap f = flatten (map f l) := by
rcases l with l, rfl
simp [Array.flatMap_def, Function.comp_def]
@[simp] theorem flatMap_id (l : Vector (Vector α m) n) : l.flatMap id = l.flatten := by simp [flatMap_def]
@[simp] theorem flatMap_id' (l : Vector (Vector α m) n) : l.flatMap (fun a => a) = l.flatten := by simp [flatMap_def]
@[simp] theorem mem_flatMap {f : α Vector β m} {b} {l : Vector α n} : b l.flatMap f a, a l b f a := by
simp [flatMap_def, mem_flatten]
exact fun _, a, h₁, rfl, h₂ => a, h₁, h₂, fun a, h₁, h₂ => _, a, h₁, rfl, h₂
theorem exists_of_mem_flatMap {b : β} {l : Vector α n} {f : α Vector β m} :
b l.flatMap f a, a l b f a := mem_flatMap.1
theorem mem_flatMap_of_mem {b : β} {l : Vector α n} {f : α Vector β m} {a} (al : a l) (h : b f a) :
b l.flatMap f := mem_flatMap.2 a, al, h
theorem forall_mem_flatMap {p : β Prop} {l : Vector α n} {f : α Vector β m} :
( (x) (_ : x l.flatMap f), p x) (a) (_ : a l) (b) (_ : b f a), p b := by
simp only [mem_flatMap, forall_exists_index, and_imp]
constructor <;> (intros; solve_by_elim)
theorem flatMap_singleton (f : α Vector β m) (x : α) : #v[x].flatMap f = (f x).cast (by simp) := by
simp [flatMap_def]
@[simp] theorem flatMap_singleton' (l : Vector α n) : (l.flatMap fun x => #v[x]) = l.cast (by simp) := by
rcases l with l, rfl
simp
@[simp] theorem flatMap_append (xs ys : Vector α n) (f : α Vector β m) :
(xs ++ ys).flatMap f = (xs.flatMap f ++ ys.flatMap f).cast (by simp [Nat.add_mul]) := by
rcases xs with xs
rcases ys with ys
simp [flatMap_def, flatten_append]
theorem flatMap_assoc {α β} (l : Vector α n) (f : α Vector β m) (g : β Vector γ k) :
(l.flatMap f).flatMap g = (l.flatMap fun x => (f x).flatMap g).cast (by simp [Nat.mul_assoc]) := by
rcases l with l, rfl
simp [Array.flatMap_assoc]
theorem map_flatMap (f : β γ) (g : α Vector β m) (l : Vector α n) :
(l.flatMap g).map f = l.flatMap fun a => (g a).map f := by
rcases l with l, rfl
simp [Array.map_flatMap]
theorem flatMap_map (f : α β) (g : β Vector γ k) (l : Vector α n) :
(map f l).flatMap g = l.flatMap (fun a => g (f a)) := by
rcases l with l, rfl
simp [Array.flatMap_map]
theorem map_eq_flatMap {α β} (f : α β) (l : Vector α n) :
map f l = (l.flatMap fun x => #v[f x]).cast (by simp) := by
rcases l with l, rfl
simp [Array.map_eq_flatMap]
/-! Content below this point has not yet been aligned with `List` and `Array`. -/
@[simp] theorem getElem_ofFn {α n} (f : Fin n α) (i : Nat) (h : i < n) :
@@ -1634,6 +1197,28 @@ defeq issues in the implicit size argument.
subst h
simp [pop, back, back!, Array.eq_push_pop_back!_of_size_ne_zero]
/-! ### append -/
theorem getElem_append (a : Vector α n) (b : Vector α m) (i : Nat) (hi : i < n + m) :
(a ++ b)[i] = if h : i < n then a[i] else b[i - n] := by
rcases a with a, rfl
rcases b with b, rfl
simp [Array.getElem_append, hi]
theorem getElem_append_left {a : Vector α n} {b : Vector α m} {i : Nat} (hi : i < n) :
(a ++ b)[i] = a[i] := by simp [getElem_append, hi]
theorem getElem_append_right {a : Vector α n} {b : Vector α m} {i : Nat} (h : i < n + m) (hi : n i) :
(a ++ b)[i] = b[i - n] := by
rw [getElem_append, dif_neg (by omega)]
/-! ### cast -/
@[simp] theorem getElem_cast (a : Vector α n) (h : n = m) (i : Nat) (hi : i < m) :
(a.cast h)[i] = a[i] := by
cases a
simp
/-! ### extract -/
@[simp] theorem getElem_extract (a : Vector α n) (start stop) (i : Nat) (hi : i < min stop n - start) :

View File

@@ -11,4 +11,3 @@ import Init.Grind.Cases
import Init.Grind.Propagator
import Init.Grind.Util
import Init.Grind.Offset
import Init.Grind.PP

View File

@@ -12,9 +12,6 @@ import Init.Grind.Util
namespace Lean.Grind
theorem rfl_true : true = true :=
rfl
theorem intro_with_eq (p p' q : Prop) (he : p = p') (h : p' q) : p q :=
fun hp => h (he.mp hp)
@@ -69,12 +66,6 @@ theorem eq_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a = b) = a := by s
theorem eq_congr {α : Sort u} {a₁ b₁ a₂ b₂ : α} (h₁ : a₁ = a₂) (h₂ : b₁ = b₂) : (a₁ = b₁) = (a₂ = b₂) := by simp [*]
theorem eq_congr' {α : Sort u} {a₁ b₁ a₂ b₂ : α} (h₁ : a₁ = b₂) (h₂ : b₁ = a₂) : (a₁ = b₁) = (a₂ = b₂) := by rw [h₁, h₂, Eq.comm (a := a₂)]
/- The following two helper theorems are used to case-split `a = b` representing `iff`. -/
theorem of_eq_eq_true {a b : Prop} (h : (a = b) = True) : (¬a b) (¬b a) := by
by_cases a <;> by_cases b <;> simp_all
theorem of_eq_eq_false {a b : Prop} (h : (a = b) = False) : (¬a ¬b) (b a) := by
by_cases a <;> by_cases b <;> simp_all
/-! Forall -/
theorem forall_propagator (p : Prop) (q : p Prop) (q' : Prop) (h₁ : p = True) (h₂ : q (of_eq_true h₁) = q') : ( hp : p, q hp) = q' := by

View File

@@ -46,12 +46,6 @@ attribute [grind_norm] not_false_eq_true
theorem imp_eq (p q : Prop) : (p q) = (¬ p q) := by
by_cases p <;> by_cases q <;> simp [*]
@[grind_norm] theorem true_imp_eq (p : Prop) : (True p) = p := by simp
@[grind_norm] theorem false_imp_eq (p : Prop) : (False p) = True := by simp
@[grind_norm] theorem imp_true_eq (p : Prop) : (p True) = True := by simp
@[grind_norm] theorem imp_false_eq (p : Prop) : (p False) = ¬p := by simp
@[grind_norm] theorem imp_self_eq (p : Prop) : (p p) = True := by simp
-- And
@[grind_norm] theorem not_and (p q : Prop) : (¬(p q)) = (¬p ¬q) := by
by_cases p <;> by_cases q <;> simp [*]

View File

@@ -7,86 +7,159 @@ prelude
import Init.Core
import Init.Omega
namespace Lean.Grind
abbrev isLt (x y : Nat) : Bool := x < y
abbrev isLE (x y : Nat) : Bool := x y
namespace Lean.Grind.Offset
/-! Theorems for transitivity. -/
theorem Nat.le_ro (u w v k : Nat) : u w w v + k u v + k := by
omega
theorem Nat.le_lo (u w v k : Nat) : u w w + k v u + k v := by
omega
theorem Nat.lo_le (u w v k : Nat) : u + k w w v u + k v := by
omega
theorem Nat.lo_lo (u w v k₁ k₂ : Nat) : u + k₁ w w + k₂ v u + (k₁ + k₂) v := by
omega
theorem Nat.lo_ro_1 (u w v k₁ k₂ : Nat) : isLt k₂ k₁ = true u + k₁ w w v + k₂ u + (k₁ - k₂) v := by
simp [isLt]; omega
theorem Nat.lo_ro_2 (u w v k₁ k₂ : Nat) : u + k₁ w w v + k₂ u v + (k₂ - k₁) := by
omega
theorem Nat.ro_le (u w v k : Nat) : u w + k w v u v + k := by
omega
theorem Nat.ro_lo_1 (u w v k₁ k₂ : Nat) : u w + k₁ w + k₂ v u v + (k₁ - k₂) := by
omega
theorem Nat.ro_lo_2 (u w v k₁ k₂ : Nat) : isLt k₁ k₂ = true u w + k₁ w + k₂ v u + (k₂ - k₁) v := by
simp [isLt]; omega
theorem Nat.ro_ro (u w v k₁ k₂ : Nat) : u w + k₁ w v + k₂ u v + (k₁ + k₂) := by
omega
abbrev Var := Nat
abbrev Context := Lean.RArray Nat
/-! Theorems for negating constraints. -/
theorem Nat.of_le_eq_false (u v : Nat) : ((u v) = False) v + 1 u := by
simp; omega
theorem Nat.of_lo_eq_false_1 (u v : Nat) : ((u + 1 v) = False) v u := by
simp; omega
theorem Nat.of_lo_eq_false (u v k : Nat) : ((u + k v) = False) v u + (k-1) := by
simp; omega
theorem Nat.of_ro_eq_false (u v k : Nat) : ((u v + k) = False) v + (k+1) u := by
simp; omega
def fixedVar := 100000000 -- Any big number should work here
/-! Theorems for closing a goal. -/
theorem Nat.unsat_le_lo (u v k : Nat) : isLt 0 k = true u v v + k u False := by
simp [isLt]; omega
theorem Nat.unsat_lo_lo (u v k₁ k₂ : Nat) : isLt 0 (k₁+k₂) = true u + k₁ v v + k₂ u False := by
simp [isLt]; omega
theorem Nat.unsat_lo_ro (u v k₁ k₂ : Nat) : isLt k₂ k₁ = true u + k₁ v v u + k₂ False := by
simp [isLt]; omega
def Var.denote (ctx : Context) (v : Var) : Nat :=
bif v == fixedVar then 1 else ctx.get v
/-! Theorems for propagating constraints to `True` -/
theorem Nat.lo_eq_true_of_lo (u v k₁ k₂ : Nat) : isLE k₂ k₁ = true u + k₁ v (u + k₂ v) = True :=
by simp [isLt]; omega
theorem Nat.le_eq_true_of_lo (u v k : Nat) : u + k v (u v) = True :=
by simp; omega
theorem Nat.le_eq_true_of_le (u v : Nat) : u v (u v) = True :=
by simp
theorem Nat.ro_eq_true_of_lo (u v k₁ k₂ : Nat) : u + k₁ v (u v + k₂) = True :=
by simp; omega
theorem Nat.ro_eq_true_of_le (u v k : Nat) : u v (u v + k) = True :=
by simp; omega
theorem Nat.ro_eq_true_of_ro (u v k₁ k₂ : Nat) : isLE k₁ k₂ = true u v + k₁ (u v + k₂) = True :=
by simp [isLE]; omega
structure Cnstr where
x : Var
y : Var
k : Nat := 0
l : Bool := true
deriving Repr, DecidableEq, Inhabited
/-!
Theorems for propagating constraints to `False`.
They are variants of the theorems for closing a goal.
-/
theorem Nat.lo_eq_false_of_le (u v k : Nat) : isLt 0 k = true u v (v + k u) = False := by
simp [isLt]; omega
theorem Nat.le_eq_false_of_lo (u v k : Nat) : isLt 0 k = true u + k v (v u) = False := by
simp [isLt]; omega
theorem Nat.lo_eq_false_of_lo (u v k₁ k₂ : Nat) : isLt 0 (k₁+k₂) = true u + k₁ v (v + k₂ u) = False := by
simp [isLt]; omega
theorem Nat.ro_eq_false_of_lo (u v k₁ k₂ : Nat) : isLt k₂ k₁ = true u + k₁ v (v u + k₂) = False := by
simp [isLt]; omega
theorem Nat.lo_eq_false_of_ro (u v k₁ k₂ : Nat) : isLt k₁ k₂ = true u v + k₁ (v + k₂ u) = False := by
simp [isLt]; omega
def Cnstr.denote (c : Cnstr) (ctx : Context) : Prop :=
if c.l then
c.x.denote ctx + c.k c.y.denote ctx
else
c.x.denote ctx c.y.denote ctx + c.k
/-!
Helper theorems for equality propagation
-/
def trivialCnstr : Cnstr := { x := 0, y := 0, k := 0, l := true }
theorem Nat.le_of_eq_1 (u v : Nat) : u = v u v := by omega
theorem Nat.le_of_eq_2 (u v : Nat) : u = v v u := by omega
theorem Nat.eq_of_le_of_le (u v : Nat) : u v v u u = v := by omega
theorem Nat.le_offset (a k : Nat) : k a + k := by omega
@[simp] theorem denote_trivial (ctx : Context) : trivialCnstr.denote ctx := by
simp [Cnstr.denote, trivialCnstr]
end Lean.Grind
def Cnstr.trans (c₁ c₂ : Cnstr) : Cnstr :=
if c₁.y = c₂.x then
let { x, k := k₁, l := l₁, .. } := c₁
let { y, k := k₂, l := l₂, .. } := c₂
match l₁, l₂ with
| false, false =>
{ x, y, k := k₁ + k₂, l := false }
| false, true =>
if k₁ < k₂ then
{ x, y, k := k₂ - k₁, l := true }
else
{ x, y, k := k₁ - k₂, l := false }
| true, false =>
if k₁ < k₂ then
{ x, y, k := k₂ - k₁, l := false }
else
{ x, y, k := k₁ - k₂, l := true }
| true, true =>
{ x, y, k := k₁ + k₂, l := true }
else
trivialCnstr
@[simp] theorem Cnstr.denote_trans_easy (ctx : Context) (c₁ c₂ : Cnstr) (h : c₁.y c₂.x) : (c₁.trans c₂).denote ctx := by
simp [*, Cnstr.trans]
@[simp] theorem Cnstr.denote_trans (ctx : Context) (c₁ c₂ : Cnstr) : c₁.denote ctx c₂.denote ctx (c₁.trans c₂).denote ctx := by
by_cases c₁.y = c₂.x
case neg => simp [*]
simp [trans, *]
let { x, k := k₁, l := l₁, .. } := c₁
let { y, k := k₂, l := l₂, .. } := c₂
simp_all; split
· simp [denote]; omega
· split <;> simp [denote] <;> omega
· split <;> simp [denote] <;> omega
· simp [denote]; omega
def Cnstr.isTrivial (c : Cnstr) : Bool := c.x == c.y && c.k == 0
theorem Cnstr.of_isTrivial (ctx : Context) (c : Cnstr) : c.isTrivial = true c.denote ctx := by
cases c; simp [isTrivial]; intros; simp [*, denote]
def Cnstr.isFalse (c : Cnstr) : Bool := c.x == c.y && c.k != 0 && c.l == true
theorem Cnstr.of_isFalse (ctx : Context) {c : Cnstr} : c.isFalse = true ¬c.denote ctx := by
cases c; simp [isFalse]; intros; simp [*, denote]; omega
def Cnstrs := List Cnstr
def Cnstrs.denoteAnd' (ctx : Context) (c₁ : Cnstr) (c₂ : Cnstrs) : Prop :=
match c₂ with
| [] => c₁.denote ctx
| c::cs => c₁.denote ctx Cnstrs.denoteAnd' ctx c cs
theorem Cnstrs.denote'_trans (ctx : Context) (c₁ c : Cnstr) (cs : Cnstrs) : c₁.denote ctx denoteAnd' ctx c cs denoteAnd' ctx (c₁.trans c) cs := by
induction cs
next => simp [denoteAnd', *]; apply Cnstr.denote_trans
next c cs ih => simp [denoteAnd']; intros; simp [*]
def Cnstrs.trans' (c₁ : Cnstr) (c₂ : Cnstrs) : Cnstr :=
match c₂ with
| [] => c₁
| c::c₂ => trans' (c₁.trans c) c₂
@[simp] theorem Cnstrs.denote'_trans' (ctx : Context) (c₁ : Cnstr) (c₂ : Cnstrs) : denoteAnd' ctx c₁ c₂ (trans' c₁ c₂).denote ctx := by
induction c₂ generalizing c₁
next => intros; simp_all [trans', denoteAnd']
next c cs ih => simp [denoteAnd']; intros; simp [trans']; apply ih; apply denote'_trans <;> assumption
def Cnstrs.denoteAnd (ctx : Context) (c : Cnstrs) : Prop :=
match c with
| [] => True
| c::cs => denoteAnd' ctx c cs
def Cnstrs.trans (c : Cnstrs) : Cnstr :=
match c with
| [] => trivialCnstr
| c::cs => trans' c cs
theorem Cnstrs.of_denoteAnd_trans {ctx : Context} {c : Cnstrs} : c.denoteAnd ctx c.trans.denote ctx := by
cases c <;> simp [*, trans, denoteAnd] <;> intros <;> simp [*]
def Cnstrs.isFalse (c : Cnstrs) : Bool :=
c.trans.isFalse
theorem Cnstrs.unsat' (ctx : Context) (c : Cnstrs) : c.isFalse = true ¬ c.denoteAnd ctx := by
simp [isFalse]; intro h₁ h₂
have := of_denoteAnd_trans h₂
have := Cnstr.of_isFalse ctx h₁
contradiction
/-- `denote ctx [c_1, ..., c_n] C` is `c_1.denote ctx → ... → c_n.denote ctx → C` -/
def Cnstrs.denote (ctx : Context) (cs : Cnstrs) (C : Prop) : Prop :=
match cs with
| [] => C
| c::cs => c.denote ctx denote ctx cs C
theorem Cnstrs.not_denoteAnd'_eq (ctx : Context) (c : Cnstr) (cs : Cnstrs) (C : Prop) : (denoteAnd' ctx c cs C) = denote ctx (c::cs) C := by
simp [denote]
induction cs generalizing c
next => simp [denoteAnd', denote]
next c' cs ih =>
simp [denoteAnd', denote, *]
theorem Cnstrs.not_denoteAnd_eq (ctx : Context) (cs : Cnstrs) (C : Prop) : (denoteAnd ctx cs C) = denote ctx cs C := by
cases cs
next => simp [denoteAnd, denote]
next c cs => apply not_denoteAnd'_eq
def Cnstr.isImpliedBy (cs : Cnstrs) (c : Cnstr) : Bool :=
cs.trans == c
/-! Main theorems used by `grind`. -/
/-- Auxiliary theorem used by `grind` to prove that a system of offset inequalities is unsatisfiable. -/
theorem Cnstrs.unsat (ctx : Context) (cs : Cnstrs) : cs.isFalse = true cs.denote ctx False := by
intro h
rw [ not_denoteAnd_eq]
apply unsat'
assumption
/-- Auxiliary theorem used by `grind` to prove an implied offset inequality. -/
theorem Cnstrs.imp (ctx : Context) (cs : Cnstrs) (c : Cnstr) (h : c.isImpliedBy cs = true) : cs.denote ctx (c.denote ctx) := by
rw [ eq_of_beq h]
rw [ not_denoteAnd_eq]
apply of_denoteAnd_trans
end Lean.Grind.Offset

View File

@@ -1,30 +0,0 @@
/-
Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.NotationExtra
namespace Lean.Grind
/-!
This is a hackish module for hovering node information in the `grind` tactic state.
-/
inductive NodeDef where
| unit
set_option linter.unusedVariables false in
def node_def (_ : Nat) {α : Sort u} {a : α} : NodeDef := .unit
@[app_unexpander node_def]
def nodeDefUnexpander : PrettyPrinter.Unexpander := fun stx => do
match stx with
| `($_ $id:num) => return mkIdent <| Name.mkSimple $ "#" ++ toString id.getNat
| _ => throw ()
@[app_unexpander NodeDef]
def NodeDefUnexpander : PrettyPrinter.Unexpander := fun _ => do
return mkIdent <| Name.mkSimple "NodeDef"
end Lean.Grind

View File

@@ -25,7 +25,7 @@ Passed to `grind` using, for example, the `grind (config := { matchEqs := true }
-/
structure Config where
/-- Maximum number of case-splits in a proof search branch. It does not include splits performed during normalization. -/
splits : Nat := 8
splits : Nat := 5
/-- Maximum number of E-matching (aka heuristic theorem instantiation) rounds before each case split. -/
ematch : Nat := 5
/--
@@ -45,10 +45,6 @@ structure Config where
If `splitIndPred` is `true`, `grind` performs case-splitting on inductive predicates.
Otherwise, it performs case-splitting only on types marked with `[grind_split]` attribute. -/
splitIndPred : Bool := true
/-- By default, `grind` halts as soon as it encounters a sub-goal where no further progress can be made. -/
failures : Nat := 1
/-- Maximum number of heartbeats (in thousands) the canonicalizer can spend per definitional equality test. -/
canonHeartbeats : Nat := 1000
deriving Inhabited, BEq
end Lean.Grind

View File

@@ -9,7 +9,7 @@ import Init.Core
namespace Lean.Grind
/-- A helper gadget for annotating nested proofs in goals. -/
def nestedProof (p : Prop) {h : p} : p := h
def nestedProof (p : Prop) (h : p) : p := h
/--
Gadget for marking terms that should not be normalized by `grind`s simplifier.
@@ -28,7 +28,7 @@ When `EqMatch a b origin` is `True`, we mark `origin` as a resolved case-split.
-/
def EqMatch (a b : α) {_origin : α} : Prop := a = b
theorem nestedProof_congr (p q : Prop) (h : p = q) (hp : p) (hq : q) : HEq (@nestedProof p hp) (@nestedProof q hq) := by
theorem nestedProof_congr (p q : Prop) (h : p = q) (hp : p) (hq : q) : HEq (nestedProof p hp) (nestedProof q hq) := by
subst h; apply HEq.refl
end Lean.Grind

View File

@@ -21,6 +21,11 @@ def Environment.addDecl (env : Environment) (opts : Options) (decl : Declaration
else
addDeclCore env (Core.getMaxHeartbeats opts).toUSize decl cancelTk?
def Environment.addAndCompile (env : Environment) (opts : Options) (decl : Declaration)
(cancelTk? : Option IO.CancelToken := none) : Except KernelException Environment := do
let env addDecl env opts decl cancelTk?
compileDecl env opts decl
def addDecl (decl : Declaration) : CoreM Unit := do
profileitM Exception "type checking" ( getOptions) do
withTraceNode `Kernel (fun _ => return m!"typechecking declaration") do

View File

@@ -85,7 +85,7 @@ partial def eraseProjIncForAux (y : VarId) (bs : Array FnBody) (mask : Mask) (ke
/-- Try to erase `inc` instructions on projections of `y` occurring in the tail of `bs`.
Return the updated `bs` and a bit mask specifying which `inc`s have been removed. -/
def eraseProjIncFor (n : Nat) (y : VarId) (bs : Array FnBody) : Array FnBody × Mask :=
eraseProjIncForAux y bs (Array.replicate n none) #[]
eraseProjIncForAux y bs (mkArray n none) #[]
/-- Replace `reuse x ctor ...` with `ctor ...`, and remove `dec x` -/
partial def reuseToCtor (x : VarId) : FnBody FnBody

View File

@@ -144,7 +144,11 @@ def declareBuiltin (forDecl : Name) (value : Expr) : CoreM Unit := do
let type := mkApp (mkConst `IO) (mkConst `Unit)
let decl := Declaration.defnDecl { name, levelParams := [], type, value, hints := ReducibilityHints.opaque,
safety := DefinitionSafety.safe }
addAndCompile decl
IO.ofExcept (setBuiltinInitAttr ( getEnv) name) >>= setEnv
match ( getEnv).addAndCompile {} decl with
-- TODO: pretty print error
| Except.error e => do
let msg (e.toMessageData {}).toString
throwError "failed to emit registration code for builtin '{forDecl}': {msg}"
| Except.ok env => IO.ofExcept (setBuiltinInitAttr env name) >>= setEnv
end Lean

View File

@@ -169,7 +169,7 @@ def mkFixedParamsMap (decls : Array Decl) : NameMap (Array Bool) := Id.run do
for decl in decls do
let values := mkInitialValues decl.params.size
let assignment := mkAssignment decl values
let fixed := Array.replicate decl.params.size true
let fixed := Array.mkArray decl.params.size true
match decl.value with
| .code c =>
match evalCode c |>.run { main := decl, decls, assignment } |>.run { fixed } with

View File

@@ -74,6 +74,8 @@ partial def toMonoType (type : Expr) : CoreM Expr := do
let type := type.headBeta
if type.isErased then
return erasedExpr
else if type.isErased then
return erasedExpr
else if isTypeFormerType type then
return erasedExpr
else match type with

View File

@@ -98,7 +98,7 @@ where
return { ctx with discrCtorMap := ctx.discrCtorMap.insert discr ctorInfo, ctorDiscrMap := ctx.ctorDiscrMap.insert ctor.toExpr discr }
else
-- For the discrCtor map, the constructor parameters are irrelevant for optimizations that use this information
let ctorInfo := .ctor ctorVal (Array.replicate ctorVal.numParams Arg.erased ++ fieldArgs)
let ctorInfo := .ctor ctorVal (mkArray ctorVal.numParams Arg.erased ++ fieldArgs)
return { ctx with discrCtorMap := ctx.discrCtorMap.insert discr ctorInfo }
@[inline, inherit_doc withDiscrCtorImp] def withDiscrCtor [MonadFunctorT DiscrM m] (discr : FVarId) (ctorName : Name) (ctorFields : Array Param) : m α m α :=

View File

@@ -147,7 +147,7 @@ def saveSpecParamInfo (decls : Array Decl) : CompilerM Unit := do
let mut declsInfo := #[]
for decl in decls do
if hasNospecializeAttribute ( getEnv) decl.name then
declsInfo := declsInfo.push (Array.replicate decl.params.size .other)
declsInfo := declsInfo.push (mkArray decl.params.size .other)
else
let specArgs? := getSpecializationArgs? ( getEnv) decl.name
let contains (i : Nat) : Bool := specArgs?.getD #[] |>.contains i

View File

@@ -53,3 +53,18 @@ def isUnsafeRecName? : Name → Option Name
| _ => none
end Compiler
namespace Environment
/--
Compile the given block of mutual declarations.
Assumes the declarations have already been added to the environment using `addDecl`.
-/
@[extern "lean_compile_decls"]
opaque compileDecls (env : Environment) (opt : @& Options) (decls : @& List Name) : Except KernelException Environment
/-- Compile the given declaration, it assumes the declaration has already been added to the environment using `addDecl`. -/
def compileDecl (env : Environment) (opt : @& Options) (decl : @& Declaration) : Except KernelException Environment :=
compileDecls env opt (Compiler.getDeclNamesForCodeGen decl)
end Environment

View File

@@ -514,16 +514,13 @@ register_builtin_option compiler.enableNew : Bool := {
@[extern "lean_lcnf_compile_decls"]
opaque compileDeclsNew (declNames : List Name) : CoreM Unit
@[extern "lean_compile_decls"]
opaque compileDeclsOld (env : Environment) (opt : @& Options) (decls : @& List Name) : Except KernelException Environment
def compileDecl (decl : Declaration) : CoreM Unit := do
let opts getOptions
let decls := Compiler.getDeclNamesForCodeGen decl
if compiler.enableNew.get opts then
compileDeclsNew decls
let res withTraceNode `compiler (fun _ => return m!"compiling old: {decls}") do
return compileDeclsOld ( getEnv) opts decls
return ( getEnv).compileDecl opts decl
match res with
| Except.ok env => setEnv env
| Except.error (KernelException.other msg) =>
@@ -536,7 +533,7 @@ def compileDecls (decls : List Name) : CoreM Unit := do
let opts getOptions
if compiler.enableNew.get opts then
compileDeclsNew decls
match compileDeclsOld ( getEnv) opts decls with
match ( getEnv).compileDecls opts decls with
| Except.ok env => setEnv env
| Except.error (KernelException.other msg) =>
throwError msg

View File

@@ -24,7 +24,7 @@ order, exists in the array.
-/
def filterPairsM {m} [Monad m] {α} (a : Array α) (f : α α m (Bool × Bool)) :
m (Array α) := do
let mut removed := Array.replicate a.size false
let mut removed := Array.mkArray a.size false
let mut numRemoved := 0
for h1 : i in [:a.size] do for h2 : j in [i+1:a.size] do
unless removed[i]! || removed[j]! do

View File

@@ -24,7 +24,7 @@ abbrev empty : AssocList α β :=
instance : EmptyCollection (AssocList α β) := empty
abbrev insertNew (m : AssocList α β) (k : α) (v : β) : AssocList α β :=
abbrev insert (m : AssocList α β) (k : α) (v : β) : AssocList α β :=
m.cons k v
def isEmpty : AssocList α β Bool
@@ -77,12 +77,6 @@ def replace [BEq α] (a : α) (b : β) : AssocList α β → AssocList α β
| true => cons a b es
| false => cons k v (replace a b es)
def insert [BEq α] (m : AssocList α β) (k : α) (v : β) : AssocList α β :=
if m.contains k then
m.replace k v
else
m.insertNew k v
def erase [BEq α] (a : α) : AssocList α β AssocList α β
| nil => nil
| cons k v es => match k == a with

View File

@@ -99,11 +99,11 @@ private def fuzzyMatchCore (pattern word : String) (patternRoles wordRoles : Arr
between the substrings pattern[:i+1] and word[:j+1] assuming that pattern[i] misses at word[j] (k = 0, i.e.
it was matched earlier), or matches at word[j] (k = 1). A value of `none` corresponds to a score of -∞, and is used
where no such match/miss is possible or for unneeded parts of the table. -/
let mut result : Array (Option Int) := Array.replicate (pattern.length * word.length * 2) none
let mut runLengths : Array Int := Array.replicate (pattern.length * word.length) 0
let mut result : Array (Option Int) := Array.mkArray (pattern.length * word.length * 2) none
let mut runLengths : Array Int := Array.mkArray (pattern.length * word.length) 0
-- penalty for starting a consecutive run at each index
let mut startPenalties : Array Int := Array.replicate word.length 0
let mut startPenalties : Array Int := Array.mkArray word.length 0
let mut lastSepIdx := 0
let mut penaltyNs : Int := 0
@@ -124,8 +124,8 @@ private def fuzzyMatchCore (pattern word : String) (patternRoles wordRoles : Arr
`word.length - pattern.length` at each index (because at the very end, we can only consider fuzzy matches
of `pattern` with a longer substring of `word`). -/
for wordIdx in [patternIdx:word.length-(pattern.length - patternIdx - 1)] do
let missScore? :=
if wordIdx >= 1 then
let missScore? :=
if wordIdx >= 1 then
selectBest
(getMiss result patternIdx (wordIdx - 1))
(getMatch result patternIdx (wordIdx - 1))
@@ -134,7 +134,7 @@ private def fuzzyMatchCore (pattern word : String) (patternRoles wordRoles : Arr
let mut matchScore? := none
if allowMatch (pattern.get patternIdx) (word.get wordIdx) (patternRoles.get! patternIdx) (wordRoles.get! wordIdx) then
if patternIdx >= 1 then
if patternIdx >= 1 then
let runLength := runLengths.get! (getIdx (patternIdx - 1) (wordIdx - 1)) + 1
runLengths := runLengths.set! (getIdx patternIdx wordIdx) runLength
@@ -213,7 +213,7 @@ private def fuzzyMatchCore (pattern word : String) (patternRoles wordRoles : Arr
/- Consecutive character match. -/
if let some bonus := consecutive then
/- consecutive run bonus -/
score := score + bonus
score := score + bonus
return score
/-- Match the given pattern with the given word using a fuzzy matching

View File

@@ -32,7 +32,7 @@ private def numBucketsForCapacity (capacity : Nat) : Nat :=
def mkHashMapImp {α : Type u} {β : Type v} (capacity := 8) : HashMapImp α β :=
{ size := 0
buckets :=
Array.replicate (numBucketsForCapacity capacity).nextPowerOfTwo AssocList.nil,
mkArray (numBucketsForCapacity capacity).nextPowerOfTwo AssocList.nil,
by simp; apply Nat.isPowerOfTwo_nextPowerOfTwo }
namespace HashMapImp
@@ -101,7 +101,7 @@ decreasing_by simp_wf; decreasing_trivial_pre_omega
def expand [Hashable α] (size : Nat) (buckets : HashMapBucket α β) : HashMapImp α β :=
let bucketsNew : HashMapBucket α β :=
Array.replicate (buckets.val.size * 2) AssocList.nil,
mkArray (buckets.val.size * 2) AssocList.nil,
by simp; apply Nat.mul2_isPowerOfTwo_of_isPowerOfTwo buckets.property
{ size := size,

View File

@@ -28,7 +28,7 @@ structure HashSetImp (α : Type u) where
def mkHashSetImp {α : Type u} (capacity := 8) : HashSetImp α :=
{ size := 0
buckets :=
Array.replicate ((capacity * 4) / 3).nextPowerOfTwo [],
mkArray ((capacity * 4) / 3).nextPowerOfTwo [],
by simp; apply Nat.isPowerOfTwo_nextPowerOfTwo }
namespace HashSetImp
@@ -92,7 +92,7 @@ decreasing_by simp_wf; decreasing_trivial_pre_omega
def expand [Hashable α] (size : Nat) (buckets : HashSetBucket α) : HashSetImp α :=
let bucketsNew : HashSetBucket α :=
Array.replicate (buckets.val.size * 2) [],
mkArray (buckets.val.size * 2) [],
by simp; apply Nat.mul2_isPowerOfTwo_of_isPowerOfTwo buckets.property
{ size := size,

View File

@@ -39,7 +39,7 @@ abbrev maxDepth : USize := 7
abbrev maxCollisions : Nat := 4
def mkEmptyEntriesArray {α β} : Array (Entry α β (Node α β)) :=
(Array.replicate PersistentHashMap.branching.toNat PersistentHashMap.Entry.null)
(Array.mkArray PersistentHashMap.branching.toNat PersistentHashMap.Entry.null)
end PersistentHashMap

View File

@@ -1474,7 +1474,7 @@ where
| field::fields, false => .fieldName field field.getId.getString! none fIdent :: toLVals fields false
/-- Resolve `(.$id:ident)` using the expected type to infer namespace. -/
private partial def resolveDotName (id : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
private partial def resolveDotName (id : Syntax) (expectedType? : Option Expr) : TermElabM Name := do
tryPostponeIfNoneOrMVar expectedType?
let some expectedType := expectedType?
| throwError "invalid dotted identifier notation, expected type must be known"
@@ -1489,7 +1489,7 @@ where
withForallBody body k
else
k body
go (resultType : Expr) (expectedType : Expr) (previousExceptions : Array Exception) : TermElabM Expr := do
go (resultType : Expr) (expectedType : Expr) (previousExceptions : Array Exception) : TermElabM Name := do
let resultType instantiateMVars resultType
let resultTypeFn := resultType.cleanupAnnotations.getAppFn
try
@@ -1497,12 +1497,9 @@ where
let .const declName .. := resultTypeFn.cleanupAnnotations
| throwError "invalid dotted identifier notation, expected type is not of the form (... → C ...) where C is a constant{indentExpr expectedType}"
let idNew := declName ++ id.getId.eraseMacroScopes
if ( getEnv).contains idNew then
mkConst idNew
else if let some (fvar, []) resolveLocalName idNew then
return fvar
else
unless ( getEnv).contains idNew do
throwError "invalid dotted identifier notation, unknown identifier `{idNew}` from expected type{indentExpr expectedType}"
return idNew
catch
| ex@(.error ..) =>
match ( unfoldDefinition? resultType) with
@@ -1551,7 +1548,7 @@ private partial def elabAppFn (f : Syntax) (lvals : List LVal) (namedArgs : Arra
| `(_) => throwError "placeholders '_' cannot be used where a function is expected"
| `(.$id:ident) =>
addCompletionInfo <| CompletionInfo.dotId f id.getId ( getLCtx) expectedType?
let fConst resolveDotName id expectedType?
let fConst mkConst ( resolveDotName id expectedType?)
let s observing do
-- Use (force := true) because we want to record the result of .ident resolution even in patterns
let fConst addTermInfo f fConst expectedType? (force := true)

View File

@@ -5,7 +5,7 @@ Authors: Leonardo de Moura, Sebastian Ullrich
-/
prelude
import Lean.Parser.Module
import Lean.Util.Paths
import Lean.Data.Json
namespace Lean.Elab
@@ -42,12 +42,4 @@ def printImports (input : String) (fileName : Option String) : IO Unit := do
let fname findOLean dep.module
IO.println fname
@[export lean_print_import_srcs]
def printImportSrcs (input : String) (fileName : Option String) : IO Unit := do
let sp initSrcSearchPath
let (deps, _, _) parseImports input fileName
for dep in deps do
let fname findLean sp dep.module
IO.println fname
end Lean.Elab

View File

@@ -38,9 +38,6 @@ declare_config_elab elabBVDecideConfig Lean.Elab.Tactic.BVDecide.Frontend.BVDeci
builtin_initialize bvNormalizeExt : Meta.SimpExtension
Meta.registerSimpAttr `bv_normalize "simp theorems used by bv_normalize"
builtin_initialize intToBitVecExt : Meta.SimpExtension
Meta.registerSimpAttr `int_toBitVec "simp theorems used to convert UIntX/IntX statements into BitVec ones"
/-- Builtin `bv_normalize` simprocs. -/
builtin_initialize builtinBVNormalizeSimprocsRef : IO.Ref Meta.Simp.Simprocs IO.mkRef {}

View File

@@ -4,28 +4,342 @@ Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Lean.Meta.AppBuilder
import Lean.Meta.Tactic.AC.Main
import Lean.Elab.Tactic.Simp
import Lean.Elab.Tactic.FalseOrByContra
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Basic
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Simproc
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Rewrite
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.AndFlatten
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.EmbeddedConstraint
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.AC
import Lean.Elab.Tactic.BVDecide.Frontend.Attr
import Std.Tactic.BVDecide.Normalize
import Std.Tactic.BVDecide.Syntax
/-!
This module contains the implementation of `bv_normalize`, the preprocessing tactic for `bv_decide`.
It is in essence a (slightly reduced) version of the Bitwuzla preprocessor together with Lean
specific details.
This module contains the implementation of `bv_normalize` which is effectively a custom `bv_normalize`
simp set that is called like this: `simp only [seval, bv_normalize]`. The rules in `bv_normalize`
fulfill two goals:
1. Turn all hypothesis involving `Bool` and `BitVec` into the form `x = true` where `x` only consists
of a operations on `Bool` and `BitVec`. In particular no `Prop` should be contained. This makes
the reflection procedure further down the pipeline much easier to implement.
2. Apply simplification rules from the Bitwuzla SMT solver.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
open Std.Tactic.BVDecide.Normalize
def passPipeline : PreProcessM (List Pass) := do
let mut passPipeline := [rewriteRulesPass]
let cfg PreProcessM.getConfig
builtin_simproc [bv_normalize] reduceCond (cond _ _ _) := fun e => do
let_expr f@cond α c tb eb := e | return .continue
let r Simp.simp c
if r.expr.cleanupAnnotations.isConstOf ``Bool.true then
let pr := mkApp (mkApp4 (mkConst ``Bool.cond_pos f.constLevels!) α c tb eb) ( r.getProof)
return .visit { expr := tb, proof? := pr }
else if r.expr.cleanupAnnotations.isConstOf ``Bool.false then
let pr := mkApp (mkApp4 (mkConst ``Bool.cond_neg f.constLevels!) α c tb eb) ( r.getProof)
return .visit { expr := eb, proof? := pr }
else
return .continue
builtin_simproc [bv_normalize] eqToBEq (((_ : Bool) = (_ : Bool))) := fun e => do
let_expr Eq _ lhs rhs := e | return .continue
match_expr rhs with
| Bool.true => return .continue
| _ =>
let beqApp mkAppM ``BEq.beq #[lhs, rhs]
let new := mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) beqApp (mkConst ``Bool.true)
let proof := mkApp2 (mkConst ``Bool.eq_to_beq) lhs rhs
return .done { expr := new, proof? := some proof }
builtin_simproc [bv_normalize] andOnes ((_ : BitVec _) &&& (_ : BitVec _)) := fun e => do
let_expr HAnd.hAnd _ _ _ _ lhs rhs := e | return .continue
let some w, rhsValue getBitVecValue? rhs | return .continue
if rhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.and_ones) (toExpr w) lhs
return .visit { expr := lhs, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] onesAnd ((_ : BitVec _) &&& (_ : BitVec _)) := fun e => do
let_expr HAnd.hAnd _ _ _ _ lhs rhs := e | return .continue
let some w, lhsValue getBitVecValue? lhs | return .continue
if lhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.ones_and) (toExpr w) rhs
return .visit { expr := rhs, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] maxUlt (BitVec.ult (_ : BitVec _) (_ : BitVec _)) := fun e => do
let_expr BitVec.ult _ lhs rhs := e | return .continue
let some w, lhsValue getBitVecValue? lhs | return .continue
if lhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.max_ult') (toExpr w) rhs
return .visit { expr := toExpr Bool.false, proof? := some proof }
else
return .continue
-- A specialised version of BitVec.neg_eq_not_add so it doesn't trigger on -constant
builtin_simproc [bv_normalize] neg_eq_not_add (-(_ : BitVec _)) := fun e => do
let_expr Neg.neg typ _ val := e | return .continue
let_expr BitVec widthExpr := typ | return .continue
let some w getNatValue? widthExpr | return .continue
match getBitVecValue? val with
| some _ => return .continue
| none =>
let proof := mkApp2 (mkConst ``BitVec.neg_eq_not_add) (toExpr w) val
let expr mkAppM ``HAdd.hAdd #[ mkAppM ``Complement.complement #[val], (toExpr 1#w)]
return .visit { expr := expr, proof? := some proof }
builtin_simproc [bv_normalize] bv_add_const ((_ : BitVec _) + ((_ : BitVec _) + (_ : BitVec _))) :=
fun e => do
let_expr HAdd.hAdd _ _ _ _ exp1 rhs := e | return .continue
let_expr HAdd.hAdd _ _ _ _ exp2 exp3 := rhs | return .continue
let some w, exp1Val getBitVecValue? exp1 | return .continue
let proofBuilder thm := mkApp4 (mkConst thm) (toExpr w) exp1 exp2 exp3
match getBitVecValue? exp2 with
| some w', exp2Val =>
if h : w = w' then
let newLhs := exp1Val + h exp2Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp3]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_left
return .visit { expr := expr, proof? := some proof }
else
return .continue
| none =>
let some w', exp3Val getBitVecValue? exp3 | return .continue
if h : w = w' then
let newLhs := exp1Val + h exp3Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp2]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_right
return .visit { expr := expr, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] bv_add_const' (((_ : BitVec _) + (_ : BitVec _)) + (_ : BitVec _)) :=
fun e => do
let_expr HAdd.hAdd _ _ _ _ lhs exp3 := e | return .continue
let_expr HAdd.hAdd _ _ _ _ exp1 exp2 := lhs | return .continue
let some w, exp3Val getBitVecValue? exp3 | return .continue
let proofBuilder thm := mkApp4 (mkConst thm) (toExpr w) exp1 exp2 exp3
match getBitVecValue? exp1 with
| some w', exp1Val =>
if h : w = w' then
let newLhs := exp3Val + h exp1Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp2]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_left'
return .visit { expr := expr, proof? := some proof }
else
return .continue
| none =>
let some w', exp2Val getBitVecValue? exp2 | return .continue
if h : w = w' then
let newLhs := exp3Val + h exp2Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp1]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_right'
return .visit { expr := expr, proof? := some proof }
else
return .continue
/-- Return a number `k` such that `2^k = n`. -/
private def Nat.log2Exact (n : Nat) : Option Nat := do
guard <| n 0
let k := n.log2
guard <| Nat.pow 2 k == n
return k
-- Build an expression for `x ^ y`.
def mkPow (x y : Expr) : MetaM Expr := mkAppM ``HPow.hPow #[x, y]
builtin_simproc [bv_normalize] bv_udiv_of_two_pow (((_ : BitVec _) / (BitVec.ofNat _ _) : BitVec _)) := fun e => do
let_expr HDiv.hDiv _α _β _γ _self x y := e | return .continue
let some w, yVal getBitVecValue? y | return .continue
let n := yVal.toNat
-- BitVec.ofNat w n, where n =def= 2^k
let some k := Nat.log2Exact n | return .continue
-- check that k < w.
if k w then return .continue
let rhs mkAppM ``HShiftRight.hShiftRight #[x, mkNatLit k]
-- 2^k = n
let hk mkDecideProof ( mkEq ( mkPow (mkNatLit 2) (mkNatLit k)) (mkNatLit n))
-- k < w
let hlt mkDecideProof ( mkLt (mkNatLit k) (mkNatLit w))
let proof := mkAppN (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.udiv_ofNat_eq_of_lt)
#[mkNatLit w, x, mkNatLit n, mkNatLit k, hk, hlt]
return .done {
expr := rhs
proof? := some proof
}
/--
A pass in the normalization pipeline. Takes the current goal and produces a refined one or closes
the goal fully, indicated by returning `none`.
-/
structure Pass where
name : Name
run : MVarId MetaM (Option MVarId)
namespace Pass
/--
Repeatedly run a list of `Pass` until they either close the goal or an iteration doesn't change
the goal anymore.
-/
partial def fixpointPipeline (passes : List Pass) (goal : MVarId) : MetaM (Option MVarId) := do
let runPass (goal? : Option MVarId) (pass : Pass) : MetaM (Option MVarId) := do
let some goal := goal? | return none
withTraceNode `bv (fun _ => return s!"Running pass: {pass.name}") do
pass.run goal
let some newGoal := passes.foldlM (init := some goal) runPass | return none
if goal != newGoal then
trace[Meta.Tactic.bv] m!"Rerunning pipeline on:\n{newGoal}"
fixpointPipeline passes newGoal
else
trace[Meta.Tactic.bv] "Pipeline reached a fixpoint"
return newGoal
/--
Responsible for applying the Bitwuzla style rewrite rules.
-/
def rewriteRulesPass (maxSteps : Nat) : Pass where
name := `rewriteRules
run goal := do
let bvThms bvNormalizeExt.getTheorems
let bvSimprocs bvNormalizeSimprocExt.getSimprocs
let sevalThms getSEvalTheorems
let sevalSimprocs Simp.getSEvalSimprocs
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, zetaDelta := true, maxSteps })
(simpTheorems := #[bvThms, sevalThms])
(congrTheorems := ( getSimpCongrTheorems))
let hyps goal.getNondepPropHyps
let result?, _ simpGoal goal
(ctx := simpCtx)
(simprocs := #[bvSimprocs, sevalSimprocs])
(fvarIdsToSimp := hyps)
let some (_, newGoal) := result? | return none
return newGoal
/--
Flatten out ands. That is look for hypotheses of the form `h : (x && y) = true` and replace them
with `h.left : x = true` and `h.right : y = true`. This can enable more fine grained substitutions
in embedded constraint substitution.
-/
partial def andFlatteningPass : Pass where
name := `andFlattening
run goal := do
goal.withContext do
let hyps goal.getNondepPropHyps
let mut newHyps := #[]
let mut oldHyps := #[]
for fvar in hyps do
let hyp : Hypothesis := {
userName := ( fvar.getDecl).userName
type := fvar.getType
value := mkFVar fvar
}
let sizeBefore := newHyps.size
newHyps splitAnds hyp newHyps
if newHyps.size > sizeBefore then
oldHyps := oldHyps.push fvar
if newHyps.size == 0 then
return goal
else
let (_, goal) goal.assertHypotheses newHyps
-- Given that we collected the hypotheses in the correct order above the invariant is given
let goal goal.tryClearMany oldHyps
return goal
where
splitAnds (hyp : Hypothesis) (hyps : Array Hypothesis) (first : Bool := true) :
MetaM (Array Hypothesis) := do
match trySplit hyp with
| some (left, right) =>
let hyps splitAnds left hyps false
splitAnds right hyps false
| none =>
if first then
return hyps
else
return hyps.push hyp
trySplit (hyp : Hypothesis) : MetaM (Option (Hypothesis × Hypothesis)) := do
let typ := hyp.type
let_expr Eq α eqLhs eqRhs := typ | return none
let_expr Bool.and lhs rhs := eqLhs | return none
let_expr Bool.true := eqRhs | return none
let_expr Bool := α | return none
let mkEqTrue (lhs : Expr) : Expr :=
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
let leftHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue lhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hyp.value
}
let rightHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue rhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hyp.value
}
return some (leftHyp, rightHyp)
/--
Substitute embedded constraints. That is look for hypotheses of the form `h : x = true` and use
them to substitute occurences of `x` within other hypotheses. Additionally this drops all
redundant top level hypotheses.
-/
def embeddedConstraintPass (maxSteps : Nat) : Pass where
name := `embeddedConstraintSubsitution
run goal := do
goal.withContext do
let hyps goal.getNondepPropHyps
let mut relevantHyps : SimpTheoremsArray := #[]
let mut seen : Std.HashSet Expr := {}
let mut duplicates : Array FVarId := #[]
for hyp in hyps do
let typ hyp.getType
let_expr Eq α lhs rhs := typ | continue
let_expr Bool.true := rhs | continue
let_expr Bool := α | continue
if seen.contains lhs then
-- collect and later remove duplicates on the fly
duplicates := duplicates.push hyp
else
seen := seen.insert lhs
let localDecl hyp.getDecl
let proof := localDecl.toExpr
relevantHyps relevantHyps.addTheorem (.fvar hyp) proof
let goal goal.tryClearMany duplicates
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, maxSteps })
(simpTheorems := relevantHyps)
(congrTheorems := ( getSimpCongrTheorems))
let result?, _ simpGoal goal (ctx := simpCtx) (fvarIdsToSimp := goal.getNondepPropHyps)
let some (_, newGoal) := result? | return none
return newGoal
/--
Normalize with respect to Associativity and Commutativity.
-/
def acNormalizePass : Pass where
name := `ac_nf
run goal := do
let mut newGoal := goal
for hyp in ( goal.getNondepPropHyps) do
let result Lean.Meta.AC.acNfHypMeta newGoal hyp
if let .some nextGoal := result then
newGoal := nextGoal
else
return none
return newGoal
def passPipeline (cfg : BVDecideConfig) : List Pass := Id.run do
let mut passPipeline := [rewriteRulesPass cfg.maxSteps]
if cfg.acNf then
passPipeline := passPipeline ++ [acNormalizePass]
@@ -34,20 +348,18 @@ def passPipeline : PreProcessM (List Pass) := do
passPipeline := passPipeline ++ [andFlatteningPass]
if cfg.embeddedConstraintSubst then
passPipeline := passPipeline ++ [embeddedConstraintPass]
passPipeline := passPipeline ++ [embeddedConstraintPass cfg.maxSteps]
return passPipeline
def bvNormalize (g : MVarId) (cfg : BVDecideConfig) : MetaM (Option MVarId) := do
withTraceNode `bv (fun _ => return "Preprocessing goal") do
(go g).run cfg g
where
go (g : MVarId) : PreProcessM (Option MVarId) := do
let some g g.falseOrByContra | return none
end Pass
def bvNormalize (g : MVarId) (cfg : BVDecideConfig) : MetaM (Option MVarId) := do
withTraceNode `bv (fun _ => return "Normalizing goal") do
-- Contradiction proof
let some g g.falseOrByContra | return none
trace[Meta.Tactic.bv] m!"Running preprocessing pipeline on:\n{g}"
let pipeline passPipeline
Pass.fixpointPipeline pipeline g
Pass.fixpointPipeline (Pass.passPipeline cfg) g
@[builtin_tactic Lean.Parser.Tactic.bvNormalize]
def evalBVNormalize : Tactic := fun

View File

@@ -1,39 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Basic
import Lean.Meta.Tactic.AC.Main
/-!
This module contains the implementation of the associativity and commutativity normalisation pass
in the fixpoint pipeline.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
/--
Normalize with respect to Associativity and Commutativity.
-/
def acNormalizePass : Pass where
name := `ac_nf
run' goal := do
let mut newGoal := goal
for hyp in ( goal.getNondepPropHyps) do
let result AC.acNfHypMeta newGoal hyp
if let .some nextGoal := result then
newGoal := nextGoal
else
return none
return newGoal
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -1,99 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Std.Tactic.BVDecide.Normalize.Bool
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Basic
import Lean.Meta.Tactic.Assert
/-!
This module contains the implementation of the and flattening pass in the fixpoint pipeline, taking
hypotheses of the form `h : x && y = true` and splitting them into `h1 : x = true` and
`h2 : y = true` recursively.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
structure AndFlattenState where
hypsToDelete : Array FVarId := #[]
hypsToAdd : Array Hypothesis := #[]
cache : Std.HashSet Expr := {}
/--
Flatten out ands. That is look for hypotheses of the form `h : (x && y) = true` and replace them
with `h.left : x = true` and `h.right : y = true`. This can enable more fine grained substitutions
in embedded constraint substitution.
-/
partial def andFlatteningPass : Pass where
name := `andFlattening
run' goal := do
let (_, { hypsToDelete, hypsToAdd, .. }) processGoal goal |>.run {}
if hypsToAdd.isEmpty then
return goal
else
let (_, goal) goal.assertHypotheses hypsToAdd
-- Given that we collected the hypotheses in the correct order above the invariant is given
let goal goal.tryClearMany hypsToDelete
return goal
where
processGoal (goal : MVarId) : StateRefT AndFlattenState MetaM Unit := do
goal.withContext do
let hyps goal.getNondepPropHyps
hyps.forM processFVar
processFVar (fvar : FVarId) : StateRefT AndFlattenState MetaM Unit := do
let type fvar.getType
if ( get).cache.contains type then
modify (fun s => { s with hypsToDelete := s.hypsToDelete.push fvar })
else
let hyp := {
userName := ( fvar.getDecl).userName
type := type
value := mkFVar fvar
}
let some (lhs, rhs) trySplit hyp | return ()
modify (fun s => { s with hypsToDelete := s.hypsToDelete.push fvar })
splitAnds [lhs, rhs]
splitAnds (worklist : List Hypothesis) : StateRefT AndFlattenState MetaM Unit := do
match worklist with
| [] => return ()
| hyp :: worklist =>
match trySplit hyp with
| some (left, right) => splitAnds <| left :: right :: worklist
| none =>
modify (fun s => { s with hypsToAdd := s.hypsToAdd.push hyp })
splitAnds worklist
trySplit (hyp : Hypothesis) :
StateRefT AndFlattenState MetaM (Option (Hypothesis × Hypothesis)) := do
let typ := hyp.type
if ( get).cache.contains typ then
return none
else
modify (fun s => { s with cache := s.cache.insert typ })
let_expr Eq _ eqLhs eqRhs := typ | return none
let_expr Bool.and lhs rhs := eqLhs | return none
let_expr Bool.true := eqRhs | return none
let mkEqTrue (lhs : Expr) : Expr :=
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
let leftHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue lhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hyp.value
}
let rightHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue rhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hyp.value
}
return some (leftHyp, rightHyp)
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -1,86 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Lean.Meta.Basic
import Lean.Elab.Tactic.BVDecide.Frontend.Attr
/-!
This module contains the basic preprocessing pipeline framework for `bv_normalize`.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
structure PreProcessState where
/--
Contains `FVarId` that we already know are in `bv_normalize` simp normal form and thus don't
need to be processed again when we visit the next time.
-/
rewriteCache : Std.HashSet FVarId := {}
abbrev PreProcessM : Type Type := ReaderT BVDecideConfig <| StateRefT PreProcessState MetaM
namespace PreProcessM
def getConfig : PreProcessM BVDecideConfig := read
@[inline]
def checkRewritten (fvar : FVarId) : PreProcessM Bool := do
let val := ( get).rewriteCache.contains fvar
trace[Meta.Tactic.bv] m!"{mkFVar fvar} was already rewritten? {val}"
return val
@[inline]
def rewriteFinished (fvar : FVarId) : PreProcessM Unit := do
trace[Meta.Tactic.bv] m!"Adding {mkFVar fvar} to the rewritten set"
modify (fun s => { s with rewriteCache := s.rewriteCache.insert fvar })
def run (cfg : BVDecideConfig) (goal : MVarId) (x : PreProcessM α) : MetaM α := do
let hyps goal.getNondepPropHyps
ReaderT.run x cfg |>.run' { rewriteCache := Std.HashSet.empty hyps.size }
end PreProcessM
/--
A pass in the normalization pipeline. Takes the current goal and produces a refined one or closes
the goal fully, indicated by returning `none`.
-/
structure Pass where
name : Name
run' : MVarId PreProcessM (Option MVarId)
namespace Pass
def run (pass : Pass) (goal : MVarId) : PreProcessM (Option MVarId) := do
withTraceNode `bv (fun _ => return m!"Running pass: {pass.name} on\n{goal}") do
pass.run' goal
/--
Repeatedly run a list of `Pass` until they either close the goal or an iteration doesn't change
the goal anymore.
-/
partial def fixpointPipeline (passes : List Pass) (goal : MVarId) : PreProcessM (Option MVarId) := do
let mut newGoal := goal
for pass in passes do
if let some nextGoal pass.run newGoal then
newGoal := nextGoal
else
trace[Meta.Tactic.bv] "Fixpoint iteration solved the goal"
return none
if goal != newGoal then
trace[Meta.Tactic.bv] m!"Rerunning pipeline on:\n{newGoal}"
fixpointPipeline passes newGoal
else
trace[Meta.Tactic.bv] "Pipeline reached a fixpoint"
return newGoal
end Pass
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -1,62 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Std.Tactic.BVDecide.Normalize.Bool
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Basic
import Lean.Meta.Tactic.Simp
/-!
This module contains the implementation of the embedded constraint substitution pass in the fixpoint
pipeline, substituting hypotheses of the form `h : x = true` in other hypotheses.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
/--
Substitute embedded constraints. That is look for hypotheses of the form `h : x = true` and use
them to substitute occurences of `x` within other hypotheses. Additionally this drops all
redundant top level hypotheses.
-/
def embeddedConstraintPass : Pass where
name := `embeddedConstraintSubsitution
run' goal := do
goal.withContext do
let hyps goal.getNondepPropHyps
let mut relevantHyps : SimpTheoremsArray := #[]
let mut seen : Std.HashSet Expr := {}
let mut duplicates : Array FVarId := #[]
for hyp in hyps do
let typ hyp.getType
let_expr Eq _ lhs rhs := typ | continue
let_expr Bool.true := rhs | continue
if seen.contains lhs then
duplicates := duplicates.push hyp
else
seen := seen.insert lhs
let localDecl hyp.getDecl
let proof := localDecl.toExpr
relevantHyps relevantHyps.addTheorem (.fvar hyp) proof
let goal goal.tryClearMany duplicates
if relevantHyps.isEmpty then
return goal
let cfg PreProcessM.getConfig
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, maxSteps := cfg.maxSteps })
(simpTheorems := relevantHyps)
(congrTheorems := ( getSimpCongrTheorems))
let result?, _ simpGoal goal (ctx := simpCtx) (fvarIdsToSimp := goal.getNondepPropHyps)
let some (_, newGoal) := result? | return none
return newGoal
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -1,61 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Lean.Elab.Tactic.Simp
import Lean.Elab.Tactic.BVDecide.Frontend.Normalize.Basic
import Lean.Elab.Tactic.BVDecide.Frontend.Attr
/-!
This module contains the implementation of the rewriting pass in the fixpoint pipeline, applying
rules from the `bv_normalize` simp set.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
/--
Responsible for applying the Bitwuzla style rewrite rules.
-/
def rewriteRulesPass : Pass where
name := `rewriteRules
run' goal := do
let bvThms bvNormalizeExt.getTheorems
let bvSimprocs bvNormalizeSimprocExt.getSimprocs
let sevalThms getSEvalTheorems
let sevalSimprocs Simp.getSEvalSimprocs
let cfg PreProcessM.getConfig
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, zetaDelta := true, maxSteps := cfg.maxSteps })
(simpTheorems := #[bvThms, sevalThms])
(congrTheorems := ( getSimpCongrTheorems))
let hyps getHyps goal
if hyps.isEmpty then
return goal
else
let result?, _ simpGoal goal
(ctx := simpCtx)
(simprocs := #[bvSimprocs, sevalSimprocs])
(fvarIdsToSimp := hyps)
let some (_, newGoal) := result? | return none
newGoal.withContext do
( newGoal.getNondepPropHyps).forM PreProcessM.rewriteFinished
return newGoal
where
getHyps (goal : MVarId) : PreProcessM (Array FVarId) := do
goal.withContext do
let mut hyps goal.getNondepPropHyps
let filter hyp := do
return !( PreProcessM.checkRewritten hyp)
hyps.filterM filter
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -1,164 +0,0 @@
/-
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
prelude
import Std.Tactic.BVDecide.Normalize
import Std.Tactic.BVDecide.Syntax
import Lean.Elab.Tactic.Simp
import Lean.Elab.Tactic.BVDecide.Frontend.Attr
/-!
This module contains implementations of simprocs used in the `bv_normalize` simp set.
-/
namespace Lean.Elab.Tactic.BVDecide
namespace Frontend.Normalize
open Lean.Meta
open Std.Tactic.BVDecide.Normalize
builtin_simproc [bv_normalize] reduceCond (cond _ _ _) := fun e => do
let_expr f@cond α c tb eb := e | return .continue
let r Simp.simp c
if r.expr.cleanupAnnotations.isConstOf ``Bool.true then
let pr := mkApp (mkApp4 (mkConst ``Bool.cond_pos f.constLevels!) α c tb eb) ( r.getProof)
return .visit { expr := tb, proof? := pr }
else if r.expr.cleanupAnnotations.isConstOf ``Bool.false then
let pr := mkApp (mkApp4 (mkConst ``Bool.cond_neg f.constLevels!) α c tb eb) ( r.getProof)
return .visit { expr := eb, proof? := pr }
else
return .continue
builtin_simproc [bv_normalize] eqToBEq (((_ : Bool) = (_ : Bool))) := fun e => do
let_expr Eq _ lhs rhs := e | return .continue
match_expr rhs with
| Bool.true => return .continue
| _ =>
let beqApp mkAppM ``BEq.beq #[lhs, rhs]
let new := mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) beqApp (mkConst ``Bool.true)
let proof := mkApp2 (mkConst ``Bool.eq_to_beq) lhs rhs
return .done { expr := new, proof? := some proof }
builtin_simproc [bv_normalize] andOnes ((_ : BitVec _) &&& (_ : BitVec _)) := fun e => do
let_expr HAnd.hAnd _ _ _ _ lhs rhs := e | return .continue
let some w, rhsValue getBitVecValue? rhs | return .continue
if rhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.and_ones) (toExpr w) lhs
return .visit { expr := lhs, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] onesAnd ((_ : BitVec _) &&& (_ : BitVec _)) := fun e => do
let_expr HAnd.hAnd _ _ _ _ lhs rhs := e | return .continue
let some w, lhsValue getBitVecValue? lhs | return .continue
if lhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.ones_and) (toExpr w) rhs
return .visit { expr := rhs, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] maxUlt (BitVec.ult (_ : BitVec _) (_ : BitVec _)) := fun e => do
let_expr BitVec.ult _ lhs rhs := e | return .continue
let some w, lhsValue getBitVecValue? lhs | return .continue
if lhsValue == -1#w then
let proof := mkApp2 (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.max_ult') (toExpr w) rhs
return .visit { expr := toExpr Bool.false, proof? := some proof }
else
return .continue
-- A specialised version of BitVec.neg_eq_not_add so it doesn't trigger on -constant
builtin_simproc [bv_normalize] neg_eq_not_add (-(_ : BitVec _)) := fun e => do
let_expr Neg.neg typ _ val := e | return .continue
let_expr BitVec widthExpr := typ | return .continue
let some w getNatValue? widthExpr | return .continue
match getBitVecValue? val with
| some _ => return .continue
| none =>
let proof := mkApp2 (mkConst ``BitVec.neg_eq_not_add) (toExpr w) val
let expr mkAppM ``HAdd.hAdd #[ mkAppM ``Complement.complement #[val], (toExpr 1#w)]
return .visit { expr := expr, proof? := some proof }
builtin_simproc [bv_normalize] bv_add_const ((_ : BitVec _) + ((_ : BitVec _) + (_ : BitVec _))) :=
fun e => do
let_expr HAdd.hAdd _ _ _ _ exp1 rhs := e | return .continue
let_expr HAdd.hAdd _ _ _ _ exp2 exp3 := rhs | return .continue
let some w, exp1Val getBitVecValue? exp1 | return .continue
let proofBuilder thm := mkApp4 (mkConst thm) (toExpr w) exp1 exp2 exp3
match getBitVecValue? exp2 with
| some w', exp2Val =>
if h : w = w' then
let newLhs := exp1Val + h exp2Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp3]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_left
return .visit { expr := expr, proof? := some proof }
else
return .continue
| none =>
let some w', exp3Val getBitVecValue? exp3 | return .continue
if h : w = w' then
let newLhs := exp1Val + h exp3Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp2]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_right
return .visit { expr := expr, proof? := some proof }
else
return .continue
builtin_simproc [bv_normalize] bv_add_const' (((_ : BitVec _) + (_ : BitVec _)) + (_ : BitVec _)) :=
fun e => do
let_expr HAdd.hAdd _ _ _ _ lhs exp3 := e | return .continue
let_expr HAdd.hAdd _ _ _ _ exp1 exp2 := lhs | return .continue
let some w, exp3Val getBitVecValue? exp3 | return .continue
let proofBuilder thm := mkApp4 (mkConst thm) (toExpr w) exp1 exp2 exp3
match getBitVecValue? exp1 with
| some w', exp1Val =>
if h : w = w' then
let newLhs := exp3Val + h exp1Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp2]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_left'
return .visit { expr := expr, proof? := some proof }
else
return .continue
| none =>
let some w', exp2Val getBitVecValue? exp2 | return .continue
if h : w = w' then
let newLhs := exp3Val + h exp2Val
let expr mkAppM ``HAdd.hAdd #[toExpr newLhs, exp1]
let proof := proofBuilder ``Std.Tactic.BVDecide.Normalize.BitVec.add_const_right'
return .visit { expr := expr, proof? := some proof }
else
return .continue
/-- Return a number `k` such that `2^k = n`. -/
private def Nat.log2Exact (n : Nat) : Option Nat := do
guard <| n 0
let k := n.log2
guard <| Nat.pow 2 k == n
return k
-- Build an expression for `x ^ y`.
def mkPow (x y : Expr) : MetaM Expr := mkAppM ``HPow.hPow #[x, y]
builtin_simproc [bv_normalize] bv_udiv_of_two_pow (((_ : BitVec _) / (BitVec.ofNat _ _) : BitVec _)) := fun e => do
let_expr HDiv.hDiv _α _β _γ _self x y := e | return .continue
let some w, yVal getBitVecValue? y | return .continue
let n := yVal.toNat
-- BitVec.ofNat w n, where n =def= 2^k
let some k := Nat.log2Exact n | return .continue
-- check that k < w.
if k w then return .continue
let rhs mkAppM ``HShiftRight.hShiftRight #[x, mkNatLit k]
-- 2^k = n
let hk mkDecideProof ( mkEq ( mkPow (mkNatLit 2) (mkNatLit k)) (mkNatLit n))
-- k < w
let hlt mkDecideProof ( mkLt (mkNatLit k) (mkNatLit w))
let proof := mkAppN (mkConst ``Std.Tactic.BVDecide.Normalize.BitVec.udiv_ofNat_eq_of_lt)
#[mkNatLit w, x, mkNatLit n, mkNatLit k, hk, hlt]
return .done {
expr := rhs
proof? := some proof
}
end Frontend.Normalize
end Lean.Elab.Tactic.BVDecide

View File

@@ -35,9 +35,9 @@ def elabGrindPattern : CommandElab := fun stx => do
| _ => throwUnsupportedSyntax
def grind (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Grind.Fallback) : MetaM Unit := do
let goals Grind.main mvarId config mainDeclName fallback
unless goals.isEmpty do
throwError "`grind` failed\n{← Grind.goalsToMessageData goals config}"
let mvarIds Grind.main mvarId config mainDeclName fallback
unless mvarIds.isEmpty do
throwError "`grind` failed\n{goalsToMessageData mvarIds}"
private def elabFallback (fallback? : Option Term) : TermElabM (Grind.GoalM Unit) := do
let some fallback := fallback? | return (pure ())

View File

@@ -735,7 +735,7 @@ private def setImportedEntries (env : Environment) (mods : Array ModuleData) (st
let extDescrs persistentEnvExtensionsRef.get
/- For extensions starting at `startingAt`, ensure their `importedEntries` array have size `mods.size`. -/
for extDescr in extDescrs[startingAt:] do
env := extDescr.toEnvExtension.modifyState env fun s => { s with importedEntries := Array.replicate mods.size #[] }
env := extDescr.toEnvExtension.modifyState env fun s => { s with importedEntries := mkArray mods.size #[] }
/- For each module `mod`, and `mod.entries`, if the extension name is one of the extensions after `startingAt`, set `entries` -/
let extNameIdx mkExtNameMap startingAt
for h : modIdx in [:mods.size] do

View File

@@ -1127,7 +1127,7 @@ private def getAppArgsAux : Expr → Array Expr → Nat → Array Expr
@[inline] def getAppArgs (e : Expr) : Array Expr :=
let dummy := mkSort levelZero
let nargs := e.getAppNumArgs
getAppArgsAux e (Array.replicate nargs dummy) (nargs-1)
getAppArgsAux e (mkArray nargs dummy) (nargs-1)
private def getBoundedAppArgsAux : Expr Array Expr Nat Array Expr
| app f a, as, i + 1 => getBoundedAppArgsAux f (as.set! i a) i
@@ -1142,7 +1142,7 @@ where `k` is minimal such that the size of this array is at most `maxArgs`.
@[inline] def getBoundedAppArgs (maxArgs : Nat) (e : Expr) : Array Expr :=
let dummy := mkSort levelZero
let nargs := min maxArgs e.getAppNumArgs
getBoundedAppArgsAux e (Array.replicate nargs dummy) nargs
getBoundedAppArgsAux e (mkArray nargs dummy) nargs
private def getAppRevArgsAux : Expr Array Expr Array Expr
| app f a, as => getAppRevArgsAux f (as.push a)
@@ -1160,7 +1160,7 @@ private def getAppRevArgsAux : Expr → Array Expr → Array Expr
@[inline] def withApp (e : Expr) (k : Expr Array Expr α) : α :=
let dummy := mkSort levelZero
let nargs := e.getAppNumArgs
withAppAux k e (Array.replicate nargs dummy) (nargs-1)
withAppAux k e (mkArray nargs dummy) (nargs-1)
/-- Return the function (name) and arguments of an application. -/
def getAppFnArgs (e : Expr) : Name × Array Expr :=
@@ -1173,7 +1173,7 @@ The resulting array has size `n` even if `f.getAppNumArgs < n`.
-/
@[inline] def getAppArgsN (e : Expr) (n : Nat) : Array Expr :=
let dummy := mkSort levelZero
loop n e (Array.replicate n dummy)
loop n e (mkArray n dummy)
where
loop : Nat Expr Array Expr Array Expr
| 0, _, as => as

View File

@@ -11,14 +11,14 @@ import Lean.Meta.DecLevel
namespace Lean.Meta
/-- Returns `id e` -/
/-- Return `id e` -/
def mkId (e : Expr) : MetaM Expr := do
let type inferType e
let u getLevel type
return mkApp2 (mkConst ``id [u]) type e
/--
Given `e` s.t. `inferType e` is definitionally equal to `expectedType`, returns
Given `e` s.t. `inferType e` is definitionally equal to `expectedType`, return
term `@id expectedType e`. -/
def mkExpectedTypeHint (e : Expr) (expectedType : Expr) : MetaM Expr := do
let u getLevel expectedType
@@ -38,13 +38,13 @@ def mkLetFun (x : Expr) (v : Expr) (e : Expr) : MetaM Expr := do
let u2 getLevel ety
return mkAppN (.const ``letFun [u1, u2]) #[α, β, v, f]
/-- Returns `a = b`. -/
/-- Return `a = b`. -/
def mkEq (a b : Expr) : MetaM Expr := do
let aType inferType a
let u getLevel aType
return mkApp3 (mkConst ``Eq [u]) aType a b
/-- Returns `HEq a b`. -/
/-- Return `HEq a b`. -/
def mkHEq (a b : Expr) : MetaM Expr := do
let aType inferType a
let bType inferType b
@@ -52,7 +52,7 @@ def mkHEq (a b : Expr) : MetaM Expr := do
return mkApp4 (mkConst ``HEq [u]) aType a bType b
/--
If `a` and `b` have definitionally equal types, returns `Eq a b`, otherwise returns `HEq a b`.
If `a` and `b` have definitionally equal types, return `Eq a b`, otherwise return `HEq a b`.
-/
def mkEqHEq (a b : Expr) : MetaM Expr := do
let aType inferType a
@@ -63,25 +63,25 @@ def mkEqHEq (a b : Expr) : MetaM Expr := do
else
return mkApp4 (mkConst ``HEq [u]) aType a bType b
/-- Returns a proof of `a = a`. -/
/-- Return a proof of `a = a`. -/
def mkEqRefl (a : Expr) : MetaM Expr := do
let aType inferType a
let u getLevel aType
return mkApp2 (mkConst ``Eq.refl [u]) aType a
/-- Returns a proof of `HEq a a`. -/
/-- Return a proof of `HEq a a`. -/
def mkHEqRefl (a : Expr) : MetaM Expr := do
let aType inferType a
let u getLevel aType
return mkApp2 (mkConst ``HEq.refl [u]) aType a
/-- Given `hp : P` and `nhp : Not P`, returns an instance of type `e`. -/
/-- Given `hp : P` and `nhp : Not P` returns an instance of type `e`. -/
def mkAbsurd (e : Expr) (hp hnp : Expr) : MetaM Expr := do
let p inferType hp
let u getLevel e
return mkApp4 (mkConst ``absurd [u]) p e hp hnp
/-- Given `h : False`, returns an instance of type `e`. -/
/-- Given `h : False`, return an instance of type `e`. -/
def mkFalseElim (e : Expr) (h : Expr) : MetaM Expr := do
let u getLevel e
return mkApp2 (mkConst ``False.elim [u]) e h
@@ -108,7 +108,7 @@ def mkEqSymm (h : Expr) : MetaM Expr := do
return mkApp4 (mkConst ``Eq.symm [u]) α a b h
| none => throwAppBuilderException ``Eq.symm ("equality proof expected" ++ hasTypeMsg h hType)
/-- Given `h₁ : a = b` and `h₂ : b = c`, returns a proof of `a = c`. -/
/-- Given `h₁ : a = b` and `h₂ : b = c` returns a proof of `a = c`. -/
def mkEqTrans (h₁ h₂ : Expr) : MetaM Expr := do
if h₁.isAppOf ``Eq.refl then
return h₂
@@ -185,7 +185,7 @@ def mkHEqOfEq (h : Expr) : MetaM Expr := do
return mkApp4 (mkConst ``heq_of_eq [u]) α a b h
/--
If `e` is `@Eq.refl α a`, returns `a`.
If `e` is `@Eq.refl α a`, return `a`.
-/
def isRefl? (e : Expr) : Option Expr := do
if e.isAppOfArity ``Eq.refl 2 then
@@ -194,7 +194,7 @@ def isRefl? (e : Expr) : Option Expr := do
none
/--
If `e` is `@congrArg α β a b f h`, returns `α`, `f` and `h`.
If `e` is `@congrArg α β a b f h`, return `α`, `f` and `h`.
Also works if `e` can be turned into such an application (e.g. `congrFun`).
-/
def congrArg? (e : Expr) : MetaM (Option (Expr × Expr × Expr)) := do
@@ -336,14 +336,13 @@ private def withAppBuilderTrace [ToMessageData α] [ToMessageData β]
throw ex
/--
Returns the application `constName xs`.
Return the application `constName xs`.
It tries to fill the implicit arguments before the last element in `xs`.
Remark:
``mkAppM `arbitrary #[α]`` returns `@arbitrary.{u} α` without synthesizing
the implicit argument occurring after `α`.
Given a `x : ([Decidable p] → Bool) × Nat`, ``mkAppM `Prod.fst #[x]``,
returns `@Prod.fst ([Decidable p] → Bool) Nat x`.
Given a `x : ([Decidable p] → Bool) × Nat`, ``mkAppM `Prod.fst #[x]`` returns `@Prod.fst ([Decidable p] → Bool) Nat x`.
-/
def mkAppM (constName : Name) (xs : Array Expr) : MetaM Expr := do
withAppBuilderTrace constName xs do withNewMCtxDepth do
@@ -466,9 +465,8 @@ def mkPure (monad : Expr) (e : Expr) : MetaM Expr :=
mkAppOptM ``Pure.pure #[monad, none, none, e]
/--
`mkProjection s fieldName` returns an expression for accessing field `fieldName` of the structure `s`.
Remark: `fieldName` may be a subfield of `s`.
-/
`mkProjection s fieldName` returns an expression for accessing field `fieldName` of the structure `s`.
Remark: `fieldName` may be a subfield of `s`. -/
partial def mkProjection (s : Expr) (fieldName : Name) : MetaM Expr := do
let type inferType s
let type whnf type
@@ -522,11 +520,11 @@ def mkSome (type value : Expr) : MetaM Expr := do
let u getDecLevel type
return mkApp2 (mkConst ``Option.some [u]) type value
/-- Returns `Decidable.decide p` -/
/-- Return `Decidable.decide p` -/
def mkDecide (p : Expr) : MetaM Expr :=
mkAppOptM ``Decidable.decide #[p, none]
/-- Returns a proof for `p : Prop` using `decide p` -/
/-- Return a proof for `p : Prop` using `decide p` -/
def mkDecideProof (p : Expr) : MetaM Expr := do
let decP mkDecide p
let decEqTrue mkEq decP (mkConst ``Bool.true)
@@ -534,75 +532,59 @@ def mkDecideProof (p : Expr) : MetaM Expr := do
let h mkExpectedTypeHint h decEqTrue
mkAppM ``of_decide_eq_true #[h]
/-- Returns `a < b` -/
/-- Return `a < b` -/
def mkLt (a b : Expr) : MetaM Expr :=
mkAppM ``LT.lt #[a, b]
/-- Returns `a <= b` -/
/-- Return `a <= b` -/
def mkLe (a b : Expr) : MetaM Expr :=
mkAppM ``LE.le #[a, b]
/-- Returns `Inhabited.default α` -/
/-- Return `Inhabited.default α` -/
def mkDefault (α : Expr) : MetaM Expr :=
mkAppOptM ``Inhabited.default #[α, none]
/-- Returns `@Classical.ofNonempty α _` -/
/-- Return `@Classical.ofNonempty α _` -/
def mkOfNonempty (α : Expr) : MetaM Expr := do
mkAppOptM ``Classical.ofNonempty #[α, none]
/-- Returns `funext h` -/
/-- Return `funext h` -/
def mkFunExt (h : Expr) : MetaM Expr :=
mkAppM ``funext #[h]
/-- Returns `propext h` -/
/-- Return `propext h` -/
def mkPropExt (h : Expr) : MetaM Expr :=
mkAppM ``propext #[h]
/-- Returns `let_congr h₁ h₂` -/
/-- Return `let_congr h₁ h₂` -/
def mkLetCongr (h₁ h₂ : Expr) : MetaM Expr :=
mkAppM ``let_congr #[h₁, h₂]
/-- Returns `let_val_congr b h` -/
/-- Return `let_val_congr b h` -/
def mkLetValCongr (b h : Expr) : MetaM Expr :=
mkAppM ``let_val_congr #[b, h]
/-- Returns `let_body_congr a h` -/
/-- Return `let_body_congr a h` -/
def mkLetBodyCongr (a h : Expr) : MetaM Expr :=
mkAppM ``let_body_congr #[a, h]
/-- Returns `@of_eq_true p h` -/
def mkOfEqTrueCore (p : Expr) (h : Expr) : Expr :=
match_expr h with
| eq_true _ h => h
| _ => mkApp2 (mkConst ``of_eq_true) p h
/-- Return `of_eq_true h` -/
def mkOfEqTrue (h : Expr) : MetaM Expr :=
mkAppM ``of_eq_true #[h]
/-- Returns `of_eq_true h` -/
def mkOfEqTrue (h : Expr) : MetaM Expr := do
match_expr h with
| eq_true _ h => return h
| _ => mkAppM ``of_eq_true #[h]
/-- Returns `eq_true h` -/
def mkEqTrueCore (p : Expr) (h : Expr) : Expr :=
match_expr h with
| of_eq_true _ h => h
| _ => mkApp2 (mkConst ``eq_true) p h
/-- Returns `eq_true h` -/
def mkEqTrue (h : Expr) : MetaM Expr := do
match_expr h with
| of_eq_true _ h => return h
| _ => return mkApp2 (mkConst ``eq_true) ( inferType h) h
/-- Return `eq_true h` -/
def mkEqTrue (h : Expr) : MetaM Expr :=
mkAppM ``eq_true #[h]
/--
Returns `eq_false h`
Return `eq_false h`
`h` must have type definitionally equal to `¬ p` in the current
reducibility setting. -/
def mkEqFalse (h : Expr) : MetaM Expr :=
mkAppM ``eq_false #[h]
/--
Returns `eq_false' h`
Return `eq_false' h`
`h` must have type definitionally equal to `p → False` in the current
reducibility setting. -/
def mkEqFalse' (h : Expr) : MetaM Expr :=
@@ -620,7 +602,7 @@ def mkImpDepCongrCtx (h₁ h₂ : Expr) : MetaM Expr :=
def mkForallCongr (h : Expr) : MetaM Expr :=
mkAppM ``forall_congr #[h]
/-- Returns instance for `[Monad m]` if there is one -/
/-- Return instance for `[Monad m]` if there is one -/
def isMonad? (m : Expr) : MetaM (Option Expr) :=
try
let monadType mkAppM `Monad #[m]
@@ -631,52 +613,52 @@ def isMonad? (m : Expr) : MetaM (Option Expr) :=
catch _ =>
pure none
/-- Returns `(n : type)`, a numeric literal of type `type`. The method fails if we don't have an instance `OfNat type n` -/
/-- Return `(n : type)`, a numeric literal of type `type`. The method fails if we don't have an instance `OfNat type n` -/
def mkNumeral (type : Expr) (n : Nat) : MetaM Expr := do
let u getDecLevel type
let inst synthInstance (mkApp2 (mkConst ``OfNat [u]) type (mkRawNatLit n))
return mkApp3 (mkConst ``OfNat.ofNat [u]) type (mkRawNatLit n) inst
/--
Returns `a op b`, where `op` has name `opName` and is implemented using the typeclass `className`.
This method assumes `a` and `b` have the same type, and typeclass `className` is heterogeneous.
Examples of supported classes: `HAdd`, `HSub`, `HMul`.
We use heterogeneous operators to ensure we have a uniform representation.
-/
Return `a op b`, where `op` has name `opName` and is implemented using the typeclass `className`.
This method assumes `a` and `b` have the same type, and typeclass `className` is heterogeneous.
Examples of supported classes: `HAdd`, `HSub`, `HMul`.
We use heterogeneous operators to ensure we have a uniform representation.
-/
private def mkBinaryOp (className : Name) (opName : Name) (a b : Expr) : MetaM Expr := do
let aType inferType a
let u getDecLevel aType
let inst synthInstance (mkApp3 (mkConst className [u, u, u]) aType aType aType)
return mkApp6 (mkConst opName [u, u, u]) aType aType aType inst a b
/-- Returns `a + b` using a heterogeneous `+`. This method assumes `a` and `b` have the same type. -/
/-- Return `a + b` using a heterogeneous `+`. This method assumes `a` and `b` have the same type. -/
def mkAdd (a b : Expr) : MetaM Expr := mkBinaryOp ``HAdd ``HAdd.hAdd a b
/-- Returns `a - b` using a heterogeneous `-`. This method assumes `a` and `b` have the same type. -/
/-- Return `a - b` using a heterogeneous `-`. This method assumes `a` and `b` have the same type. -/
def mkSub (a b : Expr) : MetaM Expr := mkBinaryOp ``HSub ``HSub.hSub a b
/-- Returns `a * b` using a heterogeneous `*`. This method assumes `a` and `b` have the same type. -/
/-- Return `a * b` using a heterogeneous `*`. This method assumes `a` and `b` have the same type. -/
def mkMul (a b : Expr) : MetaM Expr := mkBinaryOp ``HMul ``HMul.hMul a b
/--
Returns `a r b`, where `r` has name `rName` and is implemented using the typeclass `className`.
This method assumes `a` and `b` have the same type.
Examples of supported classes: `LE` and `LT`.
We use heterogeneous operators to ensure we have a uniform representation.
-/
Return `a r b`, where `r` has name `rName` and is implemented using the typeclass `className`.
This method assumes `a` and `b` have the same type.
Examples of supported classes: `LE` and `LT`.
We use heterogeneous operators to ensure we have a uniform representation.
-/
private def mkBinaryRel (className : Name) (rName : Name) (a b : Expr) : MetaM Expr := do
let aType inferType a
let u getDecLevel aType
let inst synthInstance (mkApp (mkConst className [u]) aType)
return mkApp4 (mkConst rName [u]) aType inst a b
/-- Returns `a ≤ b`. This method assumes `a` and `b` have the same type. -/
/-- Return `a ≤ b`. This method assumes `a` and `b` have the same type. -/
def mkLE (a b : Expr) : MetaM Expr := mkBinaryRel ``LE ``LE.le a b
/-- Returns `a < b`. This method assumes `a` and `b` have the same type. -/
/-- Return `a < b`. This method assumes `a` and `b` have the same type. -/
def mkLT (a b : Expr) : MetaM Expr := mkBinaryRel ``LT ``LT.lt a b
/-- Given `h : a = b`, returns a proof for `a ↔ b`. -/
/-- Given `h : a = b`, return a proof for `a ↔ b`. -/
def mkIffOfEq (h : Expr) : MetaM Expr := do
if h.isAppOfArity ``propext 3 then
return h.appArg!

View File

@@ -1964,22 +1964,15 @@ def sortFVarIds (fvarIds : Array FVarId) : MetaM (Array FVarId) := do
end Methods
/--
Return `some info` if `declName` is an inductive predicate where `info : InductiveVal`.
That is, `inductive` type in `Prop`.
-/
def isInductivePredicate? (declName : Name) : MetaM (Option InductiveVal) := do
match ( getEnv).find? declName with
| some (.inductInfo info) =>
forallTelescopeReducing info.type fun _ type => do
match ( whnfD type) with
| .sort u .. => if u == levelZero then return some info else return none
| _ => return none
| _ => return none
/-- Return `true` if `declName` is an inductive predicate. That is, `inductive` type in `Prop`. -/
def isInductivePredicate (declName : Name) : MetaM Bool := do
return ( isInductivePredicate? declName).isSome
match ( getEnv).find? declName with
| some (.inductInfo { type := type, ..}) =>
forallTelescopeReducing type fun _ type => do
match ( whnfD type) with
| .sort u .. => return u == levelZero
| _ => return false
| _ => return false
def isListLevelDefEqAux : List Level List Level MetaM Bool
| [], [] => return true

View File

@@ -196,7 +196,7 @@ def mkSizeOfSpecLemmaInstance (ctorApp : Expr) : MetaM Expr :=
let lemmaInfo getConstInfo lemmaName
let lemmaArity forallTelescopeReducing lemmaInfo.type fun xs _ => return xs.size
let lemmaArgMask := ctorParams.toArray.map some
let lemmaArgMask := lemmaArgMask ++ Array.replicate (lemmaArity - ctorInfo.numParams - ctorInfo.numFields) (none (α := Expr))
let lemmaArgMask := lemmaArgMask ++ mkArray (lemmaArity - ctorInfo.numParams - ctorInfo.numFields) (none (α := Expr))
let lemmaArgMask := lemmaArgMask ++ ctorFields.toArray.map some
mkAppOptM lemmaName lemmaArgMask

View File

@@ -35,7 +35,7 @@ def insert (s : FVarSubst) (fvarId : FVarId) (v : Expr) : FVarSubst :=
if s.contains fvarId then s
else
let map := s.map.mapVal fun e => e.replaceFVarId fvarId v;
{ map := map.insertNew fvarId v }
{ map := map.insert fvarId v }
def erase (s : FVarSubst) (fvarId : FVarId) : FVarSubst :=
{ map := s.map.erase fvarId }

View File

@@ -24,7 +24,6 @@ import Lean.Meta.Tactic.Grind.EMatchTheorem
import Lean.Meta.Tactic.Grind.EMatch
import Lean.Meta.Tactic.Grind.Main
import Lean.Meta.Tactic.Grind.CasesMatch
import Lean.Meta.Tactic.Grind.Arith
namespace Lean
@@ -43,14 +42,6 @@ builtin_initialize registerTraceClass `grind.simp
builtin_initialize registerTraceClass `grind.split
builtin_initialize registerTraceClass `grind.split.candidate
builtin_initialize registerTraceClass `grind.split.resolved
builtin_initialize registerTraceClass `grind.offset
builtin_initialize registerTraceClass `grind.offset.dist
builtin_initialize registerTraceClass `grind.offset.internalize
builtin_initialize registerTraceClass `grind.offset.internalize.term (inherited := true)
builtin_initialize registerTraceClass `grind.offset.propagate
builtin_initialize registerTraceClass `grind.offset.eq
builtin_initialize registerTraceClass `grind.offset.eq.to (inherited := true)
builtin_initialize registerTraceClass `grind.offset.eq.from (inherited := true)
/-! Trace options for `grind` developers -/
builtin_initialize registerTraceClass `grind.debug
@@ -63,6 +54,4 @@ builtin_initialize registerTraceClass `grind.debug.final
builtin_initialize registerTraceClass `grind.debug.forallPropagator
builtin_initialize registerTraceClass `grind.debug.split
builtin_initialize registerTraceClass `grind.debug.canon
builtin_initialize registerTraceClass `grind.debug.offset
builtin_initialize registerTraceClass `grind.debug.offset.proof
end Lean

View File

@@ -1,10 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Tactic.Grind.Arith.Util
import Lean.Meta.Tactic.Grind.Arith.Types
import Lean.Meta.Tactic.Grind.Arith.Offset
import Lean.Meta.Tactic.Grind.Arith.Main

View File

@@ -1,14 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Tactic.Grind.Arith.Offset
namespace Lean.Meta.Grind.Arith
def internalize (e : Expr) (parent? : Option Expr) : GoalM Unit := do
Offset.internalize e parent?
end Lean.Meta.Grind.Arith

View File

@@ -1,14 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Tactic.Grind.Arith.Offset
namespace Lean.Meta.Grind.Arith
def checkInvariants : GoalM Unit :=
Offset.checkInvariants
end Lean.Meta.Grind.Arith

View File

@@ -1,34 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Tactic.Grind.PropagatorAttr
import Lean.Meta.Tactic.Grind.Arith.Offset
namespace Lean.Meta.Grind.Arith
namespace Offset
def isCnstr? (e : Expr) : GoalM (Option (Cnstr NodeId)) :=
return ( get).arith.offset.cnstrs.find? { expr := e }
def assertTrue (c : Cnstr NodeId) (p : Expr) : GoalM Unit := do
addEdge c.u c.v c.k ( mkOfEqTrue p)
def assertFalse (c : Cnstr NodeId) (p : Expr) : GoalM Unit := do
let p := mkOfNegEqFalse ( get').nodes c p
let c := c.neg
addEdge c.u c.v c.k p
end Offset
builtin_grind_propagator propagateLE LE.le := fun e => do
if ( isEqTrue e) then
if let some c Offset.isCnstr? e then
Offset.assertTrue c ( mkEqTrueProof e)
if ( isEqFalse e) then
if let some c Offset.isCnstr? e then
Offset.assertFalse c ( mkEqFalseProof e)
end Lean.Meta.Grind.Arith

View File

@@ -1,46 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Basic
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Util
namespace Lean.Meta.Grind.Arith.Offset
/-- Construct a model that statisfies all offset constraints -/
def mkModel (goal : Goal) : MetaM (Array (Expr × Nat)) := do
let s := goal.arith.offset
let nodes := s.nodes
let mut pre : Array (Option Int) := mkArray nodes.size none
for u in [:nodes.size] do
let val? := s.sources[u]!.foldl (init := @none Int) fun val? v k => Id.run do
let some va := pre[v]! | return val?
let val' := va - k
let some val := val? | return val'
if val' > val then return val' else val?
let val? := s.targets[u]!.foldl (init := val?) fun val? v k => Id.run do
let some va := pre[v]! | return val?
let val' := va + k
let some val := val? | return val'
if val' < val then return val' else val?
let val := val?.getD 0
pre := pre.set! u (some val)
let min := pre.foldl (init := 0) fun min val? => Id.run do
let some val := val? | return min
if val < min then val else min
let mut r := {}
for u in [:nodes.size] do
let some val := pre[u]! | unreachable!
let val := (val - min).toNat
let e := nodes[u]!
/-
We should not include the assignment for auxiliary offset terms since
they do not provide any additional information.
-/
if (isNatOffset? e).isNone && isNatNum? e != some 0 then
r := r.push (e, val)
return r
end Lean.Meta.Grind.Arith.Offset

View File

@@ -1,335 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Grind.Offset
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Arith.ProofUtil
namespace Lean.Meta.Grind.Arith.Offset
/-!
This module implements a decision procedure for offset constraints of the form:
```
x + k ≤ y
x ≤ y + k
```
where `k` is a numeral.
Each constraint is represented as an edge in a weighted graph.
The constraint `x + k ≤ y` is represented as a negative edge.
The shortest path between two nodes in the graph corresponds to an implied inequality.
When adding a new edge, the state is considered unsatisfiable if the new edge creates a negative cycle.
An incremental Floyd-Warshall algorithm is used to find the shortest paths between all nodes.
This module can also handle offset equalities of the form `x + k = y` by representing them with two edges:
```
x + k ≤ y
y ≤ x + k
```
The main advantage of this module over a full linear integer arithmetic procedure is
its ability to efficiently detect all implied equalities and inequalities.
-/
def get' : GoalM State := do
return ( get).arith.offset
@[inline] def modify' (f : State State) : GoalM Unit := do
modify fun s => { s with arith.offset := f s.arith.offset }
def mkNode (expr : Expr) : GoalM NodeId := do
if let some nodeId := ( get').nodeMap.find? { expr } then
return nodeId
let nodeId : NodeId := ( get').nodes.size
trace[grind.offset.internalize.term] "{expr} ↦ #{nodeId}"
modify' fun s => { s with
nodes := s.nodes.push expr
nodeMap := s.nodeMap.insert { expr } nodeId
sources := s.sources.push {}
targets := s.targets.push {}
proofs := s.proofs.push {}
}
markAsOffsetTerm expr
return nodeId
private def getExpr (u : NodeId) : GoalM Expr := do
return ( get').nodes[u]!
private def getDist? (u v : NodeId) : GoalM (Option Int) := do
return ( get').targets[u]!.find? v
private def getProof? (u v : NodeId) : GoalM (Option ProofInfo) := do
return ( get').proofs[u]!.find? v
private def getNodeId (e : Expr) : GoalM NodeId := do
let some nodeId := ( get').nodeMap.find? { expr := e }
| throwError "internal `grind` error, term has not been internalized by offset module{indentExpr e}"
return nodeId
/--
Returns a proof for `u + k ≤ v` (or `u ≤ v + k`) where `k` is the
shortest path between `u` and `v`.
-/
private partial def mkProofForPath (u v : NodeId) : GoalM Expr := do
go ( getProof? u v).get!
where
go (p : ProofInfo) : GoalM Expr := do
if u == p.w then
return p.proof
else
let p' := ( getProof? u p.w).get!
go (mkTrans ( get').nodes p' p v)
/--
Given a new edge edge `u --(kuv)--> v` justified by proof `huv` s.t.
it creates a negative cycle with the existing path `v --{kvu}-->* u`, i.e., `kuv + kvu < 0`,
this function closes the current goal by constructing a proof of `False`.
-/
private def setUnsat (u v : NodeId) (kuv : Int) (huv : Expr) (kvu : Int) : GoalM Unit := do
assert! kuv + kvu < 0
let hvu mkProofForPath v u
let u getExpr u
let v getExpr v
closeGoal (mkUnsatProof u v kuv huv kvu hvu)
/-- Sets the new shortest distance `k` between nodes `u` and `v`. -/
private def setDist (u v : NodeId) (k : Int) : GoalM Unit := do
trace[grind.offset.dist] "{({ u, v, k : Cnstr NodeId})}"
modify' fun s => { s with
targets := s.targets.modify u fun es => es.insert v k
sources := s.sources.modify v fun es => es.insert u k
}
private def setProof (u v : NodeId) (p : ProofInfo) : GoalM Unit := do
modify' fun s => { s with
proofs := s.proofs.modify u fun es => es.insert v p
}
@[inline]
private def forEachSourceOf (u : NodeId) (f : NodeId Int GoalM Unit) : GoalM Unit := do
( get').sources[u]!.forM f
@[inline]
private def forEachTargetOf (u : NodeId) (f : NodeId Int GoalM Unit) : GoalM Unit := do
( get').targets[u]!.forM f
/-- Returns `true` if `k` is smaller than the shortest distance between `u` and `v` -/
private def isShorter (u v : NodeId) (k : Int) : GoalM Bool := do
if let some k' getDist? u v then
return k < k'
else
return true
/--
Tries to assign `e` to `True`, which is represented by constraint `c` (from `u` to `v`), using the
path `u --(k)--> v`.
-/
private def propagateTrue (u v : NodeId) (k : Int) (c : Cnstr NodeId) (e : Expr) : GoalM Bool := do
if k c.k then
trace[grind.offset.propagate] "{{ u, v, k : Cnstr NodeId}} ==> {e} = True"
let kuv mkProofForPath u v
let u getExpr u
let v getExpr v
pushEqTrue e <| mkPropagateEqTrueProof u v k kuv c.k
return true
return false
/--
Tries to assign `e` to `False`, which is represented by constraint `c` (from `v` to `u`), using the
path `u --(k)--> v`.
-/
private def propagateFalse (u v : NodeId) (k : Int) (c : Cnstr NodeId) (e : Expr) : GoalM Bool := do
if k + c.k < 0 then
trace[grind.offset.propagate] "{{ u, v, k : Cnstr NodeId}} ==> {e} = False"
let kuv mkProofForPath u v
let u getExpr u
let v getExpr v
pushEqFalse e <| mkPropagateEqFalseProof u v k kuv c.k
return false
/--
Auxiliary function for implementing `propagateAll`.
Traverses the constraints `c` (representing an expression `e`) s.t.
`c.u = u` and `c.v = v`, it removes `c` from the list of constraints
associated with `(u, v)` IF
- `e` is already assigned, or
- `f c e` returns true
-/
@[inline]
private def updateCnstrsOf (u v : NodeId) (f : Cnstr NodeId Expr GoalM Bool) : GoalM Unit := do
if let some cs := ( get').cnstrsOf.find? (u, v) then
let cs' cs.filterM fun (c, e) => do
if ( isEqTrue e <||> isEqFalse e) then
return false -- constraint was already assigned
else
return !( f c e)
modify' fun s => { s with cnstrsOf := s.cnstrsOf.insert (u, v) cs' }
/-- Equality propagation. -/
private def propagateEq (u v : NodeId) (k : Int) : GoalM Unit := do
if k != 0 then return ()
let some k' getDist? v u | return ()
if k' != 0 then return ()
let ue getExpr u
let ve getExpr v
if ( isEqv ue ve) then return ()
let huv mkProofForPath u v
let hvu mkProofForPath v u
trace[grind.offset.eq.from] "{ue}, {ve}"
pushEq ue ve <| mkApp4 (mkConst ``Grind.Nat.eq_of_le_of_le) ue ve huv hvu
/-- Performs constraint propagation. -/
private def propagateAll (u v : NodeId) (k : Int) : GoalM Unit := do
updateCnstrsOf u v fun c e => return !( propagateTrue u v k c e)
updateCnstrsOf v u fun c e => return !( propagateFalse u v k c e)
propagateEq u v k
/--
If `isShorter u v k`, updates the shortest distance between `u` and `v`.
`w` is the penultimate node in the path from `u` to `v`.
-/
private def updateIfShorter (u v : NodeId) (k : Int) (w : NodeId) : GoalM Unit := do
if ( isShorter u v k) then
setDist u v k
setProof u v ( getProof? w v).get!
propagateAll u v k
/--
Adds an edge `u --(k) --> v` justified by the proof term `p`, and then
if no negative cycle was created, updates the shortest distance of affected
node pairs.
-/
def addEdge (u : NodeId) (v : NodeId) (k : Int) (p : Expr) : GoalM Unit := do
if ( isInconsistent) then return ()
if let some k' getDist? v u then
if k'+k < 0 then
setUnsat u v k p k'
return ()
if ( isShorter u v k) then
setDist u v k
setProof u v { w := u, k, proof := p }
propagateAll u v k
update
where
update : GoalM Unit := do
forEachTargetOf v fun j k₂ => do
/- Check whether new path: `u -(k)-> v -(k₂)-> j` is shorter -/
updateIfShorter u j (k+k₂) v
forEachSourceOf u fun i k₁ => do
/- Check whether new path: `i -(k₁)-> u -(k)-> v` is shorter -/
updateIfShorter i v (k₁+k) u
forEachTargetOf v fun j k₂ => do
/- Check whether new path: `i -(k₁)-> u -(k)-> v -(k₂) -> j` is shorter -/
updateIfShorter i j (k₁+k+k₂) v
private def internalizeCnstr (e : Expr) (c : Cnstr Expr) : GoalM Unit := do
let u mkNode c.u
let v mkNode c.v
let c := { c with u, v }
if let some k getDist? u v then
if ( propagateTrue u v k c e) then
return ()
if let some k getDist? v u then
if ( propagateFalse v u k c e) then
return ()
trace[grind.offset.internalize] "{e} ↦ {c}"
modify' fun s => { s with
cnstrs := s.cnstrs.insert { expr := e } c
cnstrsOf :=
let cs := if let some cs := s.cnstrsOf.find? (u, v) then (c, e) :: cs else [(c, e)]
s.cnstrsOf.insert (u, v) cs
}
private def getZeroNode : GoalM NodeId := do
mkNode ( getNatZeroExpr)
/-- Internalize `e` of the form `b + k` -/
private def internalizeTerm (e : Expr) (b : Expr) (k : Nat) : GoalM Unit := do
-- `e` is of the form `b + k`
let u mkNode e
let v mkNode b
-- `u = v + k`. So, we add edges for `u ≤ v + k` and `v + k ≤ u`.
let h := mkApp (mkConst ``Nat.le_refl) e
addEdge u v k h
addEdge v u (-k) h
-- `0 + k ≤ u`
let z getZeroNode
addEdge z u (-k) <| mkApp2 (mkConst ``Grind.Nat.le_offset) b (toExpr k)
/--
Returns `true`, if `parent?` is relevant for internalization.
For example, we do not want to internalize an offset term that
is the child of an addition. This kind of term will be processed by the
more general linear arithmetic module.
-/
private def isRelevantParent (parent? : Option Expr) : GoalM Bool := do
let some parent := parent? | return false
let z getNatZeroExpr
return !isNatAdd parent && (isNatOffsetCnstr? parent z).isNone
private def isEqParent (parent? : Option Expr) : Bool := Id.run do
let some parent := parent? | return false
return parent.isEq
def internalize (e : Expr) (parent? : Option Expr) : GoalM Unit := do
let z getNatZeroExpr
if let some c := isNatOffsetCnstr? e z then
internalizeCnstr e c
else if ( isRelevantParent parent?) then
if let some (b, k) := isNatOffset? e then
internalizeTerm e b k
else if let some k := isNatNum? e then
-- core module has support for detecting equality between literals
unless isEqParent parent? do
internalizeTerm e z k
@[export lean_process_new_offset_eq]
def processNewOffsetEqImpl (a b : Expr) : GoalM Unit := do
unless isSameExpr a b do
trace[grind.offset.eq.to] "{a}, {b}"
let u getNodeId a
let v getNodeId b
let h mkEqProof a b
addEdge u v 0 <| mkApp3 (mkConst ``Grind.Nat.le_of_eq_1) a b h
addEdge v u 0 <| mkApp3 (mkConst ``Grind.Nat.le_of_eq_2) a b h
@[export lean_process_new_offset_eq_lit]
def processNewOffsetEqLitImpl (a b : Expr) : GoalM Unit := do
unless isSameExpr a b do
trace[grind.offset.eq.to] "{a}, {b}"
let some k := isNatNum? b | unreachable!
let u getNodeId a
let z mkNode ( getNatZeroExpr)
let h mkEqProof a b
addEdge u z k <| mkApp3 (mkConst ``Grind.Nat.le_of_eq_1) a b h
addEdge z u (-k) <| mkApp3 (mkConst ``Grind.Nat.le_of_eq_2) a b h
def traceDists : GoalM Unit := do
let s get'
for u in [:s.targets.size], es in s.targets.toArray do
for (v, k) in es do
trace[grind.offset.dist] "#{u} -({k})-> #{v}"
def Cnstr.toExpr (c : Cnstr NodeId) : GoalM Expr := do
let u := ( get').nodes[c.u]!
let v := ( get').nodes[c.v]!
if c.k == 0 then
return mkNatLE u v
else if c.k < 0 then
return mkNatLE (mkNatAdd u (Lean.toExpr ((-c.k).toNat))) v
else
return mkNatLE u (mkNatAdd v (Lean.toExpr c.k.toNat))
def checkInvariants : GoalM Unit := do
let s get'
for u in [:s.targets.size], es in s.targets.toArray do
for (v, k) in es do
let c : Cnstr NodeId := { u, v, k }
trace[grind.debug.offset] "{c}"
let p mkProofForPath u v
trace[grind.debug.offset.proof] "{p} : {← inferType p}"
check p
unless ( withDefault <| isDefEq ( inferType p) ( Cnstr.toExpr c)) do
trace[grind.debug.offset.proof] "failed: {← inferType p} =?= {← Cnstr.toExpr c}"
unreachable!
end Lean.Meta.Grind.Arith.Offset

View File

@@ -1,168 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Grind.Offset
import Init.Grind.Lemmas
import Lean.Meta.Tactic.Grind.Types
namespace Lean.Meta.Grind.Arith
/-!
Helper functions for constructing proof terms in the arithmetic procedures.
-/
namespace Offset
/-- Returns a proof for `true = true` -/
def rfl_true : Expr := mkConst ``Grind.rfl_true
private def toExprN (n : Int) :=
assert! n >= 0
toExpr n.toNat
open Lean.Grind in
/--
Assume `pi₁` is `{ w := u, k := k₁, proof := p₁ }` and `pi₂` is `{ w := w, k := k₂, proof := p₂ }`
`p₁` is the proof for edge `u -(k₁) → w` and `p₂` the proof for edge `w -(k₂)-> v`.
Then, this function returns a proof for edge `u -(k₁+k₂) -> v`.
-/
def mkTrans (nodes : PArray Expr) (pi₁ : ProofInfo) (pi₂ : ProofInfo) (v : NodeId) : ProofInfo :=
let { w := u, k := k₁, proof := p₁ } := pi₁
let { w, k := k₂, proof := p₂ } := pi₂
let u := nodes[u]!
let w := nodes[w]!
let v := nodes[v]!
let p := if k₁ == 0 then
if k₂ == 0 then
-- u ≤ w, w ≤ v
mkApp5 (mkConst ``Nat.le_trans) u w v p₁ p₂
else if k₂ > 0 then
-- u ≤ v, w ≤ v + k₂
mkApp6 (mkConst ``Nat.le_ro) u w v (toExprN k₂) p₁ p₂
else
let k₂ := - k₂
-- u ≤ w, w + k₂ ≤ v
mkApp6 (mkConst ``Nat.le_lo) u w v (toExprN k₂) p₁ p₂
else if k₁ < 0 then
let k₁ := -k₁
if k₂ == 0 then
mkApp6 (mkConst ``Nat.lo_le) u w v (toExprN k₁) p₁ p₂
else if k₂ < 0 then
let k₂ := -k₂
mkApp7 (mkConst ``Nat.lo_lo) u w v (toExprN k₁) (toExprN k₂) p₁ p₂
else
let ke₁ := toExprN k₁
let ke₂ := toExprN k₂
if k₁ > k₂ then
mkApp8 (mkConst ``Nat.lo_ro_1) u w v ke₁ ke₂ rfl_true p₁ p₂
else
mkApp7 (mkConst ``Nat.lo_ro_2) u w v ke₁ ke₂ p₁ p₂
else
let ke₁ := toExprN k₁
if k₂ == 0 then
mkApp6 (mkConst ``Nat.ro_le) u w v ke₁ p₁ p₂
else if k₂ < 0 then
let k₂ := -k₂
let ke₂ := toExprN k₂
if k₂ > k₁ then
mkApp8 (mkConst ``Nat.ro_lo_2) u w v ke₁ ke₂ rfl_true p₁ p₂
else
mkApp7 (mkConst ``Nat.ro_lo_1) u w v ke₁ ke₂ p₁ p₂
else
let ke₂ := toExprN k₂
mkApp7 (mkConst ``Nat.ro_ro) u w v ke₁ ke₂ p₁ p₂
{ w := pi₁.w, k := k₁+k₂, proof := p }
open Lean.Grind in
def mkOfNegEqFalse (nodes : PArray Expr) (c : Cnstr NodeId) (h : Expr) : Expr :=
let u := nodes[c.u]!
let v := nodes[c.v]!
if c.k == 0 then
mkApp3 (mkConst ``Nat.of_le_eq_false) u v h
else if c.k == -1 then
mkApp3 (mkConst ``Nat.of_lo_eq_false_1) u v h
else if c.k < 0 then
mkApp4 (mkConst ``Nat.of_lo_eq_false) u v (toExprN (-c.k)) h
else
mkApp4 (mkConst ``Nat.of_ro_eq_false) u v (toExprN c.k) h
/--
Returns a proof of `False` using a negative cycle composed of
- `u --(kuv)--> v` with proof `huv`
- `v --(kvu)--> u` with proof `hvu`
-/
def mkUnsatProof (u v : Expr) (kuv : Int) (huv : Expr) (kvu : Int) (hvu : Expr) : Expr :=
if kuv == 0 then
assert! kvu < 0
mkApp6 (mkConst ``Grind.Nat.unsat_le_lo) u v (toExprN (-kvu)) rfl_true huv hvu
else if kvu == 0 then
mkApp6 (mkConst ``Grind.Nat.unsat_le_lo) v u (toExprN (-kuv)) rfl_true hvu huv
else if kuv < 0 then
if kvu > 0 then
mkApp7 (mkConst ``Grind.Nat.unsat_lo_ro) u v (toExprN (-kuv)) (toExprN kvu) rfl_true huv hvu
else
assert! kvu < 0
mkApp7 (mkConst ``Grind.Nat.unsat_lo_lo) u v (toExprN (-kuv)) (toExprN (-kvu)) rfl_true huv hvu
else
assert! kuv > 0 && kvu < 0
mkApp7 (mkConst ``Grind.Nat.unsat_lo_ro) v u (toExprN (-kvu)) (toExprN kuv) rfl_true hvu huv
/--
Given a path `u --(kuv)--> v` justified by proof `huv`,
construct a proof of `e = True` where `e` is a term corresponding to the edgen `u --(k') --> v`
s.t. `k ≤ k'`
-/
def mkPropagateEqTrueProof (u v : Expr) (k : Int) (huv : Expr) (k' : Int) : Expr :=
if k == 0 then
if k' == 0 then
mkApp3 (mkConst ``Grind.Nat.le_eq_true_of_le) u v huv
else
assert! k' > 0
mkApp4 (mkConst ``Grind.Nat.ro_eq_true_of_le) u v (toExprN k') huv
else if k < 0 then
let k := -k
if k' == 0 then
mkApp4 (mkConst ``Grind.Nat.le_eq_true_of_lo) u v (toExprN k) huv
else if k' < 0 then
let k' := -k'
mkApp6 (mkConst ``Grind.Nat.lo_eq_true_of_lo) u v (toExprN k) (toExprN k') rfl_true huv
else
assert! k' > 0
mkApp5 (mkConst ``Grind.Nat.ro_eq_true_of_lo) u v (toExprN k) (toExprN k') huv
else
assert! k > 0
assert! k' > 0
mkApp6 (mkConst ``Grind.Nat.ro_eq_true_of_ro) u v (toExprN k) (toExprN k') rfl_true huv
/--
Given a path `u --(kuv)--> v` justified by proof `huv`,
construct a proof of `e = False` where `e` is a term corresponding to the edgen `v --(k') --> u`
s.t. `k+k' < 0`
-/
def mkPropagateEqFalseProof (u v : Expr) (k : Int) (huv : Expr) (k' : Int) : Expr :=
if k == 0 then
assert! k' < 0
let k' := -k'
mkApp5 (mkConst ``Grind.Nat.lo_eq_false_of_le) u v (toExprN k') rfl_true huv
else if k < 0 then
let k := -k
if k' == 0 then
mkApp5 (mkConst ``Grind.Nat.le_eq_false_of_lo) u v (toExprN k) rfl_true huv
else if k' < 0 then
let k' := -k'
mkApp6 (mkConst ``Grind.Nat.lo_eq_false_of_lo) u v (toExprN k) (toExprN k') rfl_true huv
else
assert! k' > 0
mkApp6 (mkConst ``Grind.Nat.ro_eq_false_of_lo) u v (toExprN k) (toExprN k') rfl_true huv
else
assert! k > 0
assert! k' < 0
let k' := -k'
mkApp6 (mkConst ``Grind.Nat.lo_eq_false_of_ro) u v (toExprN k) (toExprN k') rfl_true huv
end Offset
end Lean.Meta.Grind.Arith

View File

@@ -1,66 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Data.PersistentArray
import Lean.Meta.Tactic.Grind.ENodeKey
import Lean.Meta.Tactic.Grind.Arith.Util
namespace Lean.Meta.Grind.Arith
namespace Offset
abbrev NodeId := Nat
instance : ToMessageData (Offset.Cnstr NodeId) where
toMessageData c := Offset.toMessageData (α := NodeId) (inst := { toMessageData n := m!"#{n}" }) c
/-- Auxiliary structure used for proof extraction. -/
structure ProofInfo where
w : NodeId
k : Int
proof : Expr
deriving Inhabited
/-- State of the constraint offset procedure. -/
structure State where
/-- Mapping from `NodeId` to the `Expr` represented by the node. -/
nodes : PArray Expr := {}
/-- Mapping from `Expr` to a node representing it. -/
nodeMap : PHashMap ENodeKey NodeId := {}
/-- Mapping from `Expr` representing inequalites to constraints. -/
cnstrs : PHashMap ENodeKey (Cnstr NodeId) := {}
/--
Mapping from pairs `(u, v)` to a list of offset constraints on `u` and `v`.
We use this mapping to implement exhaustive constraint propagation.
-/
cnstrsOf : PHashMap (NodeId × NodeId) (List (Cnstr NodeId × Expr)) := {}
/--
For each node with id `u`, `sources[u]` contains
pairs `(v, k)` s.t. there is a path from `v` to `u` with weight `k`.
-/
sources : PArray (AssocList NodeId Int) := {}
/--
For each node with id `u`, `targets[u]` contains
pairs `(v, k)` s.t. there is a path from `u` to `v` with weight `k`.
-/
targets : PArray (AssocList NodeId Int) := {}
/--
Proof reconstruction information. For each node with id `u`, `proofs[u]` contains
pairs `(v, { w, proof })` s.t. there is a path from `u` to `v`, and
`w` is the penultimate node in the path, and `proof` is the justification for
the last edge.
-/
proofs : PArray (AssocList NodeId ProofInfo) := {}
deriving Inhabited
end Offset
/-- State for the arithmetic procedures. -/
structure State where
offset : Offset.State := {}
deriving Inhabited
end Lean.Meta.Grind.Arith

View File

@@ -1,102 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Expr
import Lean.Message
namespace Lean.Meta.Grind.Arith
/-- Returns `true` if `e` is of the form `Nat` -/
def isNatType (e : Expr) : Bool :=
e.isConstOf ``Nat
/-- Returns `true` if `e` is of the form `@instHAdd Nat instAddNat` -/
def isInstAddNat (e : Expr) : Bool :=
let_expr instHAdd a b := e | false
isNatType a && b.isConstOf ``instAddNat
/-- Returns `true` if `e` is `instLENat` -/
def isInstLENat (e : Expr) : Bool :=
e.isConstOf ``instLENat
/--
Returns `some (a, b)` if `e` is of the form
```
@HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) a b
```
-/
def isNatAdd? (e : Expr) : Option (Expr × Expr) :=
let_expr HAdd.hAdd _ _ _ i a b := e | none
if isInstAddNat i then some (a, b) else none
/--
Returns `true` if `e` is of the form
```
@HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) _ _
```
-/
def isNatAdd (e : Expr) : Bool :=
let_expr HAdd.hAdd _ _ _ i _ _ := e | false
isInstAddNat i
/-- Returns `some k` if `e` `@OfNat.ofNat Nat _ (instOfNatNat k)` -/
def isNatNum? (e : Expr) : Option Nat := Id.run do
let_expr OfNat.ofNat _ _ inst := e | none
let_expr instOfNatNat k := inst | none
let .lit (.natVal k) := k | none
some k
/-- Returns `some (a, k)` if `e` is of the form `a + k`. -/
def isNatOffset? (e : Expr) : Option (Expr × Nat) := Id.run do
let some (a, b) := isNatAdd? e | none
let some k := isNatNum? b | none
some (a, k)
/-- An offset constraint. -/
structure Offset.Cnstr (α : Type) where
u : α
v : α
k : Int := 0
deriving Inhabited
def Offset.Cnstr.neg : Cnstr α Cnstr α
| { u, v, k } => { u := v, v := u, k := -k - 1 }
example (c : Offset.Cnstr α) : c.neg.neg = c := by
cases c; simp [Offset.Cnstr.neg]; omega
def Offset.toMessageData [inst : ToMessageData α] (c : Offset.Cnstr α) : MessageData :=
match c.k with
| .ofNat 0 => m!"{c.u} ≤ {c.v}"
| .ofNat k => m!"{c.u} ≤ {c.v} + {k}"
| .negSucc k => m!"{c.u} + {k + 1} ≤ {c.v}"
instance : ToMessageData (Offset.Cnstr Expr) where
toMessageData c := Offset.toMessageData c
/--
Returns `some cnstr` if `e` is offset constraint.
Remark: `z` is `0` numeral. It is an extra argument because we
want to be able to provide the one that has already been internalized.
-/
def isNatOffsetCnstr? (e : Expr) (z : Expr) : Option (Offset.Cnstr Expr) :=
match_expr e with
| LE.le _ inst a b => if isInstLENat inst then go a b else none
| _ => none
where
go (u v : Expr) :=
if let some (u, k) := isNatOffset? u then
some { u, k := - k, v }
else if let some (v, k) := isNatOffset? v then
some { u, v, k }
else if let some k := isNatNum? u then
some { u := z, v, k := - k }
else if let some k := isNatNum? v then
some { u, v := z, k }
else
some { u, v }
end Lean.Meta.Grind.Arith

View File

@@ -10,7 +10,6 @@ import Lean.Meta.FunInfo
import Lean.Util.FVarSubset
import Lean.Util.PtrSet
import Lean.Util.FVarSubset
import Lean.Meta.Tactic.Grind.Types
namespace Lean.Meta.Grind
namespace Canon
@@ -41,37 +40,42 @@ additions will still use structurally different (and definitionally different) i
Furthermore, `grind` will not be able to infer that `HEq (a + a) (b + b)` even if we add the assumptions `n = m` and `HEq a b`.
-/
@[inline] private def get' : GoalM State :=
return ( get).canon
structure State where
argMap : PHashMap (Expr × Nat) (List Expr) := {}
canon : PHashMap Expr Expr := {}
proofCanon : PHashMap Expr Expr := {}
deriving Inhabited
@[inline] private def modify' (f : State State) : GoalM Unit :=
modify fun s => { s with canon := f s.canon }
inductive CanonElemKind where
| /--
Type class instances are canonicalized using `TransparencyMode.instances`.
-/
instance
| /--
Types and Type formers are canonicalized using `TransparencyMode.default`.
Remark: propositions are just visited. We do not invoke `canonElemCore` for them.
-/
type
| /--
Implicit arguments that are not types, type formers, or instances, are canonicalized
using `TransparencyMode.reducible`
-/
implicit
deriving BEq
/--
Helper function for `canonElemCore`. It tries `isDefEq a b` with default transparency, but using
at most `canonHeartbeats` heartbeats. It reports an issue if the threshold is reached.
Remark: `parent` is use only to report an issue
-/
private def isDefEqBounded (a b : Expr) (parent : Expr) : GoalM Bool := do
withCurrHeartbeats do
let config getConfig
tryCatchRuntimeEx
(withTheReader Core.Context (fun ctx => { ctx with maxHeartbeats := config.canonHeartbeats }) do
withDefault <| isDefEq a b)
fun ex => do
if ex.isRuntime then
let curr := ( getConfig).canonHeartbeats
reportIssue m!"failed to show that{indentExpr a}\nis definitionally equal to{indentExpr b}\nwhile canonicalizing{indentExpr parent}\nusing `{curr}*1000` heartbeats, `(canonHeartbeats := {curr})`"
return false
else
throw ex
def CanonElemKind.explain : CanonElemKind String
| .instance => "type class instances"
| .type => "types (or type formers)"
| .implicit => "implicit arguments (which are not type class instances or types)"
/--
Helper function for canonicalizing `e` occurring as the `i`th argument of an `f`-application.
If `useIsDefEqBounded` is `true`, we try `isDefEqBounded` before returning false
Thus, if diagnostics are enabled, we also re-check them using `TransparencyMode.default`. If the result is different
we report to the user.
-/
def canonElemCore (parent : Expr) (f : Expr) (i : Nat) (e : Expr) (useIsDefEqBounded : Bool) : GoalM Expr := do
let s get'
def canonElemCore (f : Expr) (i : Nat) (e : Expr) (kind : CanonElemKind) : StateT State MetaM Expr := do
let s get
if let some c := s.canon.find? e then
return c
let key := (f, i)
@@ -81,23 +85,20 @@ def canonElemCore (parent : Expr) (f : Expr) (i : Nat) (e : Expr) (useIsDefEqBou
-- We used to check `c.fvarsSubset e` because it is not
-- in general safe to replace `e` with `c` if `c` has more free variables than `e`.
-- However, we don't revert previously canonicalized elements in the `grind` tactic.
-- Moreover, we store the canonicalizer state in the `Goal` because we case-split
-- and different locals are added in different branches.
modify' fun s => { s with canon := s.canon.insert e c }
trace[grind.debugn.canon] "found {e} ===> {c}"
modify fun s => { s with canon := s.canon.insert e c }
trace[grind.debug.canon] "found {e} ===> {c}"
return c
if useIsDefEqBounded then
if ( isDefEqBounded e c parent) then
modify' fun s => { s with canon := s.canon.insert e c }
trace[grind.debugn.canon] "found using `isDefEqBounded`: {e} ===> {c}"
return c
if kind != .type then
if ( isTracingEnabledFor `grind.issues <&&> (withDefault <| isDefEq e c)) then
-- TODO: consider storing this information in some structure that can be browsed later.
trace[grind.issues] "the following {kind.explain} are definitionally equal with `default` transparency but not with a more restrictive transparency{indentExpr e}\nand{indentExpr c}"
trace[grind.debug.canon] "({f}, {i}) ↦ {e}"
modify' fun s => { s with canon := s.canon.insert e e, argMap := s.argMap.insert key (e::cs) }
modify fun s => { s with canon := s.canon.insert e e, argMap := s.argMap.insert key (e::cs) }
return e
abbrev canonType (parent f : Expr) (i : Nat) (e : Expr) := withDefault <| canonElemCore parent f i e (useIsDefEqBounded := false)
abbrev canonInst (parent f : Expr) (i : Nat) (e : Expr) := withReducibleAndInstances <| canonElemCore parent f i e (useIsDefEqBounded := true)
abbrev canonImplicit (parent f : Expr) (i : Nat) (e : Expr) := withReducible <| canonElemCore parent f i e (useIsDefEqBounded := true)
abbrev canonType (f : Expr) (i : Nat) (e : Expr) := withDefault <| canonElemCore f i e .type
abbrev canonInst (f : Expr) (i : Nat) (e : Expr) := withReducibleAndInstances <| canonElemCore f i e .instance
abbrev canonImplicit (f : Expr) (i : Nat) (e : Expr) := withReducible <| canonElemCore f i e .implicit
/--
Return type for the `shouldCanon` function.
@@ -145,10 +146,10 @@ def shouldCanon (pinfos : Array ParamInfo) (i : Nat) (arg : Expr) : MetaM Should
else
return .visit
unsafe def canonImpl (e : Expr) : GoalM Expr := do
unsafe def canonImpl (e : Expr) : StateT State MetaM Expr := do
visit e |>.run' mkPtrMap
where
visit (e : Expr) : StateRefT (PtrMap Expr Expr) GoalM Expr := do
visit (e : Expr) : StateRefT (PtrMap Expr Expr) (StateT State MetaM) Expr := do
unless e.isApp || e.isForall do return e
-- Check whether it is cached
if let some r := ( get).find? e then
@@ -158,11 +159,11 @@ where
if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
let prop := args[0]!
let prop' visit prop
if let some r := ( get').proofCanon.find? prop' then
if let some r := ( getThe State).proofCanon.find? prop' then
pure r
else
let e' := if ptrEq prop prop' then e else mkAppN f (args.set! 0 prop')
modify' fun s => { s with proofCanon := s.proofCanon.insert prop' e' }
modifyThe State fun s => { s with proofCanon := s.proofCanon.insert prop' e' }
pure e'
else
let pinfos := ( getFunInfo f).paramInfo
@@ -172,9 +173,9 @@ where
let arg := args[i]
trace[grind.debug.canon] "[{repr (← shouldCanon pinfos i arg)}]: {arg} : {← inferType arg}"
let arg' match ( shouldCanon pinfos i arg) with
| .canonType => canonType e f i arg
| .canonInst => canonInst e f i arg
| .canonImplicit => canonImplicit e f i ( visit arg)
| .canonType => canonType f i arg
| .canonInst => canonInst f i arg
| .canonImplicit => canonImplicit f i ( visit arg)
| .visit => visit arg
unless ptrEq arg arg' do
args := args.set i arg'
@@ -190,11 +191,11 @@ where
modify fun s => s.insert e e'
return e'
/-- Canonicalizes nested types, type formers, and instances in `e`. -/
def canon (e : Expr) : StateT State MetaM Expr := do
trace[grind.debug.canon] "{e}"
unsafe canonImpl e
end Canon
/-- Canonicalizes nested types, type formers, and instances in `e`. -/
def canon (e : Expr) : GoalM Expr := do
trace[grind.debug.canon] "{e}"
unsafe Canon.canonImpl e
end Lean.Meta.Grind

View File

@@ -10,7 +10,6 @@ import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Inv
import Lean.Meta.Tactic.Grind.PP
import Lean.Meta.Tactic.Grind.Ctor
import Lean.Meta.Tactic.Grind.Util
import Lean.Meta.Tactic.Grind.Internalize
namespace Lean.Meta.Grind
@@ -87,26 +86,6 @@ private partial def updateMT (root : Expr) : GoalM Unit := do
setENode parent { node with mt := gmt }
updateMT parent
/--
Helper function for combining `ENode.offset?` fields and propagating an equality
to the offset constraint module.
-/
private def propagateOffsetEq (rhsRoot lhsRoot : ENode) : GoalM Unit := do
match lhsRoot.offset? with
| some lhsOffset =>
if let some rhsOffset := rhsRoot.offset? then
Arith.processNewOffsetEq lhsOffset rhsOffset
else if isNatNum rhsRoot.self then
Arith.processNewOffsetEqLit lhsOffset rhsRoot.self
else
-- We have to retrieve the node because other fields have been updated
let rhsRoot getENode rhsRoot.self
setENode rhsRoot.self { rhsRoot with offset? := lhsOffset }
| none =>
if isNatNum lhsRoot.self then
if let some rhsOffset := rhsRoot.offset? then
Arith.processNewOffsetEqLit rhsOffset lhsRoot.self
private partial def addEqStep (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
let lhsNode getENode lhs
let rhsNode getENode rhs
@@ -139,7 +118,7 @@ private partial def addEqStep (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit
unless ( isInconsistent) do
if valueInconsistency then
closeGoalWithValuesEq lhsRoot.self rhsRoot.self
trace_goal[grind.debug] "after addEqStep, {← (← get).ppState}"
trace_goal[grind.debug] "after addEqStep, {← ppState}"
checkInvariants
where
go (lhs rhs : Expr) (lhsNode rhsNode lhsRoot rhsRoot : ENode) (flipped : Bool) : GoalM Unit := do
@@ -162,32 +141,31 @@ where
updateRoots lhs rhsNode.root
trace_goal[grind.debug] "{← ppENodeRef lhs} new root {← ppENodeRef rhsNode.root}, {← ppENodeRef (← getRoot lhs)}"
reinsertParents parents
propagateEqcDown lhs
setENode lhsNode.root { ( getENode lhsRoot.self) with -- We must retrieve `lhsRoot` since it was updated.
next := rhsRoot.next
}
setENode rhsNode.root { rhsRoot with
next := lhsRoot.next
size := rhsRoot.size + lhsRoot.size
next := lhsRoot.next
size := rhsRoot.size + lhsRoot.size
hasLambdas := rhsRoot.hasLambdas || lhsRoot.hasLambdas
heqProofs := isHEq || rhsRoot.heqProofs || lhsRoot.heqProofs
}
copyParentsTo parents rhsNode.root
unless ( isInconsistent) do
updateMT rhsRoot.self
propagateOffsetEq rhsRoot lhsRoot
unless ( isInconsistent) do
for parent in parents do
propagateUp parent
unless ( isInconsistent) do
updateMT rhsRoot.self
updateRoots (lhs : Expr) (rootNew : Expr) : GoalM Unit := do
traverseEqc lhs fun n =>
setENode n.self { n with root := rootNew }
propagateEqcDown (lhs : Expr) : GoalM Unit := do
traverseEqc lhs fun n =>
let rec loop (e : Expr) : GoalM Unit := do
let n getENode e
setENode e { n with root := rootNew }
unless ( isInconsistent) do
propagateDown n.self
propagateDown e
if isSameExpr lhs n.next then return ()
loop n.next
loop lhs
/-- Ensures collection of equations to be processed is empty. -/
private def resetNewEqs : GoalM Unit :=
@@ -214,28 +192,22 @@ where
processTodo
/-- Adds a new equality `lhs = rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
private def addEq (lhs rhs proof : Expr) : GoalM Unit := do
def addEq (lhs rhs proof : Expr) : GoalM Unit := do
addEqCore lhs rhs proof false
/-- Adds a new heterogeneous equality `HEq lhs rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
private def addHEq (lhs rhs proof : Expr) : GoalM Unit := do
addEqCore lhs rhs proof true
/-- Save asserted facts for pretty printing goal. -/
private def storeFact (fact : Expr) : GoalM Unit := do
modify fun s => { s with facts := s.facts.push fact }
/-- Adds a new heterogeneous equality `HEq lhs rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
def addHEq (lhs rhs proof : Expr) : GoalM Unit := do
addEqCore lhs rhs proof true
/-- Internalizes `lhs` and `rhs`, and then adds equality `lhs = rhs`. -/
def addNewEq (lhs rhs proof : Expr) (generation : Nat) : GoalM Unit := do
let eq mkEq lhs rhs
storeFact eq
internalize lhs generation eq
internalize rhs generation eq
internalize lhs generation
internalize rhs generation
addEq lhs rhs proof
/-- Adds a new `fact` justified by the given proof and using the given generation. -/
def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
storeFact fact
trace_goal[grind.assert] "{fact}"
if ( isInconsistent) then return ()
resetNewEqs
@@ -245,30 +217,22 @@ def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
where
go (p : Expr) (isNeg : Bool) : GoalM Unit := do
match_expr p with
| Eq α lhs rhs =>
if α.isProp then
-- It is morally an iff.
-- We do not use the `goEq` optimization because we want to register `p` as a case-split
goFact p isNeg
else
goEq p lhs rhs isNeg false
| Eq _ lhs rhs => goEq p lhs rhs isNeg false
| HEq _ lhs _ rhs => goEq p lhs rhs isNeg true
| _ => goFact p isNeg
goFact (p : Expr) (isNeg : Bool) : GoalM Unit := do
internalize p generation
if isNeg then
addEq p ( getFalseExpr) ( mkEqFalse proof)
else
addEq p ( getTrueExpr) ( mkEqTrue proof)
| _ =>
internalize p generation
if isNeg then
addEq p ( getFalseExpr) ( mkEqFalse proof)
else
addEq p ( getTrueExpr) ( mkEqTrue proof)
goEq (p : Expr) (lhs rhs : Expr) (isNeg : Bool) (isHEq : Bool) : GoalM Unit := do
if isNeg then
internalize p generation
addEq p ( getFalseExpr) ( mkEqFalse proof)
else
internalize lhs generation p
internalize rhs generation p
internalize lhs generation
internalize rhs generation
addEqCore lhs rhs proof isHEq
/-- Adds a new hypothesis. -/

View File

@@ -20,7 +20,7 @@ private partial def propagateInjEqs (eqs : Expr) (proof : Expr) : GoalM Unit :=
| HEq _ lhs _ rhs =>
pushHEq ( shareCommon lhs) ( shareCommon rhs) proof
| _ =>
reportIssue m!"unexpected injectivity theorem result type{indentExpr eqs}"
trace_goal[grind.issues] "unexpected injectivity theorem result type{indentExpr eqs}"
return ()
/--

View File

@@ -129,16 +129,6 @@ private partial def matchArgs? (c : Choice) (p : Expr) (e : Expr) : OptionT Goal
let c matchArg? c pArg eArg
matchArgs? c p.appFn! e.appFn!
/-- Similar to `matchArgs?` but if `p` has fewer arguments than `e`, we match `p` with a prefix of `e`. -/
private partial def matchArgsPrefix? (c : Choice) (p : Expr) (e : Expr) : OptionT GoalM Choice := do
let pn := p.getAppNumArgs
let en := e.getAppNumArgs
guard (pn <= en)
if pn == en then
matchArgs? c p e
else
matchArgs? c p (e.getAppPrefix pn)
/--
Matches pattern `p` with term `e` with respect to choice `c`.
We traverse the equivalence class of `e` looking for applications compatible with `p`.
@@ -204,7 +194,7 @@ private def processContinue (c : Choice) (p : Expr) : M Unit := do
let n getENode app
if n.generation < maxGeneration
&& (n.heqProofs || n.isCongrRoot) then
if let some c matchArgsPrefix? c p app |>.run then
if let some c matchArgs? c p app |>.run then
let gen := n.generation
let c := { c with gen := Nat.max gen c.gen }
modify fun s => { s with choiceStack := c :: s.choiceStack }
@@ -250,7 +240,7 @@ private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do w
assert! c.assignment.size == numParams
let (mvars, bis, _) forallMetaBoundedTelescope ( inferType proof) numParams
if mvars.size != thm.numParams then
reportIssue m!"unexpected number of parameters at {← thm.origin.pp}"
trace_goal[grind.issues] "unexpected number of parameters at {← thm.origin.pp}"
return ()
-- Apply assignment
for h : i in [:mvars.size] do
@@ -260,14 +250,14 @@ private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do w
let mvarIdType mvarId.getType
let vType inferType v
unless ( isDefEq mvarIdType vType <&&> mvarId.checkedAssign v) do
reportIssue m!"type error constructing proof for {← thm.origin.pp}\nwhen assigning metavariable {mvars[i]} with {indentExpr v}\n{← mkHasTypeButIsExpectedMsg vType mvarIdType}"
trace_goal[grind.issues] "type error constructing proof for {← thm.origin.pp}\nwhen assigning metavariable {mvars[i]} with {indentExpr v}\n{← mkHasTypeButIsExpectedMsg vType mvarIdType}"
return ()
-- Synthesize instances
for mvar in mvars, bi in bis do
if bi.isInstImplicit && !( mvar.mvarId!.isAssigned) then
let type inferType mvar
unless ( synthesizeInstance mvar type) do
reportIssue m!"failed to synthesize instance when instantiating {← thm.origin.pp}{indentExpr type}"
trace_goal[grind.issues] "failed to synthesize instance when instantiating {← thm.origin.pp}{indentExpr type}"
return ()
let proof := mkAppN proof mvars
if ( mvars.allM (·.mvarId!.isAssigned)) then
@@ -275,7 +265,7 @@ private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do w
else
let mvars mvars.filterM fun mvar => return !( mvar.mvarId!.isAssigned)
if let some mvarBad mvars.findM? fun mvar => return !( isProof mvar) then
reportIssue m!"failed to instantiate {← thm.origin.pp}, failed to instantiate non propositional argument with type{indentExpr (← inferType mvarBad)}"
trace_goal[grind.issues] "failed to instantiate {← thm.origin.pp}, failed to instantiate non propositional argument with type{indentExpr (← inferType mvarBad)}"
let proof mkLambdaFVars (binderInfoForMVars := .default) mvars ( instantiateMVars proof)
addNewInstance thm.origin proof c.gen
where
@@ -310,7 +300,7 @@ private def main (p : Expr) (cnstrs : List Cnstr) : M Unit := do
if (n.heqProofs || n.isCongrRoot) &&
(!useMT || n.mt == gmt) then
withInitApp app do
if let some c matchArgsPrefix? { cnstrs, assignment, gen := n.generation } p app |>.run then
if let some c matchArgs? { cnstrs, assignment, gen := n.generation } p app |>.run then
modify fun s => { s with choiceStack := [c] }
processChoices
@@ -370,4 +360,7 @@ def ematchAndAssert : GrindTactic := fun goal => do
return none
assertAll goal
def ematchStar : GrindTactic :=
ematchAndAssert.iterate
end Lean.Meta.Grind

View File

@@ -170,43 +170,11 @@ private builtin_initialize ematchTheoremsExt : SimpleScopedEnvExtension EMatchTh
initial := {}
}
/--
Symbols with built-in support in `grind` are unsuitable as pattern candidates for E-matching.
This is because `grind` performs normalization operations and uses specialized data structures
to implement these symbols, which may interfere with E-matching behavior.
-/
-- TODO: create attribute?
private def forbiddenDeclNames := #[``Eq, ``HEq, ``Iff, ``And, ``Or, ``Not]
private def isForbidden (declName : Name) := forbiddenDeclNames.contains declName
/--
Auxiliary function to expand a pattern containing forbidden application symbols
into a multi-pattern.
This function enhances the usability of the `[grind =]` attribute by automatically handling
forbidden pattern symbols. For example, consider the following theorem tagged with this attribute:
```
getLast?_eq_some_iff {xs : List α} {a : α} : xs.getLast? = some a ↔ ∃ ys, xs = ys ++ [a]
```
Here, the selected pattern is `xs.getLast? = some a`, but `Eq` is a forbidden pattern symbol.
Instead of producing an error, this function converts the pattern into a multi-pattern,
allowing the attribute to be used conveniently.
The function recursively expands patterns with forbidden symbols by splitting them
into their sub-components. If the pattern does not contain forbidden symbols,
it is returned as-is.
-/
partial def splitWhileForbidden (pat : Expr) : List Expr :=
match_expr pat with
| Not p => splitWhileForbidden p
| And p₁ p₂ => splitWhileForbidden p₁ ++ splitWhileForbidden p₂
| Or p₁ p₂ => splitWhileForbidden p₁ ++ splitWhileForbidden p₂
| Eq _ lhs rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
| Iff lhs rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
| HEq _ lhs _ rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
| _ => [pat]
private def dontCare := mkConst (Name.mkSimple "[grind_dontcare]")
def mkGroundPattern (e : Expr) : Expr :=
@@ -269,36 +237,19 @@ private def getPatternFn? (pattern : Expr) : Option Expr :=
/--
Returns a bit-mask `mask` s.t. `mask[i]` is true if the corresponding argument is
- a type (that is not a proposition) or type former (which has forward dependencies) or
- a type (that is not a proposition) or type former, or
- a proof, or
- an instance implicit argument
When `mask[i]`, we say the corresponding argument is a "support" argument.
-/
def getPatternSupportMask (f : Expr) (numArgs : Nat) : MetaM (Array Bool) := do
let pinfos := ( getFunInfoNArgs f numArgs).paramInfo
forallBoundedTelescope ( inferType f) numArgs fun xs _ => do
xs.mapIdxM fun idx x => do
xs.mapM fun x => do
if ( isProp x) then
return false
else if ( isProof x) then
else if ( isTypeFormer x <||> isProof x) then
return true
else if ( isTypeFormer x) then
if h : idx < pinfos.size then
/-
We originally wanted to ignore types and type formers in `grind` and treat them as supporting elements.
Thus, we would always return `true`. However, we changed our heuristic because of the following example:
```
example {α} (f : α → Type) (a : α) (h : ∀ x, Nonempty (f x)) : Nonempty (f a) := by
grind
```
In this example, we are reasoning about types. Therefore, we adjusted the heuristic as follows:
a type or type former is considered a supporting element only if it has forward dependencies.
Note that this is not the case for `Nonempty`.
-/
return pinfos[idx].hasFwdDeps
else
return true
else
return ( x.fvarId!.getDecl).binderInfo matches .instImplicit
@@ -517,8 +468,7 @@ def mkEMatchEqTheoremCore (origin : Origin) (levelParams : Array Name) (proof :
| _ => throwError "invalid E-matching equality theorem, conclusion must be an equality{indentExpr type}"
let pat := if useLhs then lhs else rhs
let pat preprocessPattern pat normalizePattern
let pats := splitWhileForbidden (pat.abstract xs)
return (xs.size, pats)
return (xs.size, [pat.abstract xs])
mkEMatchTheoremCore origin levelParams numParams proof patterns
/--

View File

@@ -1,30 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Expr
namespace Lean.Meta.Grind
@[inline] def isSameExpr (a b : Expr) : Bool :=
-- It is safe to use pointer equality because we hashcons all expressions
-- inserted into the E-graph
unsafe ptrEq a b
/--
Key for the `ENodeMap` and `ParentMap` map.
We use pointer addresses and rely on the fact all internalized expressions
have been hash-consed, i.e., we have applied `shareCommon`.
-/
structure ENodeKey where
expr : Expr
instance : Hashable ENodeKey where
hash k := unsafe (ptrAddrUnsafe k.expr).toUInt64
instance : BEq ENodeKey where
beq k₁ k₂ := isSameExpr k₁.expr k₂.expr
end Lean.Meta.Grind

View File

@@ -24,7 +24,7 @@ def propagateForallPropUp (e : Expr) : GoalM Unit := do
unless ( isEqTrue p) do return
trace_goal[grind.debug.forallPropagator] "isEqTrue, {e}"
let h₁ mkEqTrueProof p
let qh₁ := q.instantiate1 (mkOfEqTrueCore p h₁)
let qh₁ := q.instantiate1 (mkApp2 (mkConst ``of_eq_true) p h₁)
let r simp qh₁
let q := mkLambda n bi p q
let q' := r.expr
@@ -65,7 +65,7 @@ private def addLocalEMatchTheorems (e : Expr) : GoalM Unit := do
else
let idx modifyGet fun s => (s.nextThmIdx, { s with nextThmIdx := s.nextThmIdx + 1 })
pure <| .local ((`local).appendIndexAfter idx)
let proof := mkOfEqTrueCore e proof
let proof := mkApp2 (mkConst ``of_eq_true) e proof
let size := ( get).newThms.size
let gen getGeneration e
-- TODO: we should have a flag for collecting all unary patterns in a local theorem
@@ -77,7 +77,7 @@ private def addLocalEMatchTheorems (e : Expr) : GoalM Unit := do
if let some thm mkEMatchTheoremWithKind'? origin proof .default then
activateTheorem thm gen
if ( get).newThms.size == size then
reportIssue m!"failed to create E-match local theorem for{indentExpr e}"
trace[grind.issues] "failed to create E-match local theorem for{indentExpr e}"
def propagateForallPropDown (e : Expr) : GoalM Unit := do
let .forallE n a b bi := e | return ()

View File

@@ -11,8 +11,6 @@ import Lean.Meta.Match.MatcherInfo
import Lean.Meta.Match.MatchEqsExt
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Util
import Lean.Meta.Tactic.Grind.Canon
import Lean.Meta.Tactic.Grind.Arith.Internalize
namespace Lean.Meta.Grind
@@ -25,7 +23,7 @@ def addCongrTable (e : Expr) : GoalM Unit := do
let g := e'.getAppFn
unless isSameExpr f g do
unless ( hasSameType f g) do
reportIssue m!"found congruence between{indentExpr e}\nand{indentExpr e'}\nbut functions have different types"
trace_goal[grind.issues] "found congruence between{indentExpr e}\nand{indentExpr e'}\nbut functions have different types"
return ()
trace_goal[grind.debug.congr] "{e} = {e'}"
pushEqHEq e e' congrPlaceholderProof
@@ -55,20 +53,12 @@ private def addSplitCandidate (e : Expr) : GoalM Unit := do
-- TODO: add attribute to make this extensible
private def forbiddenSplitTypes := [``Eq, ``HEq, ``True, ``False]
/-- Returns `true` if `e` is of the form `@Eq Prop a b` -/
def isMorallyIff (e : Expr) : Bool :=
let_expr Eq α _ _ := e | false
α.isProp
/-- Inserts `e` into the list of case-split candidates if applicable. -/
private def checkAndAddSplitCandidate (e : Expr) : GoalM Unit := do
unless e.isApp do return ()
if ( getConfig).splitIte && (e.isIte || e.isDIte) then
addSplitCandidate e
return ()
if isMorallyIff e then
addSplitCandidate e
return ()
if ( getConfig).splitMatch then
if ( isMatcherApp e) then
if let .reduced _ reduceMatcher? e then
@@ -99,17 +89,14 @@ private def pushCastHEqs (e : Expr) : GoalM Unit := do
| f@Eq.recOn α a motive b h v => pushHEq e v (mkApp6 (mkConst ``Grind.eqRecOn_heq f.constLevels!) α a motive b h v)
| _ => return ()
private def preprocessGroundPattern (e : Expr) : GoalM Expr := do
shareCommon ( canon ( normalizeLevels ( unfoldReducible e)))
mutual
/-- Internalizes the nested ground terms in the given pattern. -/
private partial def internalizePattern (pattern : Expr) (generation : Nat) : GoalM Expr := do
if pattern.isBVar || isPatternDontCare pattern then
return pattern
else if let some e := groundPattern? pattern then
let e preprocessGroundPattern e
internalize e generation none
let e shareCommon ( canon ( normalizeLevels ( unfoldReducible e)))
internalize e generation
return mkGroundPattern e
else pattern.withApp fun f args => do
return mkAppN f ( args.mapM (internalizePattern · generation))
@@ -150,7 +137,7 @@ private partial def activateTheoremPatterns (fName : Name) (generation : Nat) :
trace_goal[grind.ematch] "reinsert `{thm.origin.key}`"
modify fun s => { s with thmMap := s.thmMap.insert thm }
partial def internalize (e : Expr) (generation : Nat) (parent? : Option Expr := none) : GoalM Unit := do
partial def internalize (e : Expr) (generation : Nat) : GoalM Unit := do
if ( alreadyInternalized e) then return ()
trace_goal[grind.internalize] "{e}"
match e with
@@ -161,10 +148,10 @@ partial def internalize (e : Expr) (generation : Nat) (parent? : Option Expr :=
| .forallE _ d b _ =>
mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
if ( isProp d <&&> isProp e) then
internalize d generation e
internalize d generation
registerParent e d
unless b.hasLooseBVars do
internalize b generation e
internalize b generation
registerParent e b
propagateUp e
| .lit .. | .const .. =>
@@ -172,13 +159,12 @@ partial def internalize (e : Expr) (generation : Nat) (parent? : Option Expr :=
| .mvar ..
| .mdata ..
| .proj .. =>
reportIssue m!"unexpected kernel projection term during internalization{indentExpr e}\n`grind` uses a pre-processing step that folds them as projection applications, the pre-processor should have failed to fold this term"
trace_goal[grind.issues] "unexpected term during internalization{indentExpr e}"
mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
| .app .. =>
if ( isLitValue e) then
-- We do not want to internalize the components of a literal value.
mkENode e generation
Arith.internalize e parent?
else e.withApp fun f args => do
checkAndAddSplitCandidate e
pushCastHEqs e
@@ -187,22 +173,21 @@ partial def internalize (e : Expr) (generation : Nat) (parent? : Option Expr :=
-- We only internalize the proposition. We can skip the proof because of
-- proof irrelevance
let c := args[0]!
internalize c generation e
internalize c generation
registerParent e c
else
if let .const fName _ := f then
activateTheoremPatterns fName generation
else
internalize f generation e
internalize f generation
registerParent e f
for h : i in [: args.size] do
let arg := args[i]
internalize arg generation e
internalize arg generation
registerParent e arg
mkENode e generation
addCongrTable e
updateAppMap e
Arith.internalize e parent?
propagateUp e
end

View File

@@ -25,14 +25,13 @@ private inductive IntroResult where
private def introNext (goal : Goal) (generation : Nat) : GrindM IntroResult := do
let target goal.mvarId.getType
if target.isArrow then
let (r, _) GoalM.run goal do
let mvarId := ( get).mvarId
goal.mvarId.withContext do
let p := target.bindingDomain!
if !( isProp p) then
let (fvarId, mvarId) mvarId.intro1P
return .newLocal fvarId { ( get) with mvarId }
let (fvarId, mvarId) goal.mvarId.intro1P
return .newLocal fvarId { goal with mvarId }
else
let tag mvarId.getTag
let tag goal.mvarId.getTag
let q := target.bindingBody!
-- TODO: keep applying simp/eraseIrrelevantMData/canon/shareCommon until no progress
let r simp p
@@ -45,13 +44,12 @@ private def introNext (goal : Goal) (generation : Nat) : GrindM IntroResult := d
match r.proof? with
| some he =>
let hNew := mkAppN (mkConst ``Lean.Grind.intro_with_eq) #[p, r.expr, q, he, h]
mvarId.assign hNew
return .newHyp fvarId { ( get) with mvarId := mvarIdNew }
goal.mvarId.assign hNew
return .newHyp fvarId { goal with mvarId := mvarIdNew }
| none =>
-- `p` and `p'` are definitionally equal
mvarId.assign h
return .newHyp fvarId { ( get) with mvarId := mvarIdNew }
return r
goal.mvarId.assign h
return .newHyp fvarId { goal with mvarId := mvarIdNew }
else if target.isLet || target.isForall || target.isLetFun then
let (fvarId, mvarId) goal.mvarId.intro1P
mvarId.withContext do
@@ -63,11 +61,10 @@ private def introNext (goal : Goal) (generation : Nat) : GrindM IntroResult := d
else
let goal := { goal with mvarId }
if target.isLet || target.isLetFun then
let goal GoalM.run' goal do
let v := ( fvarId.getDecl).value
let r simp v
let x shareCommon (mkFVar fvarId)
addNewEq x r.expr ( r.getProof) generation
let v := ( fvarId.getDecl).value
let r simp v
let x shareCommon (mkFVar fvarId)
let goal GoalM.run' goal <| addNewEq x r.expr ( r.getProof) generation
return .newLocal fvarId goal
else
return .newLocal fvarId goal

View File

@@ -6,7 +6,6 @@ Authors: Leonardo de Moura
prelude
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Proof
import Lean.Meta.Tactic.Grind.Arith.Inv
namespace Lean.Meta.Grind
@@ -59,12 +58,9 @@ private def checkParents (e : Expr) : GoalM Unit := do
found := true
break
-- Recall that we have support for `Expr.forallE` propagation. See `ForallProp.lean`.
if let .forallE _ d b _ := parent then
if let .forallE _ d _ _ := parent then
if ( checkChild d) then
found := true
unless b.hasLooseBVars do
if ( checkChild b) then
found := true
unless found do
assert! ( checkChild parent.getAppFn)
else
@@ -104,7 +100,6 @@ def checkInvariants (expensive := false) : GoalM Unit := do
checkEqc node
if expensive then
checkPtrEqImpliesStructEq
Arith.checkInvariants
if expensive && grind.debug.proofs.get ( getOptions) then
checkProofs

View File

@@ -15,7 +15,6 @@ import Lean.Meta.Tactic.Grind.Inv
import Lean.Meta.Tactic.Grind.Intro
import Lean.Meta.Tactic.Grind.EMatch
import Lean.Meta.Tactic.Grind.Split
import Lean.Meta.Tactic.Grind.Solve
import Lean.Meta.Tactic.Grind.SimpUtil
namespace Lean.Meta.Grind
@@ -41,20 +40,17 @@ def GrindM.run (x : GrindM α) (mainDeclName : Name) (config : Grind.Config) (fa
let scState := ShareCommon.State.mk _
let (falseExpr, scState) := ShareCommon.State.shareCommon scState (mkConst ``False)
let (trueExpr, scState) := ShareCommon.State.shareCommon scState (mkConst ``True)
let (natZExpr, scState) := ShareCommon.State.shareCommon scState (mkNatLit 0)
let simprocs Grind.getSimprocs
let simp Grind.getSimpContext
x ( mkMethods fallback).toMethodsRef { mainDeclName, config, simprocs, simp } |>.run' { scState, trueExpr, falseExpr, natZExpr }
x ( mkMethods fallback).toMethodsRef { mainDeclName, config, simprocs, simp } |>.run' { scState, trueExpr, falseExpr }
private def mkGoal (mvarId : MVarId) : GrindM Goal := do
let trueExpr getTrueExpr
let falseExpr getFalseExpr
let natZeroExpr getNatZeroExpr
let thmMap getEMatchTheorems
GoalM.run' { mvarId, thmMap } do
mkENodeCore falseExpr (interpreted := true) (ctor := false) (generation := 0)
mkENodeCore trueExpr (interpreted := true) (ctor := false) (generation := 0)
mkENodeCore natZeroExpr (interpreted := true) (ctor := false) (generation := 0)
private def initCore (mvarId : MVarId) : GrindM (List Goal) := do
mvarId.ensureProp
@@ -69,10 +65,17 @@ private def initCore (mvarId : MVarId) : GrindM (List Goal) := do
goals.forM (·.checkInvariants (expensive := true))
return goals.filter fun goal => !goal.inconsistent
def main (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Fallback) : MetaM (List Goal) := do
let go : GrindM (List Goal) := do
def all (goals : List Goal) (f : Goal GrindM (List Goal)) : GrindM (List Goal) := do
goals.foldlM (init := []) fun acc goal => return acc ++ ( f goal)
/-- A very simple strategy -/
private def simple (goals : List Goal) : GrindM (List Goal) := do
applyToAll (assertAll >> ematchStar >> (splitNext >> assertAll >> ematchStar).iterate) goals
def main (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Fallback) : MetaM (List MVarId) := do
let go : GrindM (List MVarId) := do
let goals initCore mvarId
let goals solve goals
let goals simple goals
let goals goals.filterMapM fun goal => do
if goal.inconsistent then return none
let goal GoalM.run' goal fallback
@@ -80,7 +83,7 @@ def main (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallba
if ( goal.mvarId.isAssigned) then return none
return some goal
trace[grind.debug.final] "{← ppGoals goals}"
return goals
return goals.map (·.mvarId)
go.run mainDeclName config fallback
end Lean.Meta.Grind

View File

@@ -5,162 +5,62 @@ Authors: Leonardo de Moura
-/
prelude
import Init.Grind.Util
import Init.Grind.PP
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.Arith.Model
namespace Lean.Meta.Grind
/-- Helper function for pretty printing the state for debugging purposes. -/
def Goal.ppENodeRef (goal : Goal) (e : Expr) : MetaM MessageData := do
let some n := goal.getENode? e | return "_"
let type inferType e
let u getLevel type
let d := mkApp3 (mkConst ``Grind.node_def [u]) (toExpr n.idx) type e
return m!"{d}"
@[inherit_doc Goal.ppENodeRef]
def ppENodeRef (e : Expr) : GoalM MessageData := do
( get).ppENodeRef e
def ppENodeRef (e : Expr) : GoalM Format := do
let some n getENode? e | return "_"
return f!"#{n.idx}"
/-- Helper function for pretty printing the state for debugging purposes. -/
private def Goal.ppENodeDeclValue (goal : Goal) (e : Expr) : MetaM MessageData := do
def ppENodeDeclValue (e : Expr) : GoalM Format := do
if e.isApp && !( isLitValue e) then
e.withApp fun f args => do
let r if f.isConst then
pure m!"{f}"
ppExpr f
else
goal.ppENodeRef f
ppENodeRef f
let mut r := r
for arg in args do
r := r ++ " " ++ ( goal.ppENodeRef arg)
r := r ++ " " ++ ( ppENodeRef arg)
return r
else
ppExpr e
/-- Helper function for pretty printing the state for debugging purposes. -/
private def Goal.ppENodeDecl (goal : Goal) (e : Expr) : MetaM MessageData := do
let mut r := m!"{← goal.ppENodeRef e} := {← goal.ppENodeDeclValue e}"
let n goal.getENode e
def ppENodeDecl (e : Expr) : GoalM Format := do
let mut r := f!"{← ppENodeRef e} := {← ppENodeDeclValue e}"
let n getENode e
unless isSameExpr e n.root do
r := r ++ m!" ↦ {← goal.ppENodeRef n.root}"
r := r ++ f!" ↦ {← ppENodeRef n.root}"
if n.interpreted then
r := r ++ ", [val]"
if n.ctor then
r := r ++ ", [ctor]"
if grind.debug.get ( getOptions) then
if let some target := goal.getTarget? e then
r := r ++ m!" ↝ {← goal.ppENodeRef target}"
if let some target getTarget? e then
r := r ++ f!" ↝ {← ppENodeRef target}"
return r
/-- Pretty print goal state for debugging purposes. -/
def Goal.ppState (goal : Goal) : MetaM MessageData := do
let mut r := m!"Goal:"
let nodes := goal.getENodes
def ppState : GoalM Format := do
let mut r := f!"Goal:"
let nodes getENodes
for node in nodes do
r := r ++ "\n" ++ ( goal.ppENodeDecl node.self)
let eqcs := goal.getEqcs
r := r ++ "\n" ++ ( ppENodeDecl node.self)
let eqcs getEqcs
for eqc in eqcs do
if eqc.length > 1 then
r := r ++ "\n" ++ "{" ++ (MessageData.joinSep ( eqc.mapM goal.ppENodeRef) ", ") ++ "}"
r := r ++ "\n" ++ "{" ++ (Format.joinSep ( eqc.mapM ppENodeRef) ", ") ++ "}"
return r
def ppGoals (goals : List Goal) : MetaM MessageData := do
let mut r := m!""
def ppGoals (goals : List Goal) : GrindM Format := do
let mut r := f!""
for goal in goals do
let m goal.ppState
r := r ++ Format.line ++ m
let (f, _) GoalM.run goal ppState
r := r ++ Format.line ++ f
return r
private def ppExprArray (cls : Name) (header : String) (es : Array Expr) (clsElem : Name := Name.mkSimple "_") : MessageData :=
let es := es.map fun e => .trace { cls := clsElem} m!"{e}" #[]
.trace { cls } header es
private abbrev M := ReaderT Goal (StateT (Array MessageData) MetaM)
private def pushMsg (m : MessageData) : M Unit :=
modify fun s => s.push m
private def ppEqcs : M Unit := do
let mut trueEqc? : Option MessageData := none
let mut falseEqc? : Option MessageData := none
let mut otherEqcs : Array MessageData := #[]
let goal read
for eqc in goal.getEqcs do
if Option.isSome <| eqc.find? (·.isTrue) then
let eqc := eqc.filter fun e => !e.isTrue
unless eqc.isEmpty do
trueEqc? := ppExprArray `eqc "True propositions" eqc.toArray `prop
else if Option.isSome <| eqc.find? (·.isFalse) then
let eqc := eqc.filter fun e => !e.isFalse
unless eqc.isEmpty do
falseEqc? := ppExprArray `eqc "False propositions" eqc.toArray `prop
else if let e :: _ :: _ := eqc then
-- We may want to add a flag to pretty print equivalence classes of nested proofs
unless ( isProof e) do
otherEqcs := otherEqcs.push <| .trace { cls := `eqc } (.group ("{" ++ (MessageData.joinSep (eqc.map toMessageData) ("," ++ Format.line)) ++ "}")) #[]
if let some trueEqc := trueEqc? then pushMsg trueEqc
if let some falseEqc := falseEqc? then pushMsg falseEqc
unless otherEqcs.isEmpty do
pushMsg <| .trace { cls := `eqc } "Equivalence classes" otherEqcs
private def ppEMatchTheorem (thm : EMatchTheorem) : MetaM MessageData := do
let m := m!"{← thm.origin.pp}:\n{← inferType thm.proof}\npatterns: {thm.patterns.map ppPattern}"
return .trace { cls := `thm } m #[]
private def ppActiveTheorems : M Unit := do
let goal read
let m goal.thms.toArray.mapM fun thm => ppEMatchTheorem thm
let m := m ++ ( goal.newThms.toArray.mapM fun thm => ppEMatchTheorem thm)
unless m.isEmpty do
pushMsg <| .trace { cls := `ematch } "E-matching" m
private def ppOffset : M Unit := do
let goal read
let s := goal.arith.offset
let nodes := s.nodes
if nodes.isEmpty then return ()
let model Arith.Offset.mkModel goal
let mut ms := #[]
for (e, val) in model do
ms := ms.push <| .trace { cls := `assign } m!"{e} := {val}" #[]
pushMsg <| .trace { cls := `offset } "Assignment satisfying offset contraints" ms
private def ppIssues : M Unit := do
let issues := ( read).issues
unless issues.isEmpty do
pushMsg <| .trace { cls := `issues } "Issues" issues.reverse.toArray
private def ppThresholds (c : Grind.Config) : M Unit := do
let goal read
let maxGen := goal.enodes.foldl (init := 0) fun g _ n => Nat.max g n.generation
let mut msgs := #[]
if goal.numInstances c.instances then
msgs := msgs.push <| .trace { cls := `limit } m!"maximum number of instances generated by E-matching has been reached, threshold: `(instances := {c.instances})`" #[]
if goal.numEmatch c.ematch then
msgs := msgs.push <| .trace { cls := `limit } m!"maximum number of E-matching rounds has been reached, threshold: `(ematch := {c.ematch})`" #[]
if goal.numSplits c.splits then
msgs := msgs.push <| .trace { cls := `limit } m!"maximum number of case-splits has been reached, threshold: `(splits := {c.splits})`" #[]
if maxGen c.gen then
msgs := msgs.push <| .trace { cls := `limit } m!"maximum term generation has been reached, threshold: `(gen := {c.gen})`" #[]
unless msgs.isEmpty do
pushMsg <| .trace { cls := `limits } "Thresholds reached" msgs
def goalToMessageData (goal : Goal) (config : Grind.Config) : MetaM MessageData := goal.mvarId.withContext do
let (_, m) go goal |>.run #[]
let gm := MessageData.trace { cls := `grind, collapsed := false } "Diagnostics" m
let r := m!"{.ofGoal goal.mvarId}\n{gm}"
addMessageContextFull r
where
go : M Unit := do
pushMsg <| ppExprArray `facts "Asserted facts" goal.facts.toArray `prop
ppEqcs
ppActiveTheorems
ppOffset
ppThresholds config
ppIssues
def goalsToMessageData (goals : List Goal) (config : Grind.Config) : MetaM MessageData :=
return MessageData.joinSep ( goals.mapM (goalToMessageData · config)) m!"\n"
end Lean.Meta.Grind

View File

@@ -126,32 +126,32 @@ builtin_grind_propagator propagateEqUp ↑Eq := fun e => do
else if ( isEqTrue b) then
pushEq e a <| mkApp3 (mkConst ``Lean.Grind.eq_eq_of_eq_true_right) a b ( mkEqTrueProof b)
else if ( isEqv a b) then
pushEqTrue e <| mkEqTrueCore e ( mkEqProof a b)
pushEqTrue e <| mkApp2 (mkConst ``eq_true) e ( mkEqProof a b)
/-- Propagates `Eq` downwards -/
builtin_grind_propagator propagateEqDown Eq := fun e => do
if ( isEqTrue e) then
let_expr Eq _ a b := e | return ()
pushEq a b <| mkOfEqTrueCore e ( mkEqTrueProof e)
pushEq a b <| mkApp2 (mkConst ``of_eq_true) e ( mkEqTrueProof e)
/-- Propagates `EqMatch` downwards -/
builtin_grind_propagator propagateEqMatchDown Grind.EqMatch := fun e => do
if ( isEqTrue e) then
let_expr Grind.EqMatch _ a b origin := e | return ()
markCaseSplitAsResolved origin
pushEq a b <| mkOfEqTrueCore e ( mkEqTrueProof e)
pushEq a b <| mkApp2 (mkConst ``of_eq_true) e ( mkEqTrueProof e)
/-- Propagates `HEq` downwards -/
builtin_grind_propagator propagateHEqDown HEq := fun e => do
if ( isEqTrue e) then
let_expr HEq _ a _ b := e | return ()
pushHEq a b <| mkOfEqTrueCore e ( mkEqTrueProof e)
pushHEq a b <| mkApp2 (mkConst ``of_eq_true) e ( mkEqTrueProof e)
/-- Propagates `HEq` upwards -/
builtin_grind_propagator propagateHEqUp HEq := fun e => do
let_expr HEq _ a _ b := e | return ()
if ( isEqv a b) then
pushEqTrue e <| mkEqTrueCore e ( mkHEqProof a b)
pushEqTrue e <| mkApp2 (mkConst ``eq_true) e ( mkHEqProof a b)
/-- Propagates `ite` upwards -/
builtin_grind_propagator propagateIte ite := fun e => do
@@ -166,7 +166,7 @@ builtin_grind_propagator propagateDIte ↑dite := fun e => do
let_expr f@dite α c h a b := e | return ()
if ( isEqTrue c) then
let h₁ mkEqTrueProof c
let ah₁ := mkApp a (mkOfEqTrueCore c h₁)
let ah₁ := mkApp a (mkApp2 (mkConst ``of_eq_true) c h₁)
let p simp ah₁
let r := p.expr
let h₂ p.getProof

View File

@@ -11,7 +11,6 @@ import Lean.Meta.Tactic.Grind.Util
import Lean.Meta.Tactic.Grind.Types
import Lean.Meta.Tactic.Grind.DoNotSimp
import Lean.Meta.Tactic.Grind.MarkNestedProofs
import Lean.Meta.Tactic.Grind.Canon
namespace Lean.Meta.Grind
/-- Simplifies the given expression using the `grind` simprocs and normalization theorems. -/
@@ -25,13 +24,13 @@ def simpCore (e : Expr) : GrindM Simp.Result := do
Simplifies `e` using `grind` normalization theorems and simprocs,
and then applies several other preprocessing steps.
-/
def simp (e : Expr) : GoalM Simp.Result := do
def simp (e : Expr) : GrindM Simp.Result := do
let e instantiateMVars e
let r simpCore e
let e' := r.expr
let e' unfoldReducible e'
let e' abstractNestedProofs e'
let e' markNestedProofs e'
let e' unfoldReducible e'
let e' eraseIrrelevantMData e'
let e' foldProjs e'
let e' normalizeLevels e'

View File

@@ -1,92 +0,0 @@
/-
Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Lean.Meta.Tactic.Grind.Combinators
import Lean.Meta.Tactic.Grind.Split
import Lean.Meta.Tactic.Grind.EMatch
namespace Lean.Meta.Grind
namespace Solve
structure State where
todo : List Goal
failures : List Goal := []
stop : Bool := false
private abbrev M := StateRefT State GrindM
def getNext? : M (Option Goal) := do
let goal::todo := ( get).todo | return none
modify fun s => { s with todo }
return some goal
def pushGoal (goal : Goal) : M Unit :=
modify fun s => { s with todo := goal :: s.todo }
def pushGoals (goals : List Goal) : M Unit :=
modify fun s => { s with todo := goals ++ s.todo }
def pushFailure (goal : Goal) : M Unit := do
modify fun s => { s with failures := goal :: s.failures }
if ( get).failures.length ( getConfig).failures then
modify fun s => { s with stop := true }
@[inline] def stepGuard (x : Goal M Bool) (goal : Goal) : M Bool := do
try
x goal
catch ex =>
if ex.isMaxHeartbeat || ex.isMaxRecDepth then
let goal goal.reportIssue ex.toMessageData
pushFailure goal
return true
else
throw ex
def applyTac (x : GrindTactic) (goal : Goal) : M Bool := do
let go (goal : Goal) : M Bool := do
let some goals x goal | return false
pushGoals goals
return true
stepGuard go goal
def tryAssertNext : Goal M Bool := applyTac assertNext
def tryEmatch : Goal M Bool := applyTac ematchAndAssert
def trySplit : Goal M Bool := applyTac splitNext
def maxNumFailuresReached : M Bool := do
return ( get).failures.length ( getConfig).failures
partial def main : M Unit := do
repeat do
if ( get).stop then
return ()
let some goal getNext? |
return ()
if goal.inconsistent then
continue
if ( tryAssertNext goal) then
continue
if ( tryEmatch goal) then
continue
if ( trySplit goal) then
continue
pushFailure goal
end Solve
/--
Try to solve/close the given goals, and returns the ones that could not be solved.
-/
def solve (goals : List Goal) : GrindM (List Goal) := do
let (_, s) Solve.main.run { todo := goals }
let todo s.todo.mapM fun goal => do
goal.reportIssue m!"this goal was not fully processed due to previous failures, threshold: `(failures := {(← getConfig).failures})`"
return s.failures.reverse ++ todo
end Lean.Meta.Grind

View File

@@ -14,133 +14,77 @@ namespace Lean.Meta.Grind
inductive CaseSplitStatus where
| resolved
| notReady
| ready (numCases : Nat) (isRec := false)
| ready
deriving Inhabited, BEq
/-- Given `c`, the condition of an `if-then-else`, check whether we need to case-split on the `if-then-else` or not -/
private def checkIteCondStatus (c : Expr) : GoalM CaseSplitStatus := do
if ( isEqTrue c <||> isEqFalse c) then
return .resolved
else
return .ready 2
/--
Given `e` of the form `a b`, check whether we are ready to case-split on `e`.
That is, `e` is `True`, but neither `a` nor `b` is `True`."
-/
private def checkDisjunctStatus (e a b : Expr) : GoalM CaseSplitStatus := do
if ( isEqTrue e) then
if ( isEqTrue a <||> isEqTrue b) then
return .resolved
else
return .ready 2
else if ( isEqFalse e) then
return .resolved
else
return .notReady
/--
Given `e` of the form `a ∧ b`, check whether we are ready to case-split on `e`.
That is, `e` is `False`, but neither `a` nor `b` is `False`.
-/
private def checkConjunctStatus (e a b : Expr) : GoalM CaseSplitStatus := do
if ( isEqTrue e) then
return .resolved
else if ( isEqFalse e) then
if ( isEqFalse a <||> isEqFalse b) then
return .resolved
else
return .ready 2
else
return .notReady
/--
Given `e` of the form `@Eq Prop a b`, check whether we are ready to case-split on `e`.
There are two cases:
1- `e` is `True`, but neither both `a` and `b` are `True`, nor both `a` and `b` are `False`.
2- `e` is `False`, but neither `a` is `True` and `b` is `False`, nor `a` is `False` and `b` is `True`.
-/
private def checkIffStatus (e a b : Expr) : GoalM CaseSplitStatus := do
if ( isEqTrue e) then
if ( (isEqTrue a <&&> isEqTrue b) <||> (isEqFalse a <&&> isEqFalse b)) then
return .resolved
else
return .ready 2
else if ( isEqFalse e) then
if ( (isEqTrue a <&&> isEqFalse b) <||> (isEqFalse a <&&> isEqTrue b)) then
return .resolved
else
return .ready 2
else
return .notReady
/-- Returns `true` is `c` is congruent to a case-split that was already performed. -/
private def isCongrToPrevSplit (c : Expr) : GoalM Bool := do
( get).resolvedSplits.foldM (init := false) fun flag { expr := c' } => do
if flag then
return true
else
return isCongruent ( get).enodes c c'
private def checkCaseSplitStatus (e : Expr) : GoalM CaseSplitStatus := do
match_expr e with
| Or a b => checkDisjunctStatus e a b
| And a b => checkConjunctStatus e a b
| Eq _ a b => checkIffStatus e a b
| ite _ c _ _ _ => checkIteCondStatus c
| dite _ c _ _ _ => checkIteCondStatus c
| Or a b =>
if ( isEqTrue e) then
if ( isEqTrue a <||> isEqTrue b) then
return .resolved
else
return .ready
else if ( isEqFalse e) then
return .resolved
else
return .notReady
| And a b =>
if ( isEqTrue e) then
return .resolved
else if ( isEqFalse e) then
if ( isEqFalse a <||> isEqFalse b) then
return .resolved
else
return .ready
else
return .notReady
| ite _ c _ _ _ =>
if ( isEqTrue c <||> isEqFalse c) then
return .resolved
else
return .ready
| dite _ c _ _ _ =>
if ( isEqTrue c <||> isEqFalse c) then
return .resolved
else
return .ready
| _ =>
if ( isResolvedCaseSplit e) then
trace[grind.debug.split] "split resolved: {e}"
return .resolved
if ( isCongrToPrevSplit e) then
return .resolved
if let some info := isMatcherAppCore? ( getEnv) e then
return .ready info.numAlts
if ( isMatcherApp e) then
return .ready
let .const declName .. := e.getAppFn | unreachable!
if let some info isInductivePredicate? declName then
if ( isEqTrue e) then
return .ready info.ctors.length info.isRec
if ( isInductivePredicate declName <&&> isEqTrue e) then
return .ready
return .notReady
private inductive SplitCandidate where
| none
| some (c : Expr) (numCases : Nat) (isRec : Bool)
/-- Returns the next case-split to be performed. It uses a very simple heuristic. -/
private def selectNextSplit? : GoalM SplitCandidate := do
if ( isInconsistent) then return .none
if ( checkMaxCaseSplit) then return .none
go ( get).splitCandidates .none []
private def selectNextSplit? : GoalM (Option Expr) := do
if ( isInconsistent) then return none
if ( checkMaxCaseSplit) then return none
go ( get).splitCandidates none []
where
go (cs : List Expr) (c? : SplitCandidate) (cs' : List Expr) : GoalM SplitCandidate := do
go (cs : List Expr) (c? : Option Expr) (cs' : List Expr) : GoalM (Option Expr) := do
match cs with
| [] =>
modify fun s => { s with splitCandidates := cs'.reverse }
if let .some _ numCases isRec := c? then
let numSplits := ( get).numSplits
-- We only increase the number of splits if there is more than one case or it is recursive.
let numSplits := if numCases > 1 || isRec then numSplits + 1 else numSplits
if c?.isSome then
-- Remark: we reset `numEmatch` after each case split.
-- We should consider other strategies in the future.
modify fun s => { s with numSplits, numEmatch := 0 }
modify fun s => { s with numSplits := s.numSplits + 1, numEmatch := 0 }
return c?
| c::cs =>
match ( checkCaseSplitStatus c) with
| .notReady => go cs c? (c::cs')
| .resolved => go cs c? cs'
| .ready numCases isRec =>
| .ready =>
match c? with
| .none => go cs (.some c numCases isRec) cs'
| .some c' numCases' _ =>
let isBetter : GoalM Bool := do
if numCases == 1 && !isRec && numCases' > 1 then
return true
if ( getGeneration c) < ( getGeneration c') then
return true
return numCases < numCases'
if ( isBetter) then
go cs (.some c numCases isRec) (c'::cs')
| none => go cs (some c) cs'
| some c' =>
if ( getGeneration c) < ( getGeneration c') then
go cs (some c) (c'::cs')
else
go cs c? (c::cs')
@@ -150,12 +94,7 @@ private def mkCasesMajor (c : Expr) : GoalM Expr := do
| And a b => return mkApp3 (mkConst ``Grind.or_of_and_eq_false) a b ( mkEqFalseProof c)
| ite _ c _ _ _ => return mkEM c
| dite _ c _ _ _ => return mkEM c
| Eq _ a b =>
if ( isEqTrue c) then
return mkApp3 (mkConst ``Grind.of_eq_eq_true) a b ( mkEqTrueProof c)
else
return mkApp3 (mkConst ``Grind.of_eq_eq_false) a b ( mkEqFalseProof c)
| _ => return mkOfEqTrueCore c ( mkEqTrueProof c)
| _ => return mkApp2 (mkConst ``of_eq_true) c ( mkEqTrueProof c)
/-- Introduces new hypotheses in each goal. -/
private def introNewHyp (goals : List Goal) (acc : List Goal) (generation : Nat) : GrindM (List Goal) := do
@@ -169,11 +108,9 @@ and returns a new list of goals if successful.
-/
def splitNext : GrindTactic := fun goal => do
let (goals?, _) GoalM.run goal do
let .some c numCases isRec selectNextSplit?
let some c selectNextSplit?
| return none
let gen getGeneration c
let genNew := if numCases > 1 || isRec then gen+1 else gen
markCaseSplitAsResolved c
trace_goal[grind.split] "{c}, generation: {gen}"
let mvarIds if ( isMatcherApp c) then
casesMatch ( get).mvarId c
@@ -182,7 +119,7 @@ def splitNext : GrindTactic := fun goal => do
cases ( get).mvarId major
let goal get
let goals := mvarIds.map fun mvarId => { goal with mvarId }
let goals introNewHyp goals [] genNew
let goals introNewHyp goals [] (gen+1)
return some goals
return goals?

View File

@@ -13,13 +13,17 @@ import Lean.Meta.CongrTheorems
import Lean.Meta.AbstractNestedProofs
import Lean.Meta.Tactic.Simp.Types
import Lean.Meta.Tactic.Util
import Lean.Meta.Tactic.Grind.ENodeKey
import Lean.Meta.Tactic.Grind.Canon
import Lean.Meta.Tactic.Grind.Attr
import Lean.Meta.Tactic.Grind.Arith.Types
import Lean.Meta.Tactic.Grind.EMatchTheorem
namespace Lean.Meta.Grind
@[inline] def isSameExpr (a b : Expr) : Bool :=
-- It is safe to use pointer equality because we hashcons all expressions
-- inserted into the E-graph
unsafe ptrEq a b
/-- We use this auxiliary constant to mark delayed congruence proofs. -/
def congrPlaceholderProof := mkConst (Name.mkSimple "[congruence]")
@@ -65,6 +69,7 @@ instance : Hashable CongrTheoremCacheKey where
/-- State for the `GrindM` monad. -/
structure State where
canon : Canon.State := {}
/-- `ShareCommon` (aka `Hashconsing`) state. -/
scState : ShareCommon.State.{0} ShareCommon.objectFactory := ShareCommon.State.mk _
/-- Next index for creating auxiliary theorems. -/
@@ -78,7 +83,6 @@ structure State where
simpStats : Simp.Stats := {}
trueExpr : Expr
falseExpr : Expr
natZExpr : Expr
/--
Used to generate trace messages of the for `[grind] working on <tag>`,
and implement the macro `trace_goal`.
@@ -103,10 +107,6 @@ def getTrueExpr : GrindM Expr := do
def getFalseExpr : GrindM Expr := do
return ( get).falseExpr
/-- Returns the internalized `0 : Nat` numeral. -/
def getNatZeroExpr : GrindM Expr := do
return ( get).natZExpr
def getMainDeclName : GrindM Name :=
return ( readThe Context).mainDeclName
@@ -131,9 +131,18 @@ Applies hash-consing to `e`. Recall that all expressions in a `grind` goal have
been hash-consed. We perform this step before we internalize expressions.
-/
def shareCommon (e : Expr) : GrindM Expr := do
modifyGet fun { scState, nextThmIdx, congrThms, trueExpr, falseExpr, natZExpr, simpStats, lastTag } =>
modifyGet fun { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr, simpStats, lastTag } =>
let (e, scState) := ShareCommon.State.shareCommon scState e
(e, { scState, nextThmIdx, congrThms, trueExpr, falseExpr, natZExpr, simpStats, lastTag })
(e, { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr, simpStats, lastTag })
/--
Canonicalizes nested types, type formers, and instances in `e`.
-/
def canon (e : Expr) : GrindM Expr := do
let canonS modifyGet fun s => (s.canon, { s with canon := {} })
let (e, canonS) Canon.canon e |>.run canonS
modify fun s => { s with canon := canonS }
return e
/-- Returns `true` if `e` is the internalized `True` expression. -/
def isTrueExpr (e : Expr) : GrindM Bool :=
@@ -196,19 +205,13 @@ structure ENode where
on heterogeneous equality.
-/
heqProofs : Bool := false
/-- Unique index used for pretty printing and debugging purposes. -/
/--
Unique index used for pretty printing and debugging purposes.
-/
idx : Nat := 0
/-- The generation in which this enode was created. -/
generation : Nat := 0
/-- Modification time -/
mt : Nat := 0
/--
The `offset?` field is used to propagate equalities from the `grind` congruence closure module
to the offset constraints module. When `grind` merges two equivalence classes, and both have
an associated `offset?` set to `some e`, the equality is propagated. This field is
assigned during the internalization of offset terms.
-/
offset? : Option Expr := none
deriving Inhabited, Repr
def ENode.isCongrRoot (n : ENode) :=
@@ -221,6 +224,20 @@ structure NewEq where
proof : Expr
isHEq : Bool
/--
Key for the `ENodeMap` and `ParentMap` map.
We use pointer addresses and rely on the fact all internalized expressions
have been hash-consed, i.e., we have applied `shareCommon`.
-/
private structure ENodeKey where
expr : Expr
instance : Hashable ENodeKey where
hash k := unsafe (ptrAddrUnsafe k.expr).toUInt64
instance : BEq ENodeKey where
beq k₁ k₂ := isSameExpr k₁.expr k₂.expr
abbrev ENodeMap := PHashMap ENodeKey ENode
/--
@@ -332,16 +349,8 @@ structure NewFact where
generation : Nat
deriving Inhabited
/-- Canonicalizer state. See `Canon.lean` for additional details. -/
structure Canon.State where
argMap : PHashMap (Expr × Nat) (List Expr) := {}
canon : PHashMap Expr Expr := {}
proofCanon : PHashMap Expr Expr := {}
deriving Inhabited
structure Goal where
mvarId : MVarId
canon : Canon.State := {}
enodes : ENodeMap := {}
parents : ParentMap := {}
congrTable : CongrTable enodes := {}
@@ -359,8 +368,6 @@ structure Goal where
gmt : Nat := 0
/-- Next unique index for creating ENodes -/
nextIdx : Nat := 0
/-- State of arithmetic procedures -/
arith : Arith.State := {}
/-- Active theorems that we have performed ematching at least once. -/
thms : PArray EMatchTheorem := {}
/-- Active theorems that we have not performed any round of ematching yet. -/
@@ -384,17 +391,10 @@ structure Goal where
splitCandidates : List Expr := []
/-- Number of splits performed to get to this goal. -/
numSplits : Nat := 0
/-- Case-splits that have already been performed, or that do not have to be performed anymore. -/
/-- Case-splits that do not have to be performed anymore. -/
resolvedSplits : PHashSet ENodeKey := {}
/-- Next local E-match theorem idx. -/
nextThmIdx : Nat := 0
/-- Asserted facts -/
facts : PArray Expr := {}
/--
Issues found during the proof search in this goal. This issues are reported to
users when `grind` fails.
-/
issues : List MessageData := []
deriving Inhabited
def Goal.admit (goal : Goal) : MetaM Unit :=
@@ -415,20 +415,6 @@ def updateLastTag : GoalM Unit := do
trace[grind] "working on goal `{currTag}`"
modifyThe Grind.State fun s => { s with lastTag := currTag }
def Goal.reportIssue (goal : Goal) (msg : MessageData) : MetaM Goal := do
let msg addMessageContext msg
let goal := { goal with issues := .trace { cls := `issue } msg #[] :: goal.issues }
/-
We also add a trace message because we may want to know when
an issue happened relative to other trace messages.
-/
trace[grind.issues] msg
return goal
def reportIssue (msg : MessageData) : GoalM Unit := do
let goal ( get).reportIssue msg
set goal
/--
Macro similar to `trace[...]`, but it includes the trace message `trace[grind] "working on <current goal>"`
if the tag has changed since the last trace message.
@@ -477,25 +463,14 @@ def checkMaxEmatchExceeded : GoalM Bool := do
Returns `some n` if `e` has already been "internalized" into the
Otherwise, returns `none`s.
-/
def Goal.getENode? (goal : Goal) (e : Expr) : Option ENode :=
goal.enodes.find? { expr := e }
@[inline, inherit_doc Goal.getENode?]
def getENode? (e : Expr) : GoalM (Option ENode) :=
return ( get).getENode? e
def throwNonInternalizedExpr (e : Expr) : CoreM α :=
throwError "internal `grind` error, term has not been internalized{indentExpr e}"
return ( get).enodes.find? { expr := e }
/-- Returns node associated with `e`. It assumes `e` has already been internalized. -/
def Goal.getENode (goal : Goal) (e : Expr) : CoreM ENode := do
let some n := goal.enodes.find? { expr := e }
| throwNonInternalizedExpr e
return n
@[inline, inherit_doc Goal.getENode]
def getENode (e : Expr) : GoalM ENode := do
( get).getENode e
let some n := ( get).enodes.find? { expr := e }
| throwError "internal `grind` error, term has not been internalized{indentExpr e}"
return n
/-- Returns the generation of the given term. Is assumes it has been internalized -/
def getGeneration (e : Expr) : GoalM Nat :=
@@ -526,53 +501,30 @@ def isRoot (e : Expr) : GoalM Bool := do
return isSameExpr n.root e
/-- Returns the root element in the equivalence class of `e` IF `e` has been internalized. -/
def Goal.getRoot? (goal : Goal) (e : Expr) : Option Expr := Id.run do
let some n goal.getENode? e | return none
def getRoot? (e : Expr) : GoalM (Option Expr) := do
let some n getENode? e | return none
return some n.root
@[inline, inherit_doc Goal.getRoot?]
def getRoot? (e : Expr) : GoalM (Option Expr) := do
return ( get).getRoot? e
/-- Returns the root element in the equivalence class of `e`. -/
def Goal.getRoot (goal : Goal) (e : Expr) : CoreM Expr :=
return ( goal.getENode e).root
@[inline, inherit_doc Goal.getRoot]
def getRoot (e : Expr) : GoalM Expr := do
( get).getRoot e
def getRoot (e : Expr) : GoalM Expr :=
return ( getENode e).root
/-- Returns the root enode in the equivalence class of `e`. -/
def getRootENode (e : Expr) : GoalM ENode := do
getENode ( getRoot e)
/--
Returns the next element in the equivalence class of `e`
if `e` has been internalized in the given goal.
-/
def Goal.getNext? (goal : Goal) (e : Expr) : Option Expr := Id.run do
let some n goal.getENode? e | return none
return some n.next
/-- Returns the next element in the equivalence class of `e`. -/
def Goal.getNext (goal : Goal) (e : Expr) : CoreM Expr :=
return ( goal.getENode e).next
@[inline, inherit_doc Goal.getRoot]
def getNext (e : Expr) : GoalM Expr := do
( get).getNext e
def getNext (e : Expr) : GoalM Expr :=
return ( getENode e).next
/-- Returns `true` if `e` has already been internalized. -/
def alreadyInternalized (e : Expr) : GoalM Bool :=
return ( get).enodes.contains { expr := e }
def Goal.getTarget? (goal : Goal) (e : Expr) : Option Expr := Id.run do
let some n goal.getENode? e | return none
def getTarget? (e : Expr) : GoalM (Option Expr) := do
let some n getENode? e | return none
return n.target?
@[inline] def getTarget? (e : Expr) : GoalM (Option Expr) := do
return ( get).getTarget? e
/--
If `isHEq` is `false`, it pushes `lhs = rhs` with `proof` to `newEqs`.
Otherwise, it pushes `HEq lhs rhs`.
@@ -670,41 +622,6 @@ def mkENode (e : Expr) (generation : Nat) : GoalM Unit := do
let interpreted isInterpreted e
mkENodeCore e interpreted ctor generation
/--
Notify the offset constraint module that `a = b` where
`a` and `b` are terms that have been internalized by this module.
-/
@[extern "lean_process_new_offset_eq"] -- forward definition
opaque Arith.processNewOffsetEq (a b : Expr) : GoalM Unit
/--
Notify the offset constraint module that `a = k` where
`a` is term that has been internalized by this module,
and `k` is a numeral.
-/
@[extern "lean_process_new_offset_eq_lit"] -- forward definition
opaque Arith.processNewOffsetEqLit (a k : Expr) : GoalM Unit
/-- Returns `true` if `e` is a numeral and has type `Nat`. -/
def isNatNum (e : Expr) : Bool := Id.run do
let_expr OfNat.ofNat _ _ inst := e | false
let_expr instOfNatNat _ := inst | false
true
/--
Marks `e` as a term of interest to the offset constraint module.
If the root of `e`s equivalence class has already a term of interest,
a new equality is propagated to the offset module.
-/
def markAsOffsetTerm (e : Expr) : GoalM Unit := do
let root getRootENode e
if let some e' := root.offset? then
Arith.processNewOffsetEq e e'
else if isNatNum root.self && !isSameExpr e root.self then
Arith.processNewOffsetEqLit e root.self
else
setENode root.self { root with offset? := some e }
/-- Returns `true` is `e` is the root of its congruence class. -/
def isCongrRoot (e : Expr) : GoalM Bool := do
return ( getENode e).isCongrRoot
@@ -779,23 +696,11 @@ def closeGoal (falseProof : Expr) : GoalM Unit := do
else
mvarId.assign ( mkFalseElim target falseProof)
def Goal.getENodes (goal : Goal) : Array ENode :=
-- We must sort because we are using pointer addresses as keys in `enodes`
let nodes := goal.enodes.toArray.map (·.2)
nodes.qsort fun a b => a.idx < b.idx
/-- Returns all enodes in the goal -/
def getENodes : GoalM (Array ENode) := do
return ( get).getENodes
/-- Executes `f` to each term in the equivalence class containing `e` -/
@[inline] def traverseEqc (e : Expr) (f : ENode GoalM Unit) : GoalM Unit := do
let mut curr := e
repeat
let n getENode curr
f n
if isSameExpr n.next e then return ()
curr := n.next
-- We must sort because we are using pointer addresses as keys in `enodes`
let nodes := ( get).enodes.toArray.map (·.2)
return nodes.qsort fun a b => a.idx < b.idx
def forEachENode (f : ENode GoalM Unit) : GoalM Unit := do
let nodes getENodes
@@ -809,7 +714,7 @@ def filterENodes (p : ENode → GoalM Bool) : GoalM (Array ENode) := do
ref.modify (·.push n)
ref.get
def forEachEqcRoot (f : ENode GoalM Unit) : GoalM Unit := do
def forEachEqc (f : ENode GoalM Unit) : GoalM Unit := do
let nodes getENodes
for n in nodes do
if isSameExpr n.self n.root then
@@ -844,42 +749,33 @@ def applyFallback : GoalM Unit := do
fallback
/-- Returns expressions in the given expression equivalence class. -/
partial def Goal.getEqc (goal : Goal) (e : Expr) : List Expr :=
partial def getEqc (e : Expr) : GoalM (List Expr) :=
go e e []
where
go (first : Expr) (e : Expr) (acc : List Expr) : List Expr := Id.run do
let some next goal.getNext? e | acc
go (first : Expr) (e : Expr) (acc : List Expr) : GoalM (List Expr) := do
let next getNext e
let acc := e :: acc
if isSameExpr first next then
return acc
else
go first next acc
@[inline, inherit_doc Goal.getEqc]
partial def getEqc (e : Expr) : GoalM (List Expr) :=
return ( get).getEqc e
/-- Returns all equivalence classes in the current goal. -/
partial def Goal.getEqcs (goal : Goal) : List (List Expr) := Id.run do
let mut r : List (List Expr) := []
let nodes goal.getENodes
partial def getEqcs : GoalM (List (List Expr)) := do
let mut r := []
let nodes getENodes
for node in nodes do
if isSameExpr node.root node.self then
r := goal.getEqc node.self :: r
r := ( getEqc node.self) :: r
return r
@[inline, inherit_doc Goal.getEqcs]
def getEqcs : GoalM (List (List Expr)) :=
return ( get).getEqcs
/-- Returns `true` if `e` is a case-split that does not need to be performed anymore. -/
def isResolvedCaseSplit (e : Expr) : GoalM Bool :=
return ( get).resolvedSplits.contains { expr := e }
/--
Mark `e` as a case-split that does not need to be performed anymore.
Remark: we currently use this feature to disable `match`-case-splits.
Remark: we also use this feature to record the case-splits that have already been performed.
Remark: we currently use this feature to disable `match`-case-splits
-/
def markCaseSplitAsResolved (e : Expr) : GoalM Unit := do
unless ( isResolvedCaseSplit e) do

View File

@@ -50,24 +50,18 @@ def simpCnstr? (e : Expr) : MetaM (Option (Expr × Expr)) := do
if let some arg := e.not? then
let mut eNew? := none
let mut thmName := Name.anonymous
match_expr arg with
| LE.le α _ _ _ =>
if α.isConstOf ``Nat then
eNew? := some ( mkLE ( mkAdd (arg.getArg! 3) (mkNatLit 1)) (arg.getArg! 2))
thmName := ``Nat.not_le_eq
| GE.ge α _ _ _ =>
if α.isConstOf ``Nat then
eNew? := some ( mkLE ( mkAdd (arg.getArg! 2) (mkNatLit 1)) (arg.getArg! 3))
thmName := ``Nat.not_ge_eq
| LT.lt α _ _ _ =>
if α.isConstOf ``Nat then
eNew? := some ( mkLE (arg.getArg! 3) (arg.getArg! 2))
thmName := ``Nat.not_lt_eq
| GT.gt α _ _ _ =>
if α.isConstOf ``Nat then
eNew? := some ( mkLE (arg.getArg! 2) (arg.getArg! 3))
thmName := ``Nat.not_gt_eq
| _ => pure ()
if arg.isAppOfArity ``LE.le 4 then
eNew? := some ( mkLE ( mkAdd (arg.getArg! 3) (mkNatLit 1)) (arg.getArg! 2))
thmName := ``Nat.not_le_eq
else if arg.isAppOfArity ``GE.ge 4 then
eNew? := some ( mkLE ( mkAdd (arg.getArg! 2) (mkNatLit 1)) (arg.getArg! 3))
thmName := ``Nat.not_ge_eq
else if arg.isAppOfArity ``LT.lt 4 then
eNew? := some ( mkLE (arg.getArg! 3) (arg.getArg! 2))
thmName := ``Nat.not_lt_eq
else if arg.isAppOfArity ``GT.gt 4 then
eNew? := some ( mkLE (arg.getArg! 2) (arg.getArg! 3))
thmName := ``Nat.not_gt_eq
if let some eNew := eNew? then
let h₁ := mkApp2 (mkConst thmName) (arg.getArg! 2) (arg.getArg! 3)
if let some (eNew', h₂) simpCnstrPos? eNew then

View File

@@ -1583,8 +1583,8 @@ namespace TokenMap
def insert (map : TokenMap α) (k : Name) (v : α) : TokenMap α :=
match map.find? k with
| none => RBMap.insert map k [v]
| some vs => RBMap.insert map k (v::vs)
| none => .insert map k [v]
| some vs => .insert map k (v::vs)
instance : Inhabited (TokenMap α) where
default := RBMap.empty

View File

@@ -103,8 +103,11 @@ partial def compileParserExpr (e : Expr) : MetaM Expr := do
name := c', levelParams := []
type := ty, value := value, hints := ReducibilityHints.opaque, safety := DefinitionSafety.safe
}
addAndCompile decl
modifyEnv (ctx.combinatorAttr.setDeclFor · c c')
let env getEnv
let env match env.addAndCompile {} decl with
| Except.ok env => pure env
| Except.error kex => do throwError ( (kex.toMessageData {}).toString)
setEnv <| ctx.combinatorAttr.setDeclFor env c c'
if cinfo.type.isConst then
if let some kind parserNodeKind? cinfo.value! then
-- If the parser is parameter-less and produces a node of kind `kind`,

View File

@@ -419,10 +419,10 @@ mutual
|| (getPPAnalyzeTrustSubtypeMk ( getOptions) && ( getExpr).isAppOfArity ``Subtype.mk 4)
analyzeAppStagedCore { f, fType, args, mvars, bInfos, forceRegularApp } |>.run' {
bottomUps := Array.replicate args.size false,
higherOrders := Array.replicate args.size false,
provideds := Array.replicate args.size false,
funBinders := Array.replicate args.size false
bottomUps := mkArray args.size false,
higherOrders := mkArray args.size false,
provideds := mkArray args.size false,
funBinders := mkArray args.size false
}
if !rest.isEmpty then

View File

@@ -97,7 +97,7 @@ abbrev RequestT m := ReaderT RequestContext <| ExceptT RequestError m
/-- Workers execute request handlers in this monad. -/
abbrev RequestM := ReaderT RequestContext <| EIO RequestError
abbrev RequestTask.pure (a : α) : RequestTask α := Task.pure (.ok a)
abbrev RequestTask.pure (a : α) : RequestTask α := .pure (.ok a)
instance : MonadLift IO RequestM where
monadLift x := do

View File

@@ -495,7 +495,7 @@ def getCanonicalAntiquot (stx : Syntax) : Syntax :=
stx
def mkAntiquotNode (kind : Name) (term : Syntax) (nesting := 0) (name : Option String := none) (isPseudoKind := false) : Syntax :=
let nesting := mkNullNode (Array.replicate nesting (mkAtom "$"))
let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
let term :=
if term.isIdent then term
else if term.isOfKind `Lean.Parser.Term.hole then term[0]
@@ -558,7 +558,7 @@ def getAntiquotSpliceSuffix (stx : Syntax) : Syntax :=
stx[1]
def mkAntiquotSpliceNode (kind : SyntaxNodeKind) (contents : Array Syntax) (suffix : String) (nesting := 0) : Syntax :=
let nesting := mkNullNode (Array.replicate nesting (mkAtom "$"))
let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
mkNode (kind ++ `antiquot_splice) #[mkAtom "$", nesting, mkAtom "[", mkNullNode contents, mkAtom "]", mkAtom suffix]
-- `$x,*` etc.

View File

@@ -31,7 +31,7 @@ structure State where
checked : Std.HashSet Expr
unsafe def initCache : State := {
visited := Array.replicate cacheSize.toNat (cast lcProof ())
visited := mkArray cacheSize.toNat (cast lcProof ())
checked := {}
}

View File

@@ -104,26 +104,17 @@ def initSearchPath (leanSysroot : FilePath) (sp : SearchPath := ∅) : IO Unit :
private def initSearchPathInternal : IO Unit := do
initSearchPath ( getBuildDir)
/-- Find the compiled `.olean` of a module in the `LEAN_PATH` search path. -/
partial def findOLean (mod : Name) : IO FilePath := do
let sp searchPathRef.get
if let some fname sp.findWithExt "olean" mod then
return fname
else
let pkg := FilePath.mk <| mod.getRoot.toString (escape := false)
throw <| IO.userError s!"unknown module prefix '{pkg}'\n\n\
No directory '{pkg}' or file '{pkg}.olean' in the search path entries:\n\
{"\n".intercalate <| sp.map (·.toString)}"
let mut msg := s!"unknown module prefix '{pkg}'
/-- Find the `.lean` source of a module in a `LEAN_SRC_PATH` search path. -/
partial def findLean (sp : SearchPath) (mod : Name) : IO FilePath := do
if let some fname sp.findWithExt "lean" mod then
return fname
else
let pkg := FilePath.mk <| mod.getRoot.toString (escape := false)
throw <| IO.userError s!"unknown module prefix '{pkg}'\n\n\
No directory '{pkg}' or file '{pkg}.lean' in the search path entries:\n\
{"\n".intercalate <| sp.map (·.toString)}"
No directory '{pkg}' or file '{pkg}.olean' in the search path entries:
{"\n".intercalate <| sp.map (·.toString)}"
throw <| IO.userError msg
/-- Infer module name of source file name. -/
@[export lean_module_name_of_file]

Some files were not shown because too many files have changed in this diff Show More