fix: allow projections in E-matching patterns

This PR ensures that users can utilize projections in E-matching
patterns within the `grind` tactic.

doc/dev/release_checklist.md

@@ -5,11 +5,6 @@ See below for the checklist for release candidates.
 
 We'll use `v4.6.0` as the intended release version as a running example.
 
-- One week before the planned release, ensure that
-  (1) someone has written the release notes and
-  (2) someone has written the first draft of the release blog post.
-  If there is any material in `./releases_drafts/` on the `releases/v4.6.0` branch, then the release notes are not done.
-  (See the section "Writing the release notes".)
 - `git checkout releases/v4.6.0`
   (This branch should already exist, from the release candidates.)
 - `git pull`
@@ -81,12 +76,16 @@ We'll use `v4.6.0` as the intended release version as a running example.
       - Toolchain bump PR including updated Lake manifest
       - Create and push the tag
       - There is no `stable` branch; skip this step
+    - [plausible](https://github.com/leanprover-community/plausible)
+      - Toolchain bump PR including updated Lake manifest
+      - Create and push the tag
+      - There is no `stable` branch; skip this step
     - [Mathlib](https://github.com/leanprover-community/mathlib4)
       - Dependencies: `Aesop`, `ProofWidgets4`, `lean4checker`, `Batteries`, `doc-gen4`, `import-graph`
       - Toolchain bump PR notes:
         - In addition to updating the `lean-toolchain` and `lakefile.lean`,
           in `.github/workflows/lean4checker.yml` update the line
-          `git checkout v4.6.0` to the appropriate tag. 
+          `git checkout v4.6.0` to the appropriate tag.
         - Push the PR branch to the main Mathlib repository rather than a fork, or CI may not work reliably
         - Create and push the tag
         - Create a new branch from the tag, push it, and open a pull request against `stable`.
@@ -139,16 +138,13 @@ We'll use `v4.7.0-rc1` as the intended release version in this example.
     git checkout -b releases/v4.7.0
     ```
 - In `RELEASES.md` replace `Development in progress` in the `v4.7.0` section with `Release notes to be written.`
-- We will rely on automatically generated release notes for release candidates,
-  and the written release notes will be used for stable versions only.
-  It is essential to choose the nightly that will become the release candidate as early as possible, to avoid confusion.
+- It is essential to choose the nightly that will become the release candidate as early as possible, to avoid confusion.
 - In `src/CMakeLists.txt`,
   - verify that you see `set(LEAN_VERSION_MINOR 7)` (for whichever `7` is appropriate); this should already have been updated when the development cycle began.
   - `set(LEAN_VERSION_IS_RELEASE 1)` (this should be a change; on `master` and nightly releases it is always `0`).
   - Commit your changes to `src/CMakeLists.txt`, and push.
 - `git tag v4.7.0-rc1`
 - `git push origin v4.7.0-rc1`
-- Ping the FRO Zulip that release notes need to be written. The release notes do not block completing the rest of this checklist.
 - Now wait, while CI runs.
   - You can monitor this at `https://github.com/leanprover/lean4/actions/workflows/ci.yml`, looking for the `v4.7.0-rc1` tag.
   - This step can take up to an hour.
@@ -248,15 +244,12 @@ Please read https://leanprover-community.github.io/contribute/tags_and_branches.
 
 # Writing the release notes
 
-We are currently trying a system where release notes are compiled all at once from someone looking through the commit history.
-The exact steps are a work in progress.
-Here is the general idea:
+Release notes are automatically generated from the commit history, using `script/release_notes.py`.
 
-* The work is done right on the `releases/v4.6.0` branch sometime after it is created but before the stable release is made.
-  The release notes for `v4.6.0` will later be copied to `master` when we begin a new development cycle.
-* There can be material for release notes entries in commit messages.
-* There can also be pre-written entries in `./releases_drafts`, which should be all incorporated in the release notes and then deleted from the branch.
+Run this as `script/release_notes.py v4.6.0`, where `v4.6.0` is the *previous* release version. This will generate output
+for all commits since that tag. Note that there is output on both stderr, which should be manually reviewed,
+and on stdout, which should be manually copied to `RELEASES.md`.
+
+There can also be pre-written entries in `./releases_drafts`, which should be all incorporated in the release notes and then deleted from the branch.
   See `./releases_drafts/README.md` for more information.
-* The release notes should be written from a downstream expert user's point of view.
 
-This section will be updated when the next release notes are written (for `v4.10.0`).

releases_drafts/list_lex.md

@@ -1,16 +0,0 @@
-We replace the inductive predicate `List.lt` with an upstreamed version of `List.Lex` from Mathlib.
-(Previously `Lex.lt` was defined in terms of `<`; now it is generalized to take an arbitrary relation.)
-This subtely changes the notion of ordering on `List α`.
-
-`List.lt` was a weaker relation: in particular if `l₁ < l₂`, then
-`a :: l₁ < b :: l₂` may hold according to `List.lt` even if `a` and `b` are merely incomparable
-(either neither `a < b` nor `b < a`), whereas according to `List.Lex` this would require `a = b`.
-
-When `<` is total, in the sense that `¬ · < ·` is antisymmetric, then the two relations coincide.
-
-Mathlib was already overriding the order instances for `List α`,
-so this change should not be noticed by anyone already using Mathlib.
-
-We simultaneously add the boolean valued `List.lex` function, parameterised by a `BEq` typeclass
-and an arbitrary `lt` function. This will support the flexibility previously provided for `List.lt`,
-via a `==` function which is weaker than strict equality.

script/release_notes.py

@@ -0,0 +1,145 @@
+#!/usr/bin/env python3
+
+import sys
+import re
+import json
+import requests
+import subprocess
+from collections import defaultdict
+from git import Repo
+
+def get_commits_since_tag(repo, tag):
+    try:
+        tag_commit = repo.commit(tag)
+        commits = list(repo.iter_commits(f"{tag_commit.hexsha}..HEAD"))
+        return [
+            (commit.hexsha, commit.message.splitlines()[0], commit.message)
+            for commit in commits
+        ]
+    except Exception as e:
+        sys.stderr.write(f"Error retrieving commits: {e}\n")
+        sys.exit(1)
+
+def check_pr_number(first_line):
+    match = re.search(r"\(\#(\d+)\)$", first_line)
+    if match:
+        return int(match.group(1))
+    return None
+
+def fetch_pr_labels(pr_number):
+    try:
+        # Use gh CLI to fetch PR details
+        result = subprocess.run([
+            "gh", "api", f"repos/leanprover/lean4/pulls/{pr_number}"
+        ], capture_output=True, text=True, check=True)
+        pr_data = result.stdout
+        pr_json = json.loads(pr_data)
+        return [label["name"] for label in pr_json.get("labels", [])]
+    except subprocess.CalledProcessError as e:
+        sys.stderr.write(f"Failed to fetch PR #{pr_number} using gh: {e.stderr}\n")
+        return []
+
+def format_section_title(label):
+    title = label.replace("changelog-", "").capitalize()
+    if title == "Doc":
+        return "Documentation"
+    elif title == "Pp":
+        return "Pretty Printing"
+    return title
+
+def sort_sections_order():
+    return [
+        "Language",
+        "Library",
+        "Compiler",
+        "Pretty Printing",
+        "Documentation",
+        "Server",
+        "Lake",
+        "Other",
+        "Uncategorised"
+    ]
+
+def format_markdown_description(pr_number, description):
+    link = f"[#{pr_number}](https://github.com/leanprover/lean4/pull/{pr_number})"
+    return f"{link} {description}"
+
+def main():
+    if len(sys.argv) != 2:
+        sys.stderr.write("Usage: script.py <git-tag>\n")
+        sys.exit(1)
+
+    tag = sys.argv[1]
+    try:
+        repo = Repo(".")
+    except Exception as e:
+        sys.stderr.write(f"Error opening Git repository: {e}\n")
+        sys.exit(1)
+
+    commits = get_commits_since_tag(repo, tag)
+
+    sys.stderr.write(f"Found {len(commits)} commits since tag {tag}:\n")
+    for commit_hash, first_line, _ in commits:
+        sys.stderr.write(f"- {commit_hash}: {first_line}\n")
+
+    changelog = defaultdict(list)
+
+    for commit_hash, first_line, full_message in commits:
+        # Skip commits with the specific first lines
+        if first_line == "chore: update stage0" or first_line.startswith("chore: CI: bump "):
+            continue
+
+        pr_number = check_pr_number(first_line)
+
+        if not pr_number:
+            sys.stderr.write(f"No PR number found in {first_line}\n")
+            continue
+
+        # Remove the first line from the full_message for further processing
+        body = full_message[len(first_line):].strip()
+
+        paragraphs = body.split('\n\n')
+        second_paragraph = paragraphs[0] if len(paragraphs) > 0 else ""
+
+        labels = fetch_pr_labels(pr_number)
+
+        # Skip entries with the "changelog-no" label
+        if "changelog-no" in labels:
+            continue
+
+        report_errors = first_line.startswith("feat:") or first_line.startswith("fix:")
+
+        if not second_paragraph.startswith("This PR "):
+            if report_errors:
+                sys.stderr.write(f"No PR description found in commit:\n{commit_hash}\n{first_line}\n{body}\n\n")
+                fallback_description = re.sub(r":$", "", first_line.split(" ", 1)[1]).rsplit(" (#", 1)[0]
+                markdown_description = format_markdown_description(pr_number, fallback_description)
+            else:
+                continue
+        else:
+            markdown_description = format_markdown_description(pr_number, second_paragraph.replace("This PR ", ""))
+
+        changelog_labels = [label for label in labels if label.startswith("changelog-")]
+        if len(changelog_labels) > 1:
+            sys.stderr.write(f"Warning: Multiple changelog-* labels found for PR #{pr_number}: {changelog_labels}\n")
+
+        if not changelog_labels:
+            if report_errors:
+                sys.stderr.write(f"Warning: No changelog-* label found for PR #{pr_number}\n")
+            else:
+                continue
+
+        for label in changelog_labels:
+            changelog[label].append((pr_number, markdown_description))
+
+    section_order = sort_sections_order()
+    sorted_changelog = sorted(changelog.items(), key=lambda item: section_order.index(format_section_title(item[0])) if format_section_title(item[0]) in section_order else len(section_order))
+
+    for label, entries in sorted_changelog:
+        section_title = format_section_title(label) if label != "Uncategorised" else "Uncategorised"
+        print(f"## {section_title}\n")
+        for _, entry in sorted(entries, key=lambda x: x[0]):
+            print(f"* {entry}\n")
+
+if __name__ == "__main__":
+    main()

src/Init.lean

@@ -37,3 +37,4 @@ import Init.MacroTrace
 import Init.Grind
 import Init.While
 import Init.Syntax
+import Init.Internal

src/Init/Data/Array/Lemmas.lean

@@ -954,13 +954,18 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
     rw [Bool.eq_iff_iff]
     simp +contextual
 
+private theorem beq_of_beq_singleton [BEq α] {a b : α} : #[a] == #[b] → a == b := by
+  intro h
+  have : isEqv #[a] #[b] BEq.beq = true := h
+  simp [isEqv, isEqvAux] at this
+  assumption
+
 @[simp] theorem reflBEq_iff [BEq α] : ReflBEq (Array α) ↔ ReflBEq α := by
   constructor
   · intro h
     constructor
     intro a
-    suffices (#[a] == #[a]) = true by
-      simpa only [instBEq, isEqv, isEqvAux, Bool.and_true]
+    apply beq_of_beq_singleton
     simp
   · intro h
     constructor
@@ -973,11 +978,9 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
     · intro a b h
       apply singleton_inj.1
       apply eq_of_beq
-      simp only [instBEq, isEqv, isEqvAux]
-      simpa
+      simpa [instBEq, isEqv, isEqvAux]
     · intro a
-      suffices (#[a] == #[a]) = true by
-        simpa only [instBEq, isEqv, isEqvAux, Bool.and_true]
+      apply beq_of_beq_singleton
       simp
   · intro h
     constructor

src/Init/Data/Int/DivModLemmas.lean

@@ -1098,6 +1098,32 @@ theorem bmod_def (x : Int) (m : Nat) : bmod x m =
     (x % m) - m :=
   rfl
 
+theorem bdiv_add_bmod (x : Int) (m : Nat) : m * bdiv x m + bmod x m = x := by
+  unfold bdiv bmod
+  split
+  · simp_all only [Nat.cast_ofNat_Int, Int.mul_zero, emod_zero, Int.zero_add, Int.sub_zero,
+      ite_self]
+  · dsimp only
+    split
+    · exact ediv_add_emod x m
+    · rw [Int.mul_add, Int.mul_one, Int.add_assoc, Int.add_comm m, Int.sub_add_cancel]
+      exact ediv_add_emod x m
+
+theorem bmod_add_bdiv (x : Int) (m : Nat) : bmod x m + m * bdiv x m = x := by
+  rw [Int.add_comm]; exact bdiv_add_bmod x m
+
+theorem bdiv_add_bmod' (x : Int) (m : Nat) : bdiv x m * m + bmod x m = x := by
+  rw [Int.mul_comm]; exact bdiv_add_bmod x m
+
+theorem bmod_add_bdiv' (x : Int) (m : Nat) : bmod x m + bdiv x m * m = x := by
+  rw [Int.add_comm]; exact bdiv_add_bmod' x m
+
+theorem bmod_eq_self_sub_mul_bdiv (x : Int) (m : Nat) : bmod x m = x - m * bdiv x m := by
+  rw [← Int.add_sub_cancel (bmod x m), bmod_add_bdiv]
+
+theorem bmod_eq_self_sub_bdiv_mul (x : Int) (m : Nat) : bmod x m = x - bdiv x m * m := by
+  rw [← Int.add_sub_cancel (bmod x m), bmod_add_bdiv']
+
 theorem bmod_pos (x : Int) (m : Nat) (p : x % m < (m + 1) / 2) : bmod x m = x % m := by
   simp [bmod_def, p]
 

src/Init/Data/List/Lex.lean

@@ -333,7 +333,7 @@ theorem lex_eq_true_iff_exists [BEq α] (lt : α → α → Bool) :
     cases l₂ with
     | nil => simp [lex]
     | cons b l₂ =>
-      simp only [lex_cons_cons, Bool.or_eq_true, Bool.and_eq_true, ih, isEqv, length_cons]
+      simp [lex_cons_cons, Bool.or_eq_true, Bool.and_eq_true, ih, isEqv, length_cons]
       constructor
       · rintro (hab | ⟨hab, ⟨h₁, h₂⟩ | ⟨i, h₁, h₂, w₁, w₂⟩⟩)
         · exact .inr ⟨0, by simp [hab]⟩
@@ -397,7 +397,7 @@ theorem lex_eq_false_iff_exists [BEq α] [PartialEquivBEq α] (lt : α → α
     cases l₂ with
     | nil => simp [lex]
     | cons b l₂ =>
-      simp only [lex_cons_cons, Bool.or_eq_false_iff, Bool.and_eq_false_imp, ih, isEqv,
+      simp [lex_cons_cons, Bool.or_eq_false_iff, Bool.and_eq_false_imp, ih, isEqv,
         Bool.and_eq_true, length_cons]
       constructor
       · rintro ⟨hab, h⟩

src/Init/Data/List/Perm.lean

@@ -510,4 +510,18 @@ theorem Perm.eraseP (f : α → Bool) {l₁ l₂ : List α}
     refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff ?_).1 H))
     exact fun h h₁ h₂ => h h₂ h₁
 
+theorem perm_insertIdx {α} (x : α) (l : List α) {n} (h : n ≤ l.length) :
+    insertIdx n x l ~ x :: l := by
+  induction l generalizing n with
+  | nil =>
+    cases n with
+    | zero => rfl
+    | succ => cases h
+  | cons _ _ ih =>
+    cases n with
+    | zero => simp [insertIdx]
+    | succ =>
+      simp only [insertIdx, modifyTailIdx]
+      refine .trans (.cons _ (ih (Nat.le_of_succ_le_succ h))) (.swap ..)
+
 end List

src/Init/Data/List/Sort/Lemmas.lean

@@ -253,6 +253,10 @@ theorem merge_perm_append : ∀ {xs ys : List α}, merge xs ys le ~ xs ++ ys
     · exact (merge_perm_append.cons y).trans
         ((Perm.swap x y _).trans (perm_middle.symm.cons x))
 
+theorem Perm.merge (s₁ s₂ : α → α → Bool) (hl : l₁ ~ l₂) (hr : r₁ ~ r₂) :
+    merge l₁ r₁ s₁ ~ merge l₂ r₂ s₂ :=
+  Perm.trans (merge_perm_append ..) <| Perm.trans (Perm.append hl hr) <| Perm.symm (merge_perm_append ..)
+
 /-! ### mergeSort -/
 
 @[simp] theorem mergeSort_nil : [].mergeSort r = [] := by rw [List.mergeSort]

src/Init/Data/List/Zip.lean

@@ -259,7 +259,7 @@ theorem zip_map (f : α → γ) (g : β → δ) :
   | [], _ => rfl
   | _, [] => by simp only [map, zip_nil_right]
   | _ :: _, _ :: _ => by
-    simp only [map, zip_cons_cons, zip_map, Prod.map]; constructor
+    simp only [map, zip_cons_cons, zip_map, Prod.map]; try constructor -- TODO: remove try constructor after update stage0
 
 theorem zip_map_left (f : α → γ) (l₁ : List α) (l₂ : List β) :
     zip (l₁.map f) l₂ = (zip l₁ l₂).map (Prod.map f id) := by rw [← zip_map, map_id]

src/Init/Grind.lean

@@ -8,3 +8,5 @@ import Init.Grind.Norm
 import Init.Grind.Tactics
 import Init.Grind.Lemmas
 import Init.Grind.Cases
+import Init.Grind.Propagator
+import Init.Grind.Util

src/Init/Grind/Lemmas.lean

@@ -5,10 +5,65 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.Core
+import Init.SimpLemmas
+import Init.Classical
+import Init.ByCases
+import Init.Grind.Util
 
 namespace Lean.Grind
 
 theorem intro_with_eq (p p' q : Prop) (he : p = p') (h : p' → q) : p → q :=
   fun hp => h (he.mp hp)
 
+/-! And -/
+
+theorem and_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a ∧ b) = b := by simp [h]
+theorem and_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a ∧ b) = a := by simp [h]
+theorem and_eq_of_eq_false_left {a b : Prop} (h : a = False) : (a ∧ b) = False := by simp [h]
+theorem and_eq_of_eq_false_right {a b : Prop} (h : b = False) : (a ∧ b) = False := by simp [h]
+
+theorem eq_true_of_and_eq_true_left {a b : Prop} (h : (a ∧ b) = True) : a = True := by simp_all
+theorem eq_true_of_and_eq_true_right {a b : Prop} (h : (a ∧ b) = True) : b = True := by simp_all
+
+/-! Or -/
+
+theorem or_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a ∨ b) = True := by simp [h]
+theorem or_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a ∨ b) = True := by simp [h]
+theorem or_eq_of_eq_false_left {a b : Prop} (h : a = False) : (a ∨ b) = b := by simp [h]
+theorem or_eq_of_eq_false_right {a b : Prop} (h : b = False) : (a ∨ b) = a := by simp [h]
+
+theorem eq_false_of_or_eq_false_left {a b : Prop} (h : (a ∨ b) = False) : a = False := by simp_all
+theorem eq_false_of_or_eq_false_right {a b : Prop} (h : (a ∨ b) = False) : b = False := by simp_all
+
+/-! Not -/
+
+theorem not_eq_of_eq_true {a : Prop} (h : a = True) : (Not a) = False := by simp [h]
+theorem not_eq_of_eq_false {a : Prop} (h : a = False) : (Not a) = True := by simp [h]
+
+theorem eq_false_of_not_eq_true {a : Prop} (h : (Not a) = True) : a = False := by simp_all
+theorem eq_true_of_not_eq_false {a : Prop} (h : (Not a) = False) : a = True := by simp_all
+
+theorem false_of_not_eq_self {a : Prop} (h : (Not a) = a) : False := by
+  by_cases a <;> simp_all
+
+/-! Eq -/
+
+theorem eq_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a = b) = b := by simp [h]
+theorem eq_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a = b) = a := by simp [h]
+
+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₂)]
+
+/-! 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
+  apply propext; apply Iff.intro
+  · intro h'; exact Eq.mp h₂ (h' (of_eq_true h₁))
+  · intro h'; intros; exact Eq.mpr h₂ h'
+
+/-! dite -/
+
+theorem dite_cond_eq_true' {α : Sort u} {c : Prop} {_ : Decidable c} {a : c → α} {b : ¬ c → α} {r : α} (h₁ : c = True) (h₂ : a (of_eq_true h₁) = r) : (dite c a b) = r := by simp [h₁, h₂]
+theorem dite_cond_eq_false' {α : Sort u} {c : Prop} {_ : Decidable c} {a : c → α} {b : ¬ c → α} {r : α} (h₁ : c = False) (h₂ : b (of_eq_false h₁) = r) : (dite c a b) = r := by simp [h₁, h₂]
+
 end Lean.Grind

src/Init/Grind/Norm.lean

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.SimpLemmas
+import Init.PropLemmas
 import Init.Classical
 import Init.ByCases
 
@@ -41,7 +42,7 @@ attribute [grind_norm] not_true
 attribute [grind_norm] not_false_eq_true
 
 -- Implication as a clause
-@[grind_norm] theorem imp_eq (p q : Prop) : (p → q) = (¬ p ∨ q) := by
+@[grind_norm↓] theorem imp_eq (p q : Prop) : (p → q) = (¬ p ∨ q) := by
   by_cases p <;> by_cases q <;> simp [*]
 
 -- And
@@ -58,13 +59,19 @@ attribute [grind_norm] ite_true ite_false
 @[grind_norm↓] theorem not_ite {_ : Decidable p} (q r : Prop) : (¬ite p q r) = ite p (¬q) (¬r) := by
   by_cases p <;> simp [*]
 
+@[grind_norm] theorem ite_true_false {_ : Decidable p} : (ite p True False) = p := by
+  by_cases p <;> simp
+
+@[grind_norm] theorem ite_false_true {_ : Decidable p} : (ite p False True) = ¬p := by
+  by_cases p <;> simp
+
 -- Forall
 @[grind_norm↓] theorem not_forall (p : α → Prop) : (¬∀ x, p x) = ∃ x, ¬p x := by simp
 attribute [grind_norm] forall_and
 
 -- Exists
 @[grind_norm↓] theorem not_exists (p : α → Prop) : (¬∃ x, p x) = ∀ x, ¬p x := by simp
-attribute [grind_norm] exists_const exists_or
+attribute [grind_norm] exists_const exists_or exists_prop exists_and_left exists_and_right
 
 -- Bool cond
 @[grind_norm] theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = ite c a b := by
@@ -107,4 +114,7 @@ attribute [grind_norm] Nat.le_zero_eq
 -- GT GE
 attribute [grind_norm] GT.gt GE.ge
 
+-- Succ
+attribute [grind_norm] Nat.succ_eq_add_one
+
 end Lean.Grind

src/Init/Grind/Propagator.lean

@@ -0,0 +1,27 @@
+/-
+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.Parser
+
+/-- A user-defined propagator for the `grind` tactic. -/
+-- TODO: not implemented yet
+syntax (docComment)? "grind_propagator " (Tactic.simpPre <|> Tactic.simpPost) ident " (" ident ")" " := " term : command
+
+/-- A builtin propagator for the `grind` tactic. -/
+syntax (docComment)? "builtin_grind_propagator " ident (Tactic.simpPre <|> Tactic.simpPost) ident " := " term : command
+
+/-- Auxiliary attribute for builtin `grind` propagators. -/
+syntax (name := grindPropagatorBuiltinAttr) "builtin_grind_propagator" (Tactic.simpPre <|> Tactic.simpPost) ident : attr
+
+macro_rules
+  | `($[$doc?:docComment]? builtin_grind_propagator $propagatorName:ident $direction $op:ident := $body) => do
+    let propagatorType := `Lean.Meta.Grind.Propagator
+    `($[$doc?:docComment]? def $propagatorName:ident : $(mkIdent propagatorType) := $body
+      attribute [builtin_grind_propagator $direction $op] $propagatorName)
+
+end Lean.Parser

src/Init/Grind/Tactics.lean

@@ -12,14 +12,35 @@ The configuration for `grind`.
 Passed to `grind` using, for example, the `grind (config := { eager := true })` syntax.
 -/
 structure Config where
-  /--
-  When `eager` is true (default: `false`), `grind` eagerly splits `if-then-else` and `match`
-  expressions.
-  -/
+  /-- When `eager` is true (default: `false`), `grind` eagerly splits `if-then-else` and `match` expressions during internalization. -/
   eager : Bool := false
+  /-- Maximum number of branches (i.e., case-splits) in the proof search tree. -/
+  splits : Nat := 100
+  /--
+  Maximum number of E-matching (aka heuristic theorem instantiation)
+  in a proof search tree branch.
+  -/
+  ematch : Nat := 5
+  /--
+  Maximum term generation.
+  The input goal terms have generation 0. When we instantiate a theorem using a term from generation `n`,
+  the new terms have generation `n+1`. Thus, this parameter limits the length of an instantiation chain. -/
+  gen : Nat := 5
+  /-- Maximum number of theorem instances generated using E-matching in a proof search tree branch. -/
+  instances : Nat := 1000
+  /-- If `matchEqs` is `true`, `grind` uses `match`-equations as E-matching theorems. -/
+  matchEqs : Bool := true
   deriving Inhabited, BEq
 
+end Lean.Grind
+
+namespace Lean.Parser.Tactic
+
 /-!
 `grind` tactic and related tactics.
 -/
-end Lean.Grind
+
+-- TODO: parameters
+syntax (name := grind) "grind" optConfig ("on_failure " term)? : tactic
+
+end Lean.Parser.Tactic

src/Init/Grind/Util.lean

@@ -0,0 +1,29 @@
+/-
+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.Core
+
+namespace Lean.Grind
+
+/-- A helper gadget for annotating nested proofs in goals. -/
+def nestedProof (p : Prop) (h : p) : p := h
+
+/--
+Gadget for marking terms that should not be normalized by `grind`s simplifier.
+`grind` uses a simproc to implement this feature.
+We use it when adding instances of `match`-equations to prevent them from being simplified to true.
+-/
+def doNotSimp {α : Sort u} (a : α) : α := a
+
+/-- Gadget for representing offsets `t+k` in patterns. -/
+def offset (a b : Nat) : Nat := a + b
+
+set_option pp.proofs true
+
+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

src/Init/Internal.lean

@@ -0,0 +1,13 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Init.Internal.Order
+
+/-!
+This directory is used for components of the standard library that are either considered
+implementation details or not yet ready for public consumption, and that should be available
+without explicit import (in contrast to `Std.Internal`)
+-/

src/Init/Internal/Order.lean

@@ -0,0 +1,8 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Init.Internal.Order.Basic
+import Init.Internal.Order.Tactic

src/Init/Internal/Order/Basic.lean

@@ -0,0 +1,693 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+
+import Init.ByCases
+import Init.RCases
+
+/-!
+This module contains some basic definitions and results from domain theory, intended to be used as
+the underlying construction of the `partial_fixpoint` feature. It is not meant to be used as a
+general purpose library for domain theory, but can be of interest to users who want to extend
+the `partial_fixpoint` machinery (e.g. mark more functions as monotone or register more monads).
+
+This follows the corresponding
+[Isabelle development](https://isabelle.in.tum.de/library/HOL/HOL/Partial_Function.html), as also
+described in [Alexander Krauss: Recursive Definitions of Monadic Functions](https://www21.in.tum.de/~krauss/papers/mrec.pdf).
+-/
+
+universe u v w
+
+namespace Lean.Order
+
+/--
+A partial order is a reflexive, transitive and antisymmetric relation.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class PartialOrder (α : Sort u) where
+  /--
+  A “less-or-equal-to” or “approximates” relation.
+
+  This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+  -/
+  rel : α → α → Prop
+  rel_refl : ∀ {x}, rel x x
+  rel_trans : ∀ {x y z}, rel x y → rel y z → rel x z
+  rel_antisymm : ∀ {x y}, rel x y → rel y x → x = y
+
+@[inherit_doc] scoped infix:50 " ⊑ " => PartialOrder.rel
+
+section PartialOrder
+
+variable {α  : Sort u} [PartialOrder α]
+
+theorem PartialOrder.rel_of_eq {x y : α} (h : x = y) : x ⊑ y := by cases h; apply rel_refl
+
+/--
+A chain is a totally ordered set (representing a set as a predicate).
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def chain (c : α → Prop) : Prop := ∀ x y , c x → c y → x ⊑ y ∨ y ⊑ x
+
+end PartialOrder
+
+section CCPO
+
+/--
+A chain-complete partial order (CCPO) is a partial order where every chain a least upper bound.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class CCPO (α : Sort u) extends PartialOrder α where
+  /--
+  The least upper bound of a chain.
+
+  This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+  -/
+  csup : (α → Prop) → α
+  csup_spec {c : α → Prop} (hc : chain c) : csup c ⊑ x ↔ (∀ y, c y → y ⊑ x)
+
+open PartialOrder CCPO
+
+variable {α  : Sort u} [CCPO α]
+
+theorem csup_le {c : α → Prop} (hchain : chain c) : (∀ y, c y → y ⊑ x) → csup c ⊑ x :=
+  (csup_spec hchain).mpr
+
+theorem le_csup {c : α → Prop} (hchain : chain c) {y : α} (hy : c y) : y ⊑ csup c :=
+  (csup_spec hchain).mp rel_refl y hy
+
+/--
+The bottom element is the least upper bound of the empty chain.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def bot : α := csup (fun _ => False)
+
+scoped notation "⊥" => bot
+
+theorem bot_le (x : α) : ⊥ ⊑ x := by
+  apply csup_le
+  · intro x y hx hy; contradiction
+  · intro x hx; contradiction
+
+end CCPO
+
+section monotone
+
+variable {α : Sort u} [PartialOrder α]
+variable {β : Sort v} [PartialOrder β]
+
+/--
+A function is monotone if if it maps related elements to releated elements.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def monotone (f : α → β) : Prop := ∀ x y, x ⊑ y → f x ⊑ f y
+
+theorem monotone_const (c : β) : monotone (fun (_ : α) => c) :=
+  fun _ _ _ => PartialOrder.rel_refl
+
+theorem monotone_id : monotone (fun (x : α) => x) :=
+  fun _ _ hxy => hxy
+
+theorem monotone_compose
+    {γ : Sort w} [PartialOrder γ]
+    {f : α → β} {g : β → γ}
+    (hf : monotone f) (hg : monotone g) :
+   monotone (fun x => g (f x)) := fun _ _ hxy => hg _ _ (hf _ _ hxy)
+
+end monotone
+
+section admissibility
+
+variable {α : Sort u} [CCPO α]
+
+open PartialOrder CCPO
+
+/--
+A predicate is admissable if it can be transferred from the elements of a chain to the chains least
+upper bound. Such predicates can be used in fixpoint induction.
+
+This definition implies `P ⊥`. Sometimes (e.g. in Isabelle) the empty chain is excluded
+from this definition, and `P ⊥` is a separate condition of the induction predicate.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def admissible (P : α → Prop) :=
+  ∀ (c : α → Prop), chain c → (∀ x, c x → P x) → P (csup c)
+
+theorem admissible_const_true : admissible (fun (_ : α) => True) :=
+  fun _ _ _ => trivial
+
+theorem admissible_and (P Q : α → Prop)
+  (hadm₁ : admissible P) (hadm₂ : admissible Q) : admissible (fun x => P x ∧ Q x) :=
+    fun c hchain h =>
+    ⟨ hadm₁ c hchain fun x hx => (h x hx).1,
+      hadm₂ c hchain fun x hx => (h x hx).2⟩
+
+theorem chain_conj (c P : α → Prop) (hchain : chain c) : chain (fun x => c x ∧ P x) := by
+  intro x y ⟨hcx, _⟩ ⟨hcy, _⟩
+  exact hchain x y hcx hcy
+
+theorem csup_conj (c P : α → Prop) (hchain : chain c) (h : ∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ P y) :
+    csup c = csup (fun x => c x ∧ P x) := by
+  apply rel_antisymm
+  · apply csup_le hchain
+    intro x hcx
+    obtain ⟨y, hcy, hxy, hPy⟩ := h x hcx
+    apply rel_trans hxy; clear x hcx hxy
+    apply le_csup (chain_conj _ _ hchain) ⟨hcy, hPy⟩
+  · apply csup_le (chain_conj _ _ hchain)
+    intro x ⟨hcx, hPx⟩
+    apply le_csup hchain hcx
+
+theorem admissible_or (P Q : α → Prop)
+  (hadm₁ : admissible P) (hadm₂ : admissible Q) : admissible (fun x => P x ∨ Q x) := by
+  intro c hchain h
+  have : (∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ P y) ∨ (∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ Q y) := by
+    open Classical in
+    apply Decidable.or_iff_not_imp_left.mpr
+    intro h'
+    simp only [not_forall, not_imp, not_exists, not_and] at h'
+    obtain ⟨x, hcx, hx⟩ := h'
+    intro y hcy
+    cases hchain x y hcx hcy  with
+    | inl hxy =>
+      refine ⟨y, hcy, rel_refl, ?_⟩
+      cases h y hcy with
+      | inl hPy => exfalso; apply hx y hcy hxy hPy
+      | inr hQy => assumption
+    | inr hyx =>
+      refine ⟨x, hcx, hyx , ?_⟩
+      cases h x hcx with
+      | inl hPx => exfalso; apply hx x hcx rel_refl hPx
+      | inr hQx => assumption
+  cases this with
+  | inl hP =>
+    left
+    rw [csup_conj (h := hP) (hchain := hchain)]
+    apply hadm₁ _ (chain_conj _ _ hchain)
+    intro x ⟨hcx, hPx⟩
+    exact hPx
+  | inr hQ =>
+    right
+    rw [csup_conj (h := hQ) (hchain := hchain)]
+    apply hadm₂ _ (chain_conj _ _ hchain)
+    intro x ⟨hcx, hQx⟩
+    exact hQx
+
+def admissible_pi (P : α → β → Prop)
+  (hadm₁ : ∀ y, admissible (fun x => P x y)) : admissible (fun x => ∀ y, P x y) :=
+    fun c hchain h y => hadm₁ y c hchain fun x hx => h x hx y
+
+end admissibility
+
+section fix
+
+open PartialOrder CCPO
+
+variable {α  : Sort u} [CCPO α]
+
+variable {c : α → Prop} (hchain : chain c)
+
+/--
+The transfinite iteration of a function `f` is a set that is `⊥ ` and is closed under application
+of `f` and `csup`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+inductive iterates (f : α → α) : α → Prop where
+  | step : iterates f x → iterates f (f x)
+  | sup {c : α → Prop} (hc : chain c) (hi : ∀ x, c x → iterates f x) : iterates f (csup c)
+
+theorem chain_iterates {f : α → α} (hf : monotone f) : chain (iterates f) := by
+  intros x y hx hy
+  induction hx generalizing y
+  case step x hx ih =>
+    induction hy
+    case step y hy _ =>
+      cases ih y hy
+      · left; apply hf; assumption
+      · right; apply hf; assumption
+    case sup c hchain hi ih2 =>
+      show f x ⊑ csup c ∨ csup c ⊑ f x
+      by_cases h : ∃ z, c z ∧ f x ⊑ z
+      · left
+        obtain ⟨z, hz, hfz⟩ := h
+        apply rel_trans hfz
+        apply le_csup hchain hz
+      · right
+        apply csup_le hchain _
+        intro z hz
+        rw [not_exists] at h
+        specialize h z
+        rw [not_and] at h
+        specialize h hz
+        cases ih2 z hz
+        next => contradiction
+        next => assumption
+  case sup c hchain hi ih =>
+    show rel (csup c) y ∨ rel y (csup c)
+    by_cases h : ∃ z, c z ∧ rel y z
+    · right
+      obtain ⟨z, hz, hfz⟩ := h
+      apply rel_trans hfz
+      apply le_csup hchain hz
+    · left
+      apply csup_le hchain _
+      intro z hz
+      rw [not_exists] at h
+      specialize h z
+      rw [not_and] at h
+      specialize h hz
+      cases ih z hz y hy
+      next => assumption
+      next => contradiction
+
+theorem rel_f_of_iterates {f : α → α} (hf : monotone f) {x : α} (hx : iterates f x) : x ⊑ f x := by
+  induction hx
+  case step ih =>
+    apply hf
+    assumption
+  case sup c hchain hi ih =>
+    apply csup_le hchain
+    intro y hy
+    apply rel_trans (ih y hy)
+    apply hf
+    apply le_csup hchain hy
+
+set_option linter.unusedVariables false in
+/--
+The least fixpoint of a monotone function is the least upper bound of its transfinite iteration.
+
+The `monotone f` assumption is not strictly necessarily for the definition, but without this the
+definition is not very meaningful and it simplifies applying theorems like `fix_eq` if every use of
+`fix` already has the monotonicty requirement.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def fix (f : α → α) (hmono : monotone f) := csup (iterates f)
+
+/--
+The main fixpoint theorem for fixedpoints of monotone functions in chain-complete partial orders.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+theorem fix_eq {f : α → α} (hf : monotone f) : fix f hf = f (fix f hf) := by
+  apply rel_antisymm
+  · apply rel_f_of_iterates hf
+    apply iterates.sup (chain_iterates hf)
+    exact fun _ h => h
+  · apply le_csup (chain_iterates hf)
+    apply iterates.step
+    apply iterates.sup (chain_iterates hf)
+    intro y hy
+    exact hy
+
+/--
+The fixpoint induction theme: An admissible predicate holds for a least fixpoint if it is preserved
+by the fixpoint's function.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+theorem fix_induct {f : α → α} (hf : monotone f)
+    (motive : α → Prop) (hadm: admissible motive)
+    (h : ∀ x, motive x → motive (f x)) : motive (fix f hf) := by
+  apply hadm _ (chain_iterates hf)
+  intro x hiterates
+  induction hiterates with
+  | @step x hiter ih => apply h x ih
+  | @sup c hchain hiter ih => apply hadm c hchain ih
+
+end fix
+
+section fun_order
+
+open PartialOrder
+
+variable {α : Sort u}
+variable {β : α → Sort v}
+variable {γ : Sort w}
+
+instance instOrderPi [∀ x, PartialOrder (β x)] : PartialOrder (∀ x, β x) where
+  rel f g := ∀ x, f x ⊑ g x
+  rel_refl _ := rel_refl
+  rel_trans hf hg x := rel_trans (hf x) (hg x)
+  rel_antisymm hf hg := funext (fun x => rel_antisymm (hf x) (hg x))
+
+theorem monotone_of_monotone_apply [PartialOrder γ] [∀ x, PartialOrder (β x)] (f : γ → (∀ x, β x))
+  (h : ∀ y, monotone (fun x => f x y)) : monotone f :=
+  fun x y hxy z => h z x y hxy
+
+theorem monotone_apply [PartialOrder γ] [∀ x, PartialOrder (β x)] (a : α) (f : γ → ∀ x, β x)
+    (h : monotone f) :
+    monotone (fun x => f x a) := fun _ _ hfg => h _ _ hfg a
+
+theorem chain_apply [∀ x, PartialOrder (β x)] {c : (∀ x, β x) → Prop} (hc : chain c) (x : α) :
+    chain (fun y => ∃ f, c f ∧ f x = y) := by
+  intro _ _ ⟨f, hf, hfeq⟩ ⟨g, hg, hgeq⟩
+  subst hfeq; subst hgeq
+  cases hc f g hf hg
+  next h => left; apply h x
+  next h => right; apply h x
+
+def fun_csup [∀ x, CCPO (β x)] (c : (∀ x, β x) → Prop) (x : α) :=
+  CCPO.csup (fun y => ∃ f, c f ∧ f x = y)
+
+instance instCCPOPi [∀ x, CCPO (β x)] : CCPO (∀ x, β x) where
+  csup := fun_csup
+  csup_spec := by
+    intro f c hc
+    constructor
+    next =>
+      intro hf g hg x
+      apply rel_trans _ (hf x); clear hf
+      apply le_csup (chain_apply hc x)
+      exact ⟨g, hg, rfl⟩
+    next =>
+      intro h x
+      apply csup_le (chain_apply hc x)
+      intro y ⟨z, hz, hyz⟩
+      subst y
+      apply h z hz
+
+def admissible_apply [∀ x, CCPO (β x)] (P : ∀ x, β x → Prop) (x : α)
+  (hadm : admissible (P x)) : admissible (fun (f : ∀ x, β x) => P x (f x)) := by
+  intro c hchain h
+  apply hadm _ (chain_apply hchain x)
+  rintro _ ⟨f, hcf, rfl⟩
+  apply h _ hcf
+
+def admissible_pi_apply [∀ x, CCPO (β x)] (P : ∀ x, β x → Prop) (hadm : ∀ x, admissible (P x)) :
+    admissible (fun (f : ∀ x, β x) => ∀ x, P x (f x)) := by
+  apply admissible_pi
+  intro
+  apply admissible_apply
+  apply hadm
+
+end fun_order
+
+section monotone_lemmas
+
+theorem monotone_letFun
+    {α : Sort u} {β : Sort v} {γ : Sort w} [PartialOrder α] [PartialOrder β]
+    (v : γ) (k : α → γ → β)
+    (hmono : ∀ y, monotone (fun x => k x y)) :
+  monotone fun (x : α) => letFun v (k x) := hmono v
+
+theorem monotone_ite
+    {α : Sort u} {β : Sort v} [PartialOrder α] [PartialOrder β]
+    (c : Prop) [Decidable c]
+    (k₁ : α → β) (k₂ : α → β)
+    (hmono₁ : monotone k₁) (hmono₂ : monotone k₂) :
+  monotone fun x => if c then k₁ x else k₂ x := by
+    split
+    · apply hmono₁
+    · apply hmono₂
+
+theorem monotone_dite
+    {α : Sort u} {β : Sort v} [PartialOrder α] [PartialOrder β]
+    (c : Prop) [Decidable c]
+    (k₁ : α → c → β) (k₂ : α → ¬ c → β)
+    (hmono₁ : monotone k₁) (hmono₂ : monotone k₂) :
+  monotone fun x => dite c (k₁ x) (k₂ x) := by
+    split
+    · apply monotone_apply _ _ hmono₁
+    · apply monotone_apply _ _ hmono₂
+
+end monotone_lemmas
+
+section pprod_order
+
+open PartialOrder
+
+variable {α : Sort u}
+variable {β : Sort v}
+variable {γ : Sort w}
+
+instance [PartialOrder α] [PartialOrder β] : PartialOrder (α ×' β) where
+  rel a b := a.1 ⊑ b.1 ∧ a.2 ⊑ b.2
+  rel_refl := ⟨rel_refl, rel_refl⟩
+  rel_trans ha hb := ⟨rel_trans ha.1 hb.1, rel_trans ha.2 hb.2⟩
+  rel_antisymm := fun {a} {b} ha hb => by
+    cases a; cases b;
+    dsimp at *
+    rw [rel_antisymm ha.1 hb.1, rel_antisymm ha.2 hb.2]
+
+theorem monotone_pprod [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α} {g : γ → β} (hf : monotone f) (hg : monotone g) :
+    monotone (fun x => PProd.mk (f x) (g x)) :=
+  fun _ _ h12 => ⟨hf _ _ h12, hg _ _ h12⟩
+
+theorem monotone_pprod_fst [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α ×' β} (hf : monotone f) : monotone (fun x => (f x).1) :=
+  fun _ _ h12 => (hf _ _ h12).1
+
+theorem monotone_pprod_snd [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α ×' β} (hf : monotone f) : monotone (fun x => (f x).2) :=
+  fun _ _ h12 => (hf _ _ h12).2
+
+def chain_pprod_fst [CCPO α] [CCPO β] (c : α ×' β → Prop) : α → Prop := fun a => ∃ b, c ⟨a, b⟩
+def chain_pprod_snd [CCPO α] [CCPO β] (c : α ×' β → Prop) : β → Prop := fun b => ∃ a, c ⟨a, b⟩
+
+theorem chain.pprod_fst [CCPO α] [CCPO β] (c : α ×' β → Prop) (hchain : chain c) :
+    chain (chain_pprod_fst c) := by
+  intro a₁ a₂ ⟨b₁, h₁⟩ ⟨b₂, h₂⟩
+  cases hchain ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h₁ h₂
+  case inl h => left; exact h.1
+  case inr h => right; exact h.1
+
+theorem chain.pprod_snd [CCPO α] [CCPO β] (c : α ×' β → Prop) (hchain : chain c) :
+    chain (chain_pprod_snd c) := by
+  intro b₁ b₂ ⟨a₁, h₁⟩ ⟨a₂, h₂⟩
+  cases hchain ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h₁ h₂
+  case inl h => left; exact h.2
+  case inr h => right; exact h.2
+
+instance [CCPO α] [CCPO β] : CCPO (α ×' β) where
+  csup c := ⟨CCPO.csup (chain_pprod_fst c), CCPO.csup (chain_pprod_snd c)⟩
+  csup_spec := by
+    intro ⟨a, b⟩ c hchain
+    dsimp
+    constructor
+    next =>
+      intro ⟨h₁, h₂⟩ ⟨a', b'⟩ cab
+      constructor <;> dsimp at *
+      · apply rel_trans ?_ h₁
+        apply le_csup hchain.pprod_fst
+        exact ⟨b', cab⟩
+      · apply rel_trans ?_ h₂
+        apply le_csup hchain.pprod_snd
+        exact ⟨a', cab⟩
+    next =>
+      intro h
+      constructor <;> dsimp
+      · apply csup_le hchain.pprod_fst
+        intro a' ⟨b', hcab⟩
+        apply (h _ hcab).1
+      · apply csup_le hchain.pprod_snd
+        intro b' ⟨a', hcab⟩
+        apply (h _ hcab).2
+
+theorem admissible_pprod_fst {α : Sort u} {β : Sort v} [CCPO α] [CCPO β] (P : α → Prop)
+    (hadm : admissible P) : admissible (fun (x : α ×' β) => P x.1) := by
+  intro c hchain h
+  apply hadm _ hchain.pprod_fst
+  intro x ⟨y, hxy⟩
+  apply h ⟨x,y⟩ hxy
+
+theorem admissible_pprod_snd {α : Sort u} {β : Sort v} [CCPO α] [CCPO β] (P : β → Prop)
+    (hadm : admissible P) : admissible (fun (x : α ×' β) => P x.2) := by
+  intro c hchain h
+  apply hadm _ hchain.pprod_snd
+  intro y ⟨x, hxy⟩
+  apply h ⟨x,y⟩ hxy
+
+end pprod_order
+
+section flat_order
+
+variable {α : Sort u}
+
+set_option linter.unusedVariables false in
+/--
+`FlatOrder b` wraps the type `α` with the flat partial order generated by `∀ x, b ⊑ x`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def FlatOrder {α : Sort u} (b : α) := α
+
+variable {b : α}
+
+/--
+The flat partial order generated by `∀ x, b ⊑ x`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+inductive FlatOrder.rel : (x y : FlatOrder b) → Prop where
+  | bot : rel b x
+  | refl : rel x x
+
+instance FlatOrder.instOrder : PartialOrder (FlatOrder b) where
+  rel := rel
+  rel_refl := .refl
+  rel_trans {x y z : α} (hxy : rel x y) (hyz : rel y z) := by
+    cases hxy <;> cases hyz <;> constructor
+  rel_antisymm {x y : α} (hxy : rel x y) (hyz : rel y x) : x = y := by
+    cases hxy <;> cases hyz <;> constructor
+
+open Classical in
+private theorem Classical.some_spec₂ {α : Sort _} {p : α → Prop} {h : ∃ a, p a} (q : α → Prop)
+    (hpq : ∀ a, p a → q a) : q (choose h) := hpq _ <| choose_spec _
+
+noncomputable def flat_csup (c : FlatOrder b → Prop) : FlatOrder b := by
+  by_cases h : ∃ (x : FlatOrder b), c x ∧ x ≠ b
+  · exact Classical.choose h
+  · exact b
+
+noncomputable instance FlatOrder.instCCPO : CCPO (FlatOrder b) where
+  csup := flat_csup
+  csup_spec := by
+    intro x c hc
+    unfold flat_csup
+    split
+    next hex =>
+      apply Classical.some_spec₂ (q := (· ⊑ x ↔ (∀ y, c y → y ⊑ x)))
+      clear hex
+      intro z ⟨hz, hnb⟩
+      constructor
+      · intro h y hy
+        apply PartialOrder.rel_trans _ h; clear h
+        cases hc y z hy hz
+        next => assumption
+        next h =>
+          cases h
+          · contradiction
+          · constructor
+      · intro h
+        cases h z hz
+        · contradiction
+        · constructor
+    next hnotex =>
+      constructor
+      · intro h y hy; clear h
+        suffices y = b by rw [this]; exact rel.bot
+        rw [not_exists] at hnotex
+        specialize hnotex y
+        rw [not_and] at hnotex
+        specialize hnotex hy
+        rw [@Classical.not_not] at hnotex
+        assumption
+      · intro; exact rel.bot
+
+theorem admissible_flatOrder (P : FlatOrder b → Prop) (hnot : P b) : admissible P := by
+  intro c hchain h
+  by_cases h' : ∃ (x : FlatOrder b), c x ∧ x ≠ b
+  · simp [CCPO.csup, flat_csup, h']
+    apply Classical.some_spec₂ (q := (P ·))
+    intro x ⟨hcx, hneb⟩
+    apply h x hcx
+  · simp [CCPO.csup, flat_csup, h', hnot]
+
+end flat_order
+
+section mono_bind
+
+/--
+The class `MonoBind m` indicates that every `m α` has a `PartialOrder`, and that the bind operation
+on `m` is monotone in both arguments with regard to that order.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class MonoBind (m : Type u → Type v) [Bind m] [∀ α, PartialOrder (m α)] where
+  bind_mono_left {a₁ a₂ : m α} {f : α → m b} (h : a₁ ⊑ a₂) : a₁ >>= f ⊑ a₂ >>= f
+  bind_mono_right {a : m α} {f₁ f₂ : α → m b} (h : ∀ x, f₁ x ⊑ f₂ x) : a >>= f₁ ⊑ a >>= f₂
+
+theorem monotone_bind
+    (m : Type u → Type v) [Bind m] [∀ α, PartialOrder (m α)] [MonoBind m]
+    {α β : Type u}
+    {γ : Type w} [PartialOrder γ]
+    (f : γ → m α) (g : γ → α → m β)
+    (hmono₁ : monotone f)
+    (hmono₂ : monotone g) :
+    monotone (fun (x : γ) => f x >>= g x) := by
+  intro x₁ x₂ hx₁₂
+  apply PartialOrder.rel_trans
+  · apply MonoBind.bind_mono_left (hmono₁ _ _ hx₁₂)
+  · apply MonoBind.bind_mono_right (fun y => monotone_apply y _ hmono₂ _ _ hx₁₂)
+
+instance : PartialOrder (Option α) := inferInstanceAs (PartialOrder (FlatOrder none))
+noncomputable instance : CCPO (Option α) := inferInstanceAs (CCPO (FlatOrder none))
+noncomputable instance : MonoBind Option where
+  bind_mono_left h := by
+    cases h
+    · exact FlatOrder.rel.bot
+    · exact FlatOrder.rel.refl
+  bind_mono_right h := by
+    cases ‹Option _›
+    · exact FlatOrder.rel.refl
+    · exact h _
+
+theorem admissible_eq_some (P : Prop) (y : α) :
+    admissible (fun (x : Option α) => x = some y → P) := by
+  apply admissible_flatOrder; simp
+
+instance [Monad m] [inst : ∀ α, PartialOrder (m α)] : PartialOrder (ExceptT ε m α) := inst _
+instance [Monad m] [∀ α, PartialOrder (m α)] [inst : ∀ α, CCPO (m α)] : CCPO (ExceptT ε m α) := inst _
+instance [Monad m] [∀ α, PartialOrder (m α)] [∀ α, CCPO (m α)] [MonoBind m] : MonoBind (ExceptT ε m) where
+  bind_mono_left h₁₂ := by
+    apply MonoBind.bind_mono_left (m := m)
+    exact h₁₂
+  bind_mono_right h₁₂ := by
+    apply MonoBind.bind_mono_right (m := m)
+    intro x
+    cases x
+    · apply PartialOrder.rel_refl
+    · apply h₁₂
+
+end mono_bind
+
+namespace Example
+
+def findF (P : Nat → Bool) (rec : Nat → Option Nat) (x : Nat) : Option Nat :=
+  if P x then
+    some x
+  else
+    rec (x + 1)
+
+noncomputable def find (P : Nat → Bool) : Nat → Option Nat := fix (findF P) <| by
+  unfold findF
+  apply monotone_of_monotone_apply
+  intro n
+  split
+  · apply monotone_const
+  · apply monotone_apply
+    apply monotone_id
+
+theorem find_eq : find P = findF P (find P) := fix_eq ..
+
+theorem find_spec : ∀ n m, find P n = some m → n ≤ m ∧ P m := by
+  unfold find
+  refine fix_induct (motive := fun (f : Nat → Option Nat) => ∀ n m, f n = some m → n ≤ m ∧ P m) _ ?hadm ?hstep
+  case hadm =>
+    -- apply admissible_pi_apply does not work well, hard to infer everything
+    exact admissible_pi_apply _ (fun n => admissible_pi _ (fun m => admissible_eq_some _ m))
+  case hstep =>
+    intro f ih n m heq
+    simp only [findF] at heq
+    split at heq
+    · simp_all
+    · obtain ⟨ih1, ih2⟩ := ih _ _ heq
+      constructor
+      · exact Nat.le_trans (Nat.le_add_right _ _ ) ih1
+      · exact ih2
+
+end Example
+
+end Lean.Order

src/Init/Internal/Order/Tactic.lean

@@ -0,0 +1,20 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+
+prelude
+import Init.Notation
+
+namespace Lean.Order
+/--
+`monotonicity` performs one compositional step solving `monotone` goals,
+using lemma tagged with `@[partial_fixpoint_monotone]`.
+
+This tactic is mostly used internally by lean in `partial_fixpoint` definitions, but
+can be useful on its own for debugging or when proving new `@[partial_fixpoint_monotone]` lemmas.
+-/
+scoped syntax (name := monotonicity) "monotonicity" : tactic
+
+end Lean.Order

src/Lean/Data/Lsp.lean

@@ -6,6 +6,7 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Lean.Data.Lsp.Basic
+import Lean.Data.Lsp.CancelParams
 import Lean.Data.Lsp.Capabilities
 import Lean.Data.Lsp.Client
 import Lean.Data.Lsp.Communication

src/Lean/Data/Lsp/Basic.lean

@@ -6,7 +6,6 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Lean.Data.Json
-import Lean.Data.JsonRpc
 
 /-! Defines most of the 'Basic Structures' in the LSP specification
 (https://microsoft.github.io/language-server-protocol/specifications/specification-current/),
@@ -19,10 +18,6 @@ namespace Lsp
 
 open Json
 
-structure CancelParams where
-  id : JsonRpc.RequestID
-  deriving Inhabited, BEq, ToJson, FromJson
-
 abbrev DocumentUri := String
 
 /-- We adopt the convention that zero-based UTF-16 positions as sent by LSP clients

src/Lean/Data/Lsp/CancelParams.lean

@@ -0,0 +1,25 @@
+/-
+Copyright (c) 2020 Marc Huisinga. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+Authors: Marc Huisinga, Wojciech Nawrocki
+-/
+prelude
+import Lean.Data.JsonRpc
+
+/-! # Defines `Lean.Lsp.CancelParams`.
+
+This is separate from `Lean.Data.Lsp.Basic` to reduce transitive dependencies.
+-/
+
+namespace Lean
+namespace Lsp
+
+open Json
+
+structure CancelParams where
+  id : JsonRpc.RequestID
+  deriving Inhabited, BEq, ToJson, FromJson
+
+end Lsp
+end Lean

src/Lean/Data/Lsp/Utf16.lean

@@ -6,7 +6,6 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Init.Data.String
-import Init.Data.Array
 import Lean.Data.Lsp.Basic
 import Lean.Data.Position
 import Lean.DeclarationRange

src/Lean/Data/PersistentHashSet.lean

@@ -49,3 +49,8 @@ variable {_ : BEq α} {_ : Hashable α}
 
 @[inline] def fold {β : Type v} (f : β → α → β) (init : β) (s : PersistentHashSet α) : β :=
   Id.run $ s.foldM f init
+
+def toList (s : PersistentHashSet α) : List α :=
+  s.set.toList.map (·.1)
+
+end PersistentHashSet

src/Lean/Elab/Calc.lean

@@ -131,14 +131,18 @@ def throwCalcFailure (steps : Array CalcStepView) (expectedType result : Expr) :
     if ← isDefEqGuarded r er then
       let mut failed := false
       unless ← isDefEqGuarded lhs elhs do
+        let (lhs, elhs) ← addPPExplicitToExposeDiff lhs elhs
+        let (lhsTy, elhsTy) ← addPPExplicitToExposeDiff (← inferType lhs) (← inferType elhs)
         logErrorAt steps[0]!.term m!"\
-          invalid 'calc' step, left-hand side is{indentD m!"{lhs} : {← inferType lhs}"}\n\
-          but is expected to be{indentD m!"{elhs} : {← inferType elhs}"}"
+          invalid 'calc' step, left-hand side is{indentD m!"{lhs} : {lhsTy}"}\n\
+          but is expected to be{indentD m!"{elhs} : {elhsTy}"}"
         failed := true
       unless ← isDefEqGuarded rhs erhs do
+        let (rhs, erhs) ← addPPExplicitToExposeDiff rhs erhs
+        let (rhsTy, erhsTy) ← addPPExplicitToExposeDiff (← inferType rhs) (← inferType erhs)
         logErrorAt steps.back!.term m!"\
-          invalid 'calc' step, right-hand side is{indentD m!"{rhs} : {← inferType rhs}"}\n\
-          but is expected to be{indentD m!"{erhs} : {← inferType erhs}"}"
+          invalid 'calc' step, right-hand side is{indentD m!"{rhs} : {rhsTy}"}\n\
+          but is expected to be{indentD m!"{erhs} : {erhsTy}"}"
         failed := true
       if failed then
         throwAbortTerm

src/Lean/Elab/CheckTactic.lean

@@ -38,6 +38,7 @@ def elabCheckTactic : CommandElab := fun stx => do
       | [next] => do
         let (val, _, _) ← matchCheckGoalType stx (←next.getType)
         if !(← Meta.withReducible <| isDefEq val expTerm) then
+          let (val, expTerm) ← addPPExplicitToExposeDiff val expTerm
           throwErrorAt stx
             m!"Term reduces to{indentExpr val}\nbut is expected to reduce to {indentExpr expTerm}"
       | _ => do

src/Lean/Elab/Deriving.lean

@@ -16,3 +16,4 @@ import Lean.Elab.Deriving.FromToJson
 import Lean.Elab.Deriving.SizeOf
 import Lean.Elab.Deriving.Hashable
 import Lean.Elab.Deriving.Ord
+import Lean.Elab.Deriving.ToExpr

src/Lean/Elab/Deriving/ToExpr.lean

@@ -0,0 +1,237 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kyle Miller
+-/
+prelude
+import Lean.Meta.Transform
+import Lean.Elab.Deriving.Basic
+import Lean.Elab.Deriving.Util
+import Lean.ToLevel
+import Lean.ToExpr
+
+/-!
+# `ToExpr` deriving handler
+
+This module defines a `ToExpr` deriving handler for inductive types.
+It supports mutually inductive types as well.
+
+The `ToExpr` deriving handlers support universe level polymorphism, via the `Lean.ToLevel` class.
+To use `ToExpr` in places where there is universe polymorphism, make sure a `[ToLevel.{u}]` instance is available,
+though be aware that the `ToLevel` mechanism does not support `max` or `imax` expressions.
+
+Implementation note: this deriving handler was initially modeled after the `Repr` deriving handler, but
+1. we need to account for universe levels,
+2. the `ToExpr` class has two fields rather than one, and
+3. we don't handle structures specially.
+-/
+
+namespace Lean.Elab.Deriving.ToExpr
+
+open Lean Elab Parser.Term
+open Meta Command Deriving
+
+/--
+Given `args := #[e₁, e₂, …, eₙ]`, constructs the syntax `Expr.app (… (Expr.app (Expr.app f e₁) e₂) …) eₙ`.
+-/
+def mkAppNTerm (f : Term) (args : Array Term) : MetaM Term :=
+  args.foldlM (fun a b => ``(Expr.app $a $b)) f
+
+/-- Fixes the output of `mkInductiveApp` to explicitly reference universe levels. -/
+def updateIndType (indVal : InductiveVal) (t : Term) : TermElabM Term :=
+  let levels := indVal.levelParams.toArray.map mkIdent
+  match t with
+  | `(@$f $args*) => `(@$f.{$levels,*} $args*)
+  | _ => throwError "(internal error) expecting output of `mkInductiveApp`"
+
+/--
+Creates a term that evaluates to an expression representing the inductive type.
+Uses `toExpr` and `toTypeExpr` for the arguments to the type constructor.
+-/
+def mkToTypeExpr (indVal : InductiveVal) (argNames : Array Name) : TermElabM Term := do
+  let levels ← indVal.levelParams.toArray.mapM (fun u => `(Lean.toLevel.{$(mkIdent u)}))
+  forallTelescopeReducing indVal.type fun xs _ => do
+    let mut args : Array Term := #[]
+    for argName in argNames, x in xs do
+      let a := mkIdent argName
+      if ← Meta.isType x then
+        args := args.push <| ← ``(toTypeExpr $a)
+      else
+        args := args.push <| ← ``(toExpr $a)
+    mkAppNTerm (← ``(Expr.const $(quote indVal.name) [$levels,*])) args
+
+/--
+Creates the body of the `toExpr` function for the `ToExpr` instance, which is a `match` expression
+that calls `toExpr` and `toTypeExpr` to assemble an expression for a given term.
+For recursive inductive types, `auxFunName` refers to the `ToExpr` instance for the current type.
+For mutually recursive types, we rely on the local instances set up by `mkLocalInstanceLetDecls`.
+-/
+def mkToExprBody (header : Header) (indVal : InductiveVal) (auxFunName : Name) (levelInsts : Array Term) :
+    TermElabM Term := do
+  let discrs ← mkDiscrs header indVal
+  let alts ← mkAlts
+  `(match $[$discrs],* with $alts:matchAlt*)
+where
+  /-- Create the `match` cases, one per constructor. -/
+  mkAlts : TermElabM (Array (TSyntax ``matchAlt)) := do
+    let levels ← levelInsts.mapM fun inst => `($(inst).toLevel)
+    let mut alts := #[]
+    for ctorName in indVal.ctors do
+      let ctorInfo ← getConstInfoCtor ctorName
+      let alt ← forallTelescopeReducing ctorInfo.type fun xs _ => do
+        let mut patterns := #[]
+        -- add `_` pattern for indices, before the constructor's pattern
+        for _ in [:indVal.numIndices] do
+          patterns := patterns.push (← `(_))
+        let mut ctorArgs := #[]
+        let mut rhsArgs : Array Term := #[]
+        let mkArg (x : Expr) (a : Term) : TermElabM Term := do
+          if (← inferType x).isAppOf indVal.name then
+            `($(mkIdent auxFunName) $levelInsts* $a)
+          else if ← Meta.isType x then
+            ``(toTypeExpr $a)
+          else
+            ``(toExpr $a)
+        -- add `_` pattern for inductive parameters, which are inaccessible
+        for i in [:ctorInfo.numParams] do
+          let a := mkIdent header.argNames[i]!
+          ctorArgs := ctorArgs.push (← `(_))
+          rhsArgs := rhsArgs.push <| ← mkArg xs[i]! a
+        for i in [:ctorInfo.numFields] do
+          let a := mkIdent (← mkFreshUserName `a)
+          ctorArgs := ctorArgs.push a
+          rhsArgs := rhsArgs.push <| ← mkArg xs[ctorInfo.numParams + i]! a
+        patterns := patterns.push (← `(@$(mkIdent ctorName):ident $ctorArgs:term*))
+        let rhs : Term ← mkAppNTerm (← ``(Expr.const $(quote ctorInfo.name) [$levels,*])) rhsArgs
+        `(matchAltExpr| | $[$patterns:term],* => $rhs)
+      alts := alts.push alt
+    return alts
+
+/--
+For nested and mutually recursive inductive types, we define `partial` instances,
+and the strategy is to have local `ToExpr` instances in scope for the body of each instance.
+This way, each instance can freely use `toExpr` and `toTypeExpr` for each of the types in `ctx`.
+
+This is a modified copy of `Lean.Elab.Deriving.mkLocalInstanceLetDecls`,
+since we need to include the `toTypeExpr` field in the `letDecl`
+Note that, for simplicity, each instance gets its own definition of each others' `toTypeExpr` fields.
+These are very simple fields, so avoiding the duplication is not worth it.
+-/
+def mkLocalInstanceLetDecls (ctx : Deriving.Context) (argNames : Array Name) (levelInsts : Array Term) :
+    TermElabM (Array (TSyntax ``Parser.Term.letDecl)) := do
+  let mut letDecls := #[]
+  for indVal in ctx.typeInfos, auxFunName in ctx.auxFunNames do
+    let currArgNames ← mkInductArgNames indVal
+    let numParams    := indVal.numParams
+    let currIndices  := currArgNames[numParams:]
+    let binders      ← mkImplicitBinders currIndices
+    let argNamesNew  := argNames[:numParams] ++ currIndices
+    let indType      ← mkInductiveApp indVal argNamesNew
+    let instName     ← mkFreshUserName `localinst
+    let toTypeExpr   ← mkToTypeExpr indVal argNames
+    -- Recall that mutually inductive types all use the same universe levels, hence we pass the same ToLevel instances to each aux function.
+    let letDecl      ← `(Parser.Term.letDecl| $(mkIdent instName):ident $binders:implicitBinder* : ToExpr $indType :=
+                          { toExpr     := $(mkIdent auxFunName) $levelInsts*,
+                            toTypeExpr := $toTypeExpr })
+    letDecls := letDecls.push letDecl
+  return letDecls
+
+open TSyntax.Compat in
+/--
+Makes a `toExpr` function for the given inductive type.
+The implementation of each `toExpr` function for a (mutual) inductive type is given as top-level private definitions.
+These are assembled into `ToExpr` instances in `mkInstanceCmds`.
+For mutual/nested inductive types, then each of the types' `ToExpr` instances are provided as local instances,
+to wire together the recursion (necessitating these auxiliary definitions being `partial`).
+-/
+def mkAuxFunction (ctx : Deriving.Context) (i : Nat) : TermElabM Command := do
+  let auxFunName := ctx.auxFunNames[i]!
+  let indVal     := ctx.typeInfos[i]!
+  let header     ← mkHeader ``ToExpr 1 indVal
+  /- We make the `ToLevel` instances be explicit here so that we can pass the instances from the instances to the
+     aux functions. This lets us ensure universe level variables are being lined up,
+     without needing to use `ident.{u₁,…,uₙ}` syntax, which could conditionally be incorrect
+     depending on the ambient CommandElabM scope state.
+     TODO(kmill): deriving handlers should run in a scope with no `universes` or `variables`. -/
+  let (toLevelInsts, levelBinders) := Array.unzip <| ← indVal.levelParams.toArray.mapM fun u => do
+    let inst := mkIdent (← mkFreshUserName `inst)
+    return (inst, ← `(explicitBinderF| ($inst : ToLevel.{$(mkIdent u)})))
+  let mut body ← mkToExprBody header indVal auxFunName toLevelInsts
+  if ctx.usePartial then
+    let letDecls ← mkLocalInstanceLetDecls ctx header.argNames toLevelInsts
+    body ← mkLet letDecls body
+  /- We need to alter the last binder (the one for the "target") to have explicit universe levels
+     so that the `ToLevel` instance arguments can use them. -/
+  let addLevels binder :=
+    match binder with
+    | `(bracketedBinderF| ($a : $ty)) => do `(bracketedBinderF| ($a : $(← updateIndType indVal ty)))
+    | _ => throwError "(internal error) expecting inst binder"
+  let binders := header.binders.pop ++ levelBinders ++ #[← addLevels header.binders.back!]
+  if ctx.usePartial then
+    `(private partial def $(mkIdent auxFunName):ident $binders:bracketedBinder* : Expr := $body:term)
+  else
+    `(private         def $(mkIdent auxFunName):ident $binders:bracketedBinder* : Expr := $body:term)
+
+/--
+Creates all the auxiliary functions (using `mkAuxFunction`) for the (mutual) inductive type(s).
+Wraps the resulting definition commands in `mutual ... end`.
+-/
+def mkAuxFunctions (ctx : Deriving.Context) : TermElabM Syntax := do
+  let mut auxDefs := #[]
+  for i in [:ctx.typeInfos.size] do
+    auxDefs := auxDefs.push (← mkAuxFunction ctx i)
+  `(mutual $auxDefs:command* end)
+
+open TSyntax.Compat in
+/--
+Assuming all of the auxiliary definitions exist,
+creates all the `instance` commands for the `ToExpr` instances for the (mutual) inductive type(s).
+This is a modified copy of `Lean.Elab.Deriving.mkInstanceCmds` to account for `ToLevel` instances.
+-/
+def mkInstanceCmds (ctx : Deriving.Context) (typeNames : Array Name) :
+    TermElabM (Array Command) := do
+  let mut instances := #[]
+  for indVal in ctx.typeInfos, auxFunName in ctx.auxFunNames do
+    if typeNames.contains indVal.name then
+      let argNames     ← mkInductArgNames indVal
+      let binders      ← mkImplicitBinders argNames
+      let binders      := binders ++ (← mkInstImplicitBinders ``ToExpr indVal argNames)
+      let (toLevelInsts, levelBinders) := Array.unzip <| ← indVal.levelParams.toArray.mapM fun u => do
+        let inst := mkIdent (← mkFreshUserName `inst)
+        return (inst, ← `(instBinderF| [$inst : ToLevel.{$(mkIdent u)}]))
+      let binders      := binders ++ levelBinders
+      let indType      ← updateIndType indVal (← mkInductiveApp indVal argNames)
+      let toTypeExpr   ← mkToTypeExpr indVal argNames
+      let instCmd ← `(instance $binders:implicitBinder* : ToExpr $indType where
+                        toExpr := $(mkIdent auxFunName) $toLevelInsts*
+                        toTypeExpr := $toTypeExpr)
+      instances := instances.push instCmd
+  return instances
+
+/--
+Returns all the commands necessary to construct the `ToExpr` instances.
+-/
+def mkToExprInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
+  let ctx ← mkContext "toExpr" declNames[0]!
+  let cmds := #[← mkAuxFunctions ctx] ++ (← mkInstanceCmds ctx declNames)
+  trace[Elab.Deriving.toExpr] "\n{cmds}"
+  return cmds
+
+/--
+The main entry point to the `ToExpr` deriving handler.
+-/
+def mkToExprInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
+  if (← declNames.allM isInductive) && declNames.size > 0 then
+    let cmds ← withFreshMacroScope <| liftTermElabM <| mkToExprInstanceCmds declNames
+    -- Enable autoimplicits, used for universe levels.
+    withScope (fun scope => { scope with opts := autoImplicit.set scope.opts true }) do
+      elabCommand (mkNullNode cmds)
+    return true
+  else
+    return false
+
+builtin_initialize
+  registerDerivingHandler ``Lean.ToExpr mkToExprInstanceHandler
+  registerTraceClass `Elab.Deriving.toExpr
+
+end Lean.Elab.Deriving.ToExpr

src/Lean/Elab/Structure.lean

@@ -691,6 +691,9 @@ private def addProjections (r : ElabHeaderResult) (fieldInfos : Array StructFiel
   let env ← getEnv
   let env ← ofExceptKernelException (mkProjections env r.view.declName projNames.toList r.view.isClass)
   setEnv env
+  for fieldInfo in fieldInfos do
+    if fieldInfo.isSubobject then
+      addDeclarationRangesFromSyntax fieldInfo.declName r.view.ref fieldInfo.ref
 
 private def registerStructure (structName : Name) (infos : Array StructFieldInfo) : TermElabM Unit := do
   let fields ← infos.filterMapM fun info => do
@@ -775,14 +778,14 @@ private def setSourceInstImplicit (type : Expr) : Expr :=
 /--
 Creates a projection function to a non-subobject parent.
 -/
-private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (source : Expr) (parentStructName : Name) (parentType : Expr) : MetaM StructureParentInfo := do
+private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (source : Expr) (parent : StructParentInfo) (parentType : Expr) : MetaM StructureParentInfo := do
   let isProp ← Meta.isProp parentType
   let env ← getEnv
   let structName := view.declName
   let sourceFieldNames := getStructureFieldsFlattened env structName
-  let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
+  let binfo := if view.isClass && isClass env parent.structName then BinderInfo.instImplicit else BinderInfo.default
   let mut declType ← instantiateMVars (← mkForallFVars params (← mkForallFVars #[source] parentType))
-  if view.isClass && isClass env parentStructName then
+  if view.isClass && isClass env parent.structName then
     declType := setSourceInstImplicit declType
   declType := declType.inferImplicit params.size true
   let rec copyFields (parentType : Expr) : MetaM Expr := do
@@ -823,7 +826,8 @@ private partial def mkCoercionToCopiedParent (levelParams : List Name) (params :
   -- (Instances will get instance reducibility in `Lean.Elab.Command.addParentInstances`.)
   if !binfo.isInstImplicit && !(← Meta.isProp parentType) then
     setReducibleAttribute declName
-  return { structName := parentStructName, subobject := false, projFn := declName }
+  addDeclarationRangesFromSyntax declName view.ref parent.ref
+  return { structName := parent.structName, subobject := false, projFn := declName }
 
 private def mkRemainingProjections (levelParams : List Name) (params : Array Expr) (view : StructView)
     (parents : Array StructParentInfo) (fieldInfos : Array StructFieldInfo) : TermElabM (Array StructureParentInfo) := do
@@ -844,7 +848,7 @@ private def mkRemainingProjections (levelParams : List Name) (params : Array Exp
           pure { structName := parent.structName, subobject := true, projFn := info.declName }
         else
           let parent_type := (← instantiateMVars parent.type).replace fun e => parentFVarToConst[e]?
-          mkCoercionToCopiedParent levelParams params view source parent.structName parent_type)
+          mkCoercionToCopiedParent levelParams params view source parent parent_type)
       parentInfos := parentInfos.push parentInfo
       if let some fvar := parent.fvar? then
         parentFVarToConst := parentFVarToConst.insert fvar <|

src/Lean/Elab/Tactic.lean

@@ -44,3 +44,5 @@ import Lean.Elab.Tactic.DiscrTreeKey
 import Lean.Elab.Tactic.BVDecide
 import Lean.Elab.Tactic.BoolToPropSimps
 import Lean.Elab.Tactic.Classical
+import Lean.Elab.Tactic.Grind
+import Lean.Elab.Tactic.Monotonicity

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/Reflect.lean

@@ -82,7 +82,7 @@ instance : ToExpr Gate where
     | .and => mkConst ``Gate.and
     | .xor => mkConst ``Gate.xor
     | .beq => mkConst ``Gate.beq
-    | .imp => mkConst ``Gate.imp
+    | .or => mkConst ``Gate.or
   toTypeExpr := mkConst ``Gate
 
 instance : ToExpr BVPred where

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/ReifiedBVLogical.lean

@@ -91,7 +91,7 @@ where
     | .and => ``Std.Tactic.BVDecide.Reflect.Bool.and_congr
     | .xor => ``Std.Tactic.BVDecide.Reflect.Bool.xor_congr
     | .beq => ``Std.Tactic.BVDecide.Reflect.Bool.beq_congr
-    | .imp => ``Std.Tactic.BVDecide.Reflect.Bool.imp_congr
+    | .or => ``Std.Tactic.BVDecide.Reflect.Bool.or_congr
 
 /--
 Construct the reified version of `Bool.not subExpr`.
@@ -136,7 +136,7 @@ def mkIte (discr lhs rhs : ReifiedBVLogical) (discrExpr lhsExpr rhsExpr : Expr)
         lhsEvalExpr lhsProof?
         rhsEvalExpr rhsProof? | return none
     return mkApp9
-      (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.ite_congr)
+      (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.cond_congr)
       discrExpr lhsExpr rhsExpr
       discrEvalExpr lhsEvalExpr rhsEvalExpr
       discrProof lhsProof rhsProof

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/ReifiedLemmas.lean

@@ -22,67 +22,70 @@ This function adds the two lemmas:
 - `discrExpr = false → atomExpr = rhsExpr`
 It assumes that `discrExpr`, `lhsExpr` and `rhsExpr` are the expressions corresponding to `discr`,
 `lhs` and `rhs`. Furthermore it assumes that `atomExpr` is of the form
-`if discrExpr = true then lhsExpr else rhsExpr`.
+`bif discrExpr then lhsExpr else rhsExpr`.
 -/
-def addIfLemmas (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
+def addCondLemmas (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
     (discrExpr atomExpr lhsExpr rhsExpr : Expr) : LemmaM Unit := do
-  let some trueLemma ← mkIfTrueLemma discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
+  let some trueLemma ← mkCondTrueLemma discr atom lhs discrExpr atomExpr lhsExpr rhsExpr | return ()
   LemmaM.addLemma trueLemma
-  let some falseLemma ← mkIfFalseLemma discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
+  let some falseLemma ← mkCondFalseLemma discr atom rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
   LemmaM.addLemma falseLemma
 where
-  mkIfTrueLemma (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
-      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) :=
-    mkIfLemma true discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr
-
-  mkIfFalseLemma (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
-      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) :=
-    mkIfLemma false discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr
-
-  mkIfLemma (discrVal : Bool) (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
+  mkCondTrueLemma (discr : ReifiedBVLogical) (atom lhs : ReifiedBVExpr)
       (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) := do
-    let resExpr := if discrVal then lhsExpr else rhsExpr
-    let resValExpr := if discrVal then lhs else rhs
-    let lemmaName :=
-      if discrVal then
-        ``Std.Tactic.BVDecide.Reflect.BitVec.if_true
-      else
-        ``Std.Tactic.BVDecide.Reflect.BitVec.if_false
-    let discrValExpr := toExpr discrVal
-    let discrVal ← ReifiedBVLogical.mkBoolConst discrVal
+    let resExpr := lhsExpr
+    let resValExpr := lhs
+    let lemmaName := ``Std.Tactic.BVDecide.Reflect.BitVec.cond_true
 
-    let eqDiscrExpr ← mkAppM ``BEq.beq #[discrExpr, discrValExpr]
-    let eqDiscr ← ReifiedBVLogical.mkGate discr discrVal discrExpr discrValExpr .beq
+
+    let notDiscrExpr := mkApp (mkConst ``Bool.not) discrExpr
+    let notDiscr ← ReifiedBVLogical.mkNot discr discrExpr
 
     let eqBVExpr ← mkAppM ``BEq.beq #[atomExpr, resExpr]
     let some eqBVPred ← ReifiedBVPred.mkBinPred atom resValExpr atomExpr resExpr .eq | return none
     let eqBV ← ReifiedBVLogical.ofPred eqBVPred
 
-    let imp ← ReifiedBVLogical.mkGate eqDiscr eqBV eqDiscrExpr eqBVExpr .imp
+    let imp ← ReifiedBVLogical.mkGate notDiscr eqBV notDiscrExpr eqBVExpr .or
 
     let proof := do
       let evalExpr ← ReifiedBVLogical.mkEvalExpr imp.expr
       let congrProof := (← imp.evalsAtAtoms).getD (ReifiedBVLogical.mkRefl evalExpr)
       let lemmaProof := mkApp4 (mkConst lemmaName) (toExpr lhs.width) discrExpr lhsExpr rhsExpr
 
-      let trueExpr := mkConst ``Bool.true
-      let eqDiscrTrueExpr ← mkEq eqDiscrExpr trueExpr
-      let eqBVExprTrueExpr ← mkEq eqBVExpr trueExpr
-      let impExpr ← mkArrow eqDiscrTrueExpr eqBVExprTrueExpr
-      -- construct a `Decidable` instance for the implication using forall_prop_decidable
-      let decEqDiscrTrue := mkApp2 (mkConst ``instDecidableEqBool) eqDiscrExpr trueExpr
-      let decEqBVExprTrue := mkApp2 (mkConst ``instDecidableEqBool) eqBVExpr trueExpr
-      let impDecidable := mkApp4 (mkConst ``forall_prop_decidable)
-        eqDiscrTrueExpr
-        (.lam .anonymous eqDiscrTrueExpr eqBVExprTrueExpr .default)
-        decEqDiscrTrue
-        (.lam .anonymous eqDiscrTrueExpr decEqBVExprTrue .default)
-
-      let decideImpExpr := mkApp2 (mkConst ``Decidable.decide) impExpr impDecidable
+      -- !discr || (atom == rhs)
+      let impExpr := mkApp2 (mkConst ``Bool.or) notDiscrExpr eqBVExpr
 
       return mkApp4
         (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.lemma_congr)
-        decideImpExpr
+        impExpr
+        evalExpr
+        congrProof
+        lemmaProof
+    return some ⟨imp.bvExpr, proof, imp.expr⟩
+
+  mkCondFalseLemma (discr : ReifiedBVLogical) (atom rhs : ReifiedBVExpr)
+      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) := do
+    let resExpr := rhsExpr
+    let resValExpr := rhs
+    let lemmaName := ``Std.Tactic.BVDecide.Reflect.BitVec.cond_false
+
+    let eqBVExpr ← mkAppM ``BEq.beq #[atomExpr, resExpr]
+    let some eqBVPred ← ReifiedBVPred.mkBinPred atom resValExpr atomExpr resExpr .eq | return none
+    let eqBV ← ReifiedBVLogical.ofPred eqBVPred
+
+    let imp ← ReifiedBVLogical.mkGate discr eqBV discrExpr eqBVExpr .or
+
+    let proof := do
+      let evalExpr ← ReifiedBVLogical.mkEvalExpr imp.expr
+      let congrProof := (← imp.evalsAtAtoms).getD (ReifiedBVLogical.mkRefl evalExpr)
+      let lemmaProof := mkApp4 (mkConst lemmaName) (toExpr rhs.width) discrExpr lhsExpr rhsExpr
+
+      -- discr || (atom == rhs)
+      let impExpr := mkApp2 (mkConst ``Bool.or) discrExpr eqBVExpr
+
+      return mkApp4
+        (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.lemma_congr)
+        impExpr
         evalExpr
         congrProof
         lemmaProof

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/Reify.lean

@@ -220,15 +220,12 @@ where
         .rotateRight
         ``BVUnOp.rotateRight
         ``Std.Tactic.BVDecide.Reflect.BitVec.rotateRight_congr
-    | ite _ discrExpr _ lhsExpr rhsExpr =>
-      let_expr Eq α discrExpr val := discrExpr | return none
-      let_expr Bool := α | return none
-      let_expr Bool.true := val | return none
+    | cond _ discrExpr lhsExpr rhsExpr =>
       let some atom ← ReifiedBVExpr.bitVecAtom x true | return none
       let some discr ← ReifiedBVLogical.of discrExpr | return none
       let some lhs ← goOrAtom lhsExpr | return none
       let some rhs ← goOrAtom rhsExpr | return none
-      addIfLemmas discr atom lhs rhs discrExpr x lhsExpr rhsExpr
+      addCondLemmas discr atom lhs rhs discrExpr x lhsExpr rhsExpr
       return some atom
     | _ => return none
 
@@ -392,10 +389,7 @@ where
       | Bool => gateReflection lhsExpr rhsExpr .beq
       | BitVec _ => goPred t
       | _ => return none
-    | ite _ discrExpr _ lhsExpr rhsExpr =>
-      let_expr Eq α discrExpr val := discrExpr | return none
-      let_expr Bool := α | return none
-      let_expr Bool.true := val | return none
+    | cond _ discrExpr lhsExpr rhsExpr =>
       let some discr ← goOrAtom discrExpr | return none
       let some lhs ← goOrAtom lhsExpr | return none
       let some rhs ← goOrAtom rhsExpr | return none

src/Lean/Elab/Tactic/BVDecide/Frontend/Normalize.lean

@@ -28,6 +28,18 @@ 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
@@ -127,8 +139,6 @@ builtin_simproc [bv_normalize] bv_add_const' (((_ : BitVec _) + (_ : BitVec _))
       else
         return .continue
 
-attribute [builtin_bv_normalize_proc↓] reduceIte
-
 /-- Return a number `k` such that `2^k = n`. -/
 private def Nat.log2Exact (n : Nat) : Option Nat := do
   guard <| n ≠ 0

src/Lean/Elab/Tactic/Grind.lean

@@ -0,0 +1,69 @@
+/-
+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.Grind.Tactics
+import Lean.Meta.Tactic.Grind
+import Lean.Elab.Command
+import Lean.Elab.Tactic.Basic
+import Lean.Elab.Tactic.Config
+
+namespace Lean.Elab.Tactic
+open Meta
+
+declare_config_elab elabGrindConfig Grind.Config
+
+open Command Term in
+@[builtin_command_elab Lean.Parser.Command.grindPattern]
+def elabGrindPattern : CommandElab := fun stx => do
+  match stx with
+  | `(grind_pattern $thmName:ident => $terms,*) => do
+    liftTermElabM do
+      let declName ← resolveGlobalConstNoOverload thmName
+      discard <| addTermInfo thmName (← mkConstWithLevelParams declName)
+      let info ← getConstInfo declName
+      forallTelescope info.type fun xs _ => do
+        let patterns ← terms.getElems.mapM fun term => do
+          let pattern ← elabTerm term none
+          synthesizeSyntheticMVarsUsingDefault
+          let pattern ← instantiateMVars pattern
+          let pattern ← Grind.preprocessPattern pattern
+          return pattern.abstract xs
+        Grind.addEMatchTheorem declName xs.size patterns.toList
+  | _ => throwUnsupportedSyntax
+
+def grind (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Grind.Fallback) : MetaM Unit := do
+  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 ())
+  let type := mkApp (mkConst ``Grind.GoalM) (mkConst ``Unit)
+  let value ← withLCtx {} {} do Term.elabTermAndSynthesize fallback type
+  let auxDeclName ← if let .const declName _ := value then
+    pure declName
+  else
+    let auxDeclName ← Term.mkAuxName `_grind_fallback
+    let decl := Declaration.defnDecl {
+      name := auxDeclName
+      levelParams := []
+      type, value, hints := .opaque, safety := .safe
+    }
+    addAndCompile decl
+    pure auxDeclName
+  unsafe evalConst (Grind.GoalM Unit) auxDeclName
+
+@[builtin_tactic Lean.Parser.Tactic.grind] def evalApplyRfl : Tactic := fun stx => do
+  match stx with
+  | `(tactic| grind $config:optConfig $[on_failure $fallback?]?) =>
+    let fallback ← elabFallback fallback?
+    logWarningAt stx "The `grind` tactic is experimental and still under development. Avoid using it in production projects"
+    let declName := (← Term.getDeclName?).getD `_grind
+    let config ← elabGrindConfig config
+    withMainContext do liftMetaFinishingTactic (grind · config declName fallback)
+  | _ => throwUnsupportedSyntax
+
+end Lean.Elab.Tactic

src/Lean/Elab/Tactic/Induction.lean

@@ -579,12 +579,25 @@ private def checkAltsOfOptInductionAlts (optInductionAlts : Syntax) : TacticM Un
           throwErrorAt alt "more than one wildcard alternative '| _ => ...' used"
         found := true
 
-def getInductiveValFromMajor (major : Expr) : TacticM InductiveVal :=
+def getInductiveValFromMajor (induction : Bool) (major : Expr) : TacticM InductiveVal :=
   liftMetaMAtMain fun mvarId => do
     let majorType ← inferType major
     let majorType ← whnf majorType
     matchConstInduct majorType.getAppFn
-      (fun _ => Meta.throwTacticEx `induction mvarId m!"major premise type is not an inductive type {indentExpr majorType}")
+      (fun _ => do
+        let tacticName := if induction then `induction else `cases
+        let mut hint := m!"\n\nExplanation: the '{tacticName}' tactic is for constructor-based reasoning \
+          as well as for applying custom {tacticName} principles with a 'using' clause or a registered '@[{tacticName}_eliminator]' theorem. \
+          The above type neither is an inductive type nor has a registered theorem."
+        if majorType.isProp then
+          hint := m!"{hint}\n\n\
+            Consider using the 'by_cases' tactic, which does true/false reasoning for propositions."
+        else if majorType.isType then
+          hint := m!"{hint}\n\n\
+            Type universes are not inductive types, and type-constructor-based reasoning is not possible. \
+            This is a strong limitation. According to Lean's underlying theory, the only provable distinguishing \
+            feature of types is their cardinalities."
+        Meta.throwTacticEx tacticName mvarId m!"major premise type is not an inductive type{indentExpr majorType}{hint}")
       (fun val _ => pure val)
 
 /--
@@ -627,7 +640,7 @@ private def getElimNameInfo (optElimId : Syntax) (targets : Array Expr) (inducti
         return ← getElimInfo elimName
     unless targets.size == 1 do
       throwError "eliminator must be provided when multiple targets are used (use 'using <eliminator-name>'), and no default eliminator has been registered using attribute `[eliminator]`"
-    let indVal ← getInductiveValFromMajor targets[0]!
+    let indVal ← getInductiveValFromMajor induction targets[0]!
     if induction && indVal.all.length != 1 then
       throwError "'induction' tactic does not support mutually inductive types, the eliminator '{mkRecName indVal.name}' has multiple motives"
     if induction && indVal.isNested then

src/Lean/Elab/Tactic/Monotonicity.lean

@@ -0,0 +1,223 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Lean.Meta.Tactic.Split
+import Lean.Elab.RecAppSyntax
+import Lean.Elab.Tactic.Basic
+import Init.Internal.Order
+
+namespace Lean.Meta.Monotonicity
+
+open Lean Meta
+open Lean.Order
+
+partial def headBetaUnderLambda (f : Expr) : Expr := Id.run do
+  let mut f := f.headBeta
+  if f.isLambda then
+    while f.bindingBody!.isHeadBetaTarget do
+      f := f.updateLambda! f.bindingInfo! f.bindingDomain! f.bindingBody!.headBeta
+  return f
+
+
+/-- Environment extensions for monotonicity lemmas -/
+builtin_initialize monotoneExt :
+    SimpleScopedEnvExtension (Name × Array DiscrTree.Key) (DiscrTree Name) ←
+  registerSimpleScopedEnvExtension {
+    addEntry := fun dt (n, ks) => dt.insertCore ks n
+    initial := {}
+  }
+
+builtin_initialize registerBuiltinAttribute {
+  name := `partial_fixpoint_monotone
+  descr := "monotonicity theorem"
+  add := fun decl _ kind => MetaM.run' do
+    let declTy := (← getConstInfo decl).type
+    let (xs, _, targetTy) ← withReducible <| forallMetaTelescopeReducing declTy
+    let_expr monotone α inst_α β inst_β f := targetTy |
+      throwError "@[partial_fixpoint_monotone] attribute only applies to lemmas proving {.ofConstName ``monotone}"
+    let f := f.headBeta
+    let f ← if f.isLambda then pure f else etaExpand f
+    let f := headBetaUnderLambda f
+    lambdaBoundedTelescope f 1 fun _ e => do
+      let key ← withReducible <| DiscrTree.mkPath e
+      monotoneExt.add (decl, key) kind
+}
+
+/--
+Finds tagged monotonicity theorems of the form `monotone (fun x => e)`.
+-/
+def findMonoThms (e : Expr) : MetaM (Array Name) := do
+  (monotoneExt.getState (← getEnv)).getMatch e
+
+private def defaultFailK (f : Expr) (monoThms : Array Name) : MetaM α :=
+  let extraMsg := if monoThms.isEmpty then m!"" else
+    m!"Tried to apply {.andList (monoThms.toList.map (m!"'{·}'"))}, but failed."
+  throwError "Failed to prove monotonicity of:{indentExpr f}\n{extraMsg}"
+
+private def applyConst (goal : MVarId) (name : Name) : MetaM (List MVarId) := do
+  mapError (f := (m!"Could not apply {.ofConstName name}:{indentD ·}")) do
+    goal.applyConst name (cfg := { synthAssignedInstances := false})
+
+/--
+Base case for solveMonoStep: Handles goals of the form
+```
+monotone (fun f => f.1.2 x y)
+```
+
+It's tricky to solve them compositionally from the outside in, so here we construct the proof
+from the inside out.
+-/
+partial def solveMonoCall (α inst_α : Expr) (e : Expr) : MetaM (Option Expr) := do
+  if e.isApp && !e.appArg!.hasLooseBVars then
+    let some hmono ← solveMonoCall α inst_α e.appFn! | return none
+    let hmonoType ← inferType hmono
+    let_expr monotone _ _ _ inst _ := hmonoType | throwError "solveMonoCall {e}: unexpected type {hmonoType}"
+    let some inst ← whnfUntil inst ``instOrderPi | throwError "solveMonoCall {e}: unexpected instance {inst}"
+    let_expr instOrderPi γ δ inst ← inst | throwError "solveMonoCall {e}: whnfUntil failed?{indentExpr inst}"
+    return ← mkAppOptM ``monotone_apply #[γ, δ, α, inst_α, inst, e.appArg!, none, hmono]
+
+  if e.isProj then
+    let some hmono ← solveMonoCall α inst_α e.projExpr! | return none
+    let hmonoType ← inferType hmono
+    let_expr monotone _ _ _ inst _ := hmonoType | throwError "solveMonoCall {e}: unexpected type {hmonoType}"
+    let some inst ← whnfUntil inst ``instPartialOrderPProd | throwError "solveMonoCall {e}: unexpected instance {inst}"
+    let_expr instPartialOrderPProd β γ inst_β inst_γ ← inst | throwError "solveMonoCall {e}: whnfUntil failed?{indentExpr inst}"
+    let n := if e.projIdx! == 0 then ``monotone_pprod_fst else ``monotone_pprod_snd
+    return ← mkAppOptM n #[β, γ, α, inst_β, inst_γ, inst_α, none, hmono]
+
+  if e == .bvar 0 then
+    let hmono ← mkAppOptM ``monotone_id #[α, inst_α]
+    return some hmono
+
+  return none
+
+
+def solveMonoStep (failK : ∀ {α}, Expr → Array Name → MetaM α := @defaultFailK) (goal : MVarId) : MetaM (List MVarId) :=
+  goal.withContext do
+  trace[Elab.Tactic.monotonicity] "monotonicity at\n{goal}"
+  let type ← goal.getType
+  if type.isForall then
+    let (_, goal) ← goal.intro1P
+    return [goal]
+
+  match_expr type with
+  | monotone α inst_α β inst_β f =>
+    -- Ensure f is not headed by a redex and headed by at least one lambda, and clean some
+    -- redexes left by some of the lemmas we tend to apply
+    let f ← instantiateMVars f
+    let f := f.headBeta
+    let f ← if f.isLambda then pure f else etaExpand f
+    let f := headBetaUnderLambda f
+    let e := f.bindingBody!
+
+    -- No recursive calls left
+    if !e.hasLooseBVars then
+      return ← applyConst goal ``monotone_const
+
+    -- NB: `e` is now an open term.
+
+    -- Look through mdata
+    if e.isMData then
+      let f' := f.updateLambdaE! f.bindingDomain! e.mdataExpr!
+      let goal' ← mkFreshExprSyntheticOpaqueMVar (mkApp type.appFn! f')
+      goal.assign goal'
+      return [goal'.mvarId!]
+
+    -- Float letE to the environment
+    if let .letE n t v b _nonDep := e then
+      if t.hasLooseBVars || v.hasLooseBVars then
+        failK f #[]
+      let goal' ← withLetDecl n t v fun x => do
+        let b' := f.updateLambdaE! f.bindingDomain! (b.instantiate1 x)
+        let goal' ← mkFreshExprSyntheticOpaqueMVar (mkApp type.appFn! b')
+        goal.assign (← mkLetFVars #[x] goal')
+        pure goal'
+      return [goal'.mvarId!]
+
+    -- Float `letFun` to the environment.
+    -- `applyConst` tends to reduce the redex
+    match_expr e with
+    | letFun γ _ v b =>
+      if γ.hasLooseBVars || v.hasLooseBVars then
+        failK f #[]
+      let b' := f.updateLambdaE! f.bindingDomain! b
+      let p  ← mkAppOptM ``monotone_letFun #[α, β, γ, inst_α, inst_β, v, b']
+      let new_goals ← mapError (f := (m!"Could not apply {p}:{indentD ·}")) do
+        goal.apply p
+      let [new_goal] := new_goals
+          | throwError "Unexpected number of goals after {.ofConstName ``monotone_letFun}."
+      let (_, new_goal) ←
+        if b.isLambda then
+          new_goal.intro b.bindingName!
+        else
+          new_goal.intro1
+      return [new_goal]
+    | _ => pure ()
+
+    -- Handle lambdas, preserving the name of the binder
+    if e.isLambda then
+      let [new_goal] ← applyConst goal ``monotone_of_monotone_apply
+        | throwError "Unexpected number of goals after {.ofConstName ``monotone_of_monotone_apply}."
+      let (_, new_goal) ← new_goal.intro e.bindingName!
+      return [new_goal]
+
+    -- A recursive call directly here
+    if e.isBVar then
+      return ← applyConst goal ``monotone_id
+
+    -- A recursive call
+    if let some hmono ← solveMonoCall α inst_α e then
+      trace[Elab.Tactic.monotonicity] "Found recursive call {e}:{indentExpr hmono}"
+      unless ← goal.checkedAssign hmono do
+        trace[Elab.Tactic.monotonicity] "Failed to assign {hmono} : {← inferType hmono} to goal"
+        failK f #[]
+      return []
+
+    let monoThms ← withLocalDeclD `f f.bindingDomain! fun f =>
+      -- The discrimination tree does not like open terms
+      findMonoThms (e.instantiate1 f)
+    trace[Elab.Tactic.monotonicity] "Found monoThms: {monoThms.map MessageData.ofConstName}"
+    for monoThm in monoThms do
+      let new_goals? ← try
+        let new_goals ← applyConst goal monoThm
+        trace[Elab.Tactic.monotonicity] "Succeeded with {.ofConstName monoThm}"
+        pure (some new_goals)
+      catch e =>
+        trace[Elab.Tactic.monotonicity] "{e.toMessageData}"
+        pure none
+      if let some new_goals := new_goals? then
+        return new_goals
+
+    -- Split match-expressions
+    if let some info := isMatcherAppCore? (← getEnv) e then
+      let candidate ← id do
+        let args := e.getAppArgs
+        for i in [info.getFirstDiscrPos : info.getFirstDiscrPos + info.numDiscrs] do
+          if args[i]!.hasLooseBVars then
+            return false
+        return true
+      if candidate then
+        -- We could be even more deliberate here and use the `lifter` lemmas
+        -- for the match statements instead of the `split` tactic.
+        -- For now using `splitMatch` works fine.
+        return ← Split.splitMatch goal e
+
+    failK f monoThms
+  | _ =>
+    throwError "Unexpected goal:{goal}"
+
+partial def solveMono (failK : ∀ {α}, Expr → Array Name → MetaM α := defaultFailK) (goal : MVarId) : MetaM Unit := do
+  let new_goals ← solveMonoStep failK goal
+  new_goals.forM (solveMono failK)
+
+open Elab Tactic in
+@[builtin_tactic Lean.Order.monotonicity]
+def evalMonotonicity : Tactic := fun _stx =>
+  liftMetaTactic Lean.Meta.Monotonicity.solveMonoStep
+
+end Lean.Meta.Monotonicity
+
+builtin_initialize Lean.registerTraceClass `Elab.Tactic.monotonicity

src/Lean/Elab/Tactic/NormCast.lean

@@ -63,7 +63,7 @@ def isNumeral? (e : Expr) : Option (Expr × Nat) :=
   if e.isConstOf ``Nat.zero then
     (mkConst ``Nat, 0)
   else if let Expr.app (Expr.app (Expr.app (Expr.const ``OfNat.ofNat ..) α ..)
-      (Expr.lit (Literal.natVal n) ..) ..) .. := e then
+      (Expr.lit (Literal.natVal n) ..) ..) .. := e.consumeMData then
     some (α, n)
   else
     none

src/Lean/Expr.lean

@@ -769,6 +769,11 @@ opaque quickLt (a : @& Expr) (b : @& Expr) : Bool
 @[extern "lean_expr_lt"]
 opaque lt (a : @& Expr) (b : @& Expr) : Bool
 
+def quickComp (a b : Expr) : Ordering :=
+  if quickLt a b then .lt
+  else if quickLt b a then .gt
+  else .eq
+
 /--
 Return true iff `a` and `b` are alpha equivalent.
 Binder annotations are ignored.
@@ -1643,6 +1648,23 @@ def isFalse (e : Expr) : Bool :=
 def isTrue (e : Expr) : Bool :=
   e.cleanupAnnotations.isConstOf ``True
 
+/--
+`getForallArity type` returns the arity of a `forall`-type. This function consumes nested annotations,
+and performs pending beta reductions. It does **not** use whnf.
+Examples:
+- If `a` is `Nat`, `getForallArity a` returns `0`
+- If `a` is `Nat → Bool`, `getForallArity a` returns `1`
+-/
+partial def getForallArity : Expr → Nat
+  | .mdata _ b       => getForallArity b
+  | .forallE _ _ b _ => getForallArity b + 1
+  | e                =>
+    if e.isHeadBetaTarget then
+      getForallArity e.headBeta
+    else
+      let e' := e.cleanupAnnotations
+      if e != e' then getForallArity e' else 0
+
 /--
 Checks if an expression is a "natural number numeral in normal form",
 i.e. of type `Nat`, and explicitly of the form `OfNat.ofNat n`

src/Lean/Linter/MissingDocs.lean

@@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Mario Carneiro
 -/
 prelude
+import Lean.Parser.Syntax
 import Lean.Meta.Tactic.Simp.RegisterCommand
 import Lean.Elab.Command
 import Lean.Elab.SetOption

src/Lean/Meta/AppBuilder.lean

@@ -176,6 +176,14 @@ def mkEqOfHEq (h : Expr) : MetaM Expr := do
   | _ =>
     throwAppBuilderException ``eq_of_heq m!"heterogeneous equality proof expected{indentExpr h}"
 
+/-- Given `h : Eq a b`, returns a proof of `HEq a b`. -/
+def mkHEqOfEq (h : Expr) : MetaM Expr := do
+  let hType ← infer h
+  let some (α, a, b) := hType.eq?
+    | throwAppBuilderException ``heq_of_eq m!"equality proof expected{indentExpr h}"
+  let u ← getLevel α
+  return mkApp4 (mkConst ``heq_of_eq [u]) α a b h
+
 /--
 If `e` is `@Eq.refl α a`, return `a`.
 -/

src/Lean/Meta/Check.lean

@@ -17,14 +17,6 @@ namespace Lean.Meta
 private def ensureType (e : Expr) : MetaM Unit := do
   discard <| getLevel e
 
-def throwLetTypeMismatchMessage {α} (fvarId : FVarId) : MetaM α := do
-  let lctx ← getLCtx
-  match lctx.find? fvarId with
-  | some (LocalDecl.ldecl _ _ _ t v _ _) => do
-    let vType ← inferType v
-    throwError "invalid let declaration, term{indentExpr v}\nhas type{indentExpr vType}\nbut is expected to have type{indentExpr t}"
-  | _ => unreachable!
-
 private def checkConstant (constName : Name) (us : List Level) : MetaM Unit := do
   let cinfo ← getConstInfo constName
   unless us.length == cinfo.levelParams.length do
@@ -177,6 +169,15 @@ where
     catch _ =>
       return (a, b)
 
+def throwLetTypeMismatchMessage {α} (fvarId : FVarId) : MetaM α := do
+  let lctx ← getLCtx
+  match lctx.find? fvarId with
+  | some (LocalDecl.ldecl _ _ _ t v _ _) => do
+    let vType ← inferType v
+    let (vType, t) ← addPPExplicitToExposeDiff vType t
+    throwError "invalid let declaration, term{indentExpr v}\nhas type{indentExpr vType}\nbut is expected to have type{indentExpr t}"
+  | _ => unreachable!
+
 /--
   Return error message "has type{givenType}\nbut is expected to have type{expectedType}"
 -/

src/Lean/Meta/ExprDefEq.lean

@@ -167,7 +167,7 @@ def isDefEqStringLit (s t : Expr) : MetaM LBool := do
   Remark: `n` may be 0. -/
 def isEtaUnassignedMVar (e : Expr) : MetaM Bool := do
   match e.etaExpanded? with
-  | some (Expr.mvar mvarId) =>
+  | some (.mvar mvarId) =>
     if (← mvarId.isReadOnlyOrSyntheticOpaque) then
       pure false
     else if (← mvarId.isAssigned) then
@@ -361,9 +361,9 @@ private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr)
     let fvars  := fvars.push (mkFVar fvarId)
     isDefEqBindingAux lctx fvars b₁ b₂ (ds₂.push d₂)
   match e₁, e₂ with
-  | Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
-  | Expr.lam     n d₁ b₁ _, Expr.lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
-  | _,                      _                      =>
+  | .forallE n d₁ b₁ _, .forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
+  | .lam     n d₁ b₁ _, .lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
+  | _,                  _                  =>
     withLCtx' lctx do
       isDefEqBindingDomain fvars ds₂ do
         Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)
@@ -1037,13 +1037,13 @@ def checkedAssignImpl (mvarId : MVarId) (val : Expr) : MetaM Bool := do
 
 private def processAssignmentFOApproxAux (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
   match v with
-  | .mdata _ e   => processAssignmentFOApproxAux mvar args e
-  | Expr.app f a =>
+  | .mdata _ e => processAssignmentFOApproxAux mvar args e
+  | .app f a   =>
     if args.isEmpty then
       pure false
     else
       Meta.isExprDefEqAux args.back! a <&&> Meta.isExprDefEqAux (mkAppRange mvar 0 (args.size - 1) args) f
-  | _            => pure false
+  | _ => pure false
 
 /--
   Auxiliary method for applying first-order unification. It is an approximation.
@@ -1177,7 +1177,7 @@ private partial def processAssignment (mvarApp : Expr) (v : Expr) : MetaM Bool :
         let arg ← simpAssignmentArg arg
         let args := args.set i arg
         match arg with
-        | Expr.fvar fvarId =>
+        | .fvar fvarId =>
           if args[0:i].any fun prevArg => prevArg == arg then
             useFOApprox args
           else if mvarDecl.lctx.contains fvarId && !cfg.quasiPatternApprox then
@@ -1233,7 +1233,7 @@ private def processAssignment' (mvarApp : Expr) (v : Expr) : MetaM Bool := do
 
 private def isDeltaCandidate? (t : Expr) : MetaM (Option ConstantInfo) := do
   match t.getAppFn with
-  | Expr.const c _ =>
+  | .const c _ =>
     match (← getUnfoldableConst? c) with
     | r@(some info) => if info.hasValue then return r else return none
     | _             => return none
@@ -1375,8 +1375,8 @@ private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
 
 private def sameHeadSymbol (t s : Expr) : Bool :=
   match t.getAppFn, s.getAppFn with
-  | Expr.const c₁ _, Expr.const c₂ _ => c₁ == c₂
-  | _,               _               => false
+  | .const c₁ _, .const c₂ _ => c₁ == c₂
+  | _,           _           => false
 
 /--
   - If headSymbol (unfold t) == headSymbol s, then unfold t
@@ -1521,8 +1521,8 @@ private def isDefEqDelta (t s : Expr) : MetaM LBool := do
       unfoldNonProjFnDefEq tInfo sInfo t s
 
 private def isAssigned : Expr → MetaM Bool
-  | Expr.mvar mvarId => mvarId.isAssigned
-  | _                => pure false
+  | .mvar mvarId => mvarId.isAssigned
+  | _            => pure false
 
 private def expandDelayedAssigned? (t : Expr) : MetaM (Option Expr) := do
   let tFn := t.getAppFn
@@ -1647,8 +1647,8 @@ private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
   | .sort u,       .sort v     => toLBoolM <| isLevelDefEqAux u v
   | .lam ..,       .lam ..     => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
   | .forallE ..,   .forallE .. => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
-  -- | Expr.mdata _ t _,    s                   => isDefEqQuick t s
-  -- | t,                   Expr.mdata _ s _    => isDefEqQuick t s
+  -- | .mdata _ t _, s               => isDefEqQuick t s
+  -- | t,            .mdata _ s _    => isDefEqQuick t s
   | .fvar fvarId₁, .fvar fvarId₂ => do
     if fvarId₁ == fvarId₂ then
       return .true

src/Lean/Meta/Tactic/Cases.lean

@@ -66,30 +66,31 @@ structure GeneralizeIndicesSubgoal where
   numEqs         : Nat
 
 /--
-  Similar to `generalizeTargets` but customized for the `casesOn` motive.
-  Given a metavariable `mvarId` representing the
-  ```
-  Ctx, h : I A j, D |- T
-  ```
-  where `fvarId` is `h`s id, and the type `I A j` is an inductive datatype where `A` are parameters,
-  and `j` the indices. Generate the goal
-  ```
-  Ctx, h : I A j, D, j' : J, h' : I A j' |- j == j' -> h == h' -> T
-  ```
-  Remark: `(j == j' -> h == h')` is a "telescopic" equality.
-  Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
-  The result contains the fields
-  - `mvarId`: the new goal
-  - `indicesFVarIds`: `j'` ids
-  - `fvarId`: `h'` id
-  - `numEqs`: number of equations in the target -/
-def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndicesSubgoal :=
+Given a metavariable `mvarId` representing the goal
+```
+Ctx |- T
+```
+and an expression `e : I A j`, where `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, j' : J, h' : I A j' |- j == j' -> e == h' -> T
+```
+Remark: `(j == j' -> e == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target
+
+If `varName?` is not none, it is used to name `h'`.
+-/
+def generalizeIndices' (mvarId : MVarId) (e : Expr) (varName? : Option Name := none) : MetaM GeneralizeIndicesSubgoal :=
   mvarId.withContext do
     let lctx       ← getLCtx
     let localInsts ← getLocalInstances
     mvarId.checkNotAssigned `generalizeIndices
-    let fvarDecl ← fvarId.getDecl
-    let type ← whnf fvarDecl.type
+    let type ← whnfD (← inferType e)
     type.withApp fun f args => matchConstInduct f (fun _ => throwTacticEx `generalizeIndices mvarId "inductive type expected") fun val _ => do
       unless val.numIndices > 0 do throwTacticEx `generalizeIndices mvarId "indexed inductive type expected"
       unless args.size == val.numIndices + val.numParams do throwTacticEx `generalizeIndices mvarId "ill-formed inductive datatype"
@@ -98,9 +99,10 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
       let IAType ← inferType IA
       forallTelescopeReducing IAType fun newIndices _ => do
       let newType := mkAppN IA newIndices
-      withLocalDeclD fvarDecl.userName newType fun h' =>
+      let varName ← if let some varName := varName? then pure varName else mkFreshUserName `x
+      withLocalDeclD varName newType fun h' =>
       withNewEqs indices newIndices fun newEqs newRefls => do
-      let (newEqType, newRefl) ← mkEqAndProof fvarDecl.toExpr h'
+      let (newEqType, newRefl) ← mkEqAndProof e h'
       let newRefls := newRefls.push newRefl
       withLocalDeclD `h newEqType fun newEq => do
       let newEqs := newEqs.push newEq
@@ -112,7 +114,7 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
       let auxType ← mkForallFVars newIndices auxType
       let newMVar ← mkFreshExprMVarAt lctx localInsts auxType MetavarKind.syntheticOpaque tag
       /- assign mvarId := newMVar indices h refls -/
-      mvarId.assign (mkAppN (mkApp (mkAppN newMVar indices) fvarDecl.toExpr) newRefls)
+      mvarId.assign (mkAppN (mkApp (mkAppN newMVar indices) e) newRefls)
       let (indicesFVarIds, newMVarId) ← newMVar.mvarId!.introNP newIndices.size
       let (fvarId, newMVarId) ← newMVarId.intro1P
       return {
@@ -122,6 +124,29 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
         numEqs         := newEqs.size
       }
 
+/--
+Similar to `generalizeTargets` but customized for the `casesOn` motive.
+Given a metavariable `mvarId` representing the
+```
+Ctx, h : I A j, D |- T
+```
+where `fvarId` is `h`s id, and the type `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, h : I A j, D, j' : J, h' : I A j' |- j == j' -> h == h' -> T
+```
+Remark: `(j == j' -> h == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target -/
+def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndicesSubgoal :=
+  mvarId.withContext do
+    let fvarDecl ← fvarId.getDecl
+    generalizeIndices' mvarId fvarDecl.toExpr fvarDecl.userName
+
 structure CasesSubgoal extends InductionSubgoal where
   ctorName : Name
 

src/Lean/Meta/Tactic/Grind.lean

@@ -7,19 +7,46 @@ prelude
 import Lean.Meta.Tactic.Grind.Attr
 import Lean.Meta.Tactic.Grind.RevertAll
 import Lean.Meta.Tactic.Grind.Types
-import Lean.Meta.Tactic.Grind.Preprocessor
 import Lean.Meta.Tactic.Grind.Util
 import Lean.Meta.Tactic.Grind.Cases
 import Lean.Meta.Tactic.Grind.Injection
 import Lean.Meta.Tactic.Grind.Core
+import Lean.Meta.Tactic.Grind.Canon
+import Lean.Meta.Tactic.Grind.MarkNestedProofs
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.Proof
+import Lean.Meta.Tactic.Grind.Propagate
+import Lean.Meta.Tactic.Grind.PP
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Ctor
+import Lean.Meta.Tactic.Grind.Parser
+import Lean.Meta.Tactic.Grind.EMatchTheorem
+import Lean.Meta.Tactic.Grind.EMatch
+import Lean.Meta.Tactic.Grind.Main
+
 
 namespace Lean
 
+/-! Trace options for `grind` users -/
 builtin_initialize registerTraceClass `grind
-builtin_initialize registerTraceClass `grind.eq
+builtin_initialize registerTraceClass `grind.assert
+builtin_initialize registerTraceClass `grind.eqc
+builtin_initialize registerTraceClass `grind.internalize
+builtin_initialize registerTraceClass `grind.ematch
+builtin_initialize registerTraceClass `grind.ematch.pattern
+builtin_initialize registerTraceClass `grind.ematch.instance
+builtin_initialize registerTraceClass `grind.ematch.instance.assignment
 builtin_initialize registerTraceClass `grind.issues
-builtin_initialize registerTraceClass `grind.add
-builtin_initialize registerTraceClass `grind.pre
+builtin_initialize registerTraceClass `grind.simp
+
+/-! Trace options for `grind` developers -/
 builtin_initialize registerTraceClass `grind.debug
+builtin_initialize registerTraceClass `grind.debug.proofs
+builtin_initialize registerTraceClass `grind.debug.congr
+builtin_initialize registerTraceClass `grind.debug.proof
+builtin_initialize registerTraceClass `grind.debug.proj
+builtin_initialize registerTraceClass `grind.debug.parent
+builtin_initialize registerTraceClass `grind.debug.final
+builtin_initialize registerTraceClass `grind.debug.forallPropagator
 
 end Lean

src/Lean/Meta/Tactic/Grind/Canon.lean

@@ -0,0 +1,159 @@
+/-
+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.Grind.Util
+import Lean.Meta.Basic
+import Lean.Meta.FunInfo
+import Lean.Util.FVarSubset
+import Lean.Util.PtrSet
+import Lean.Util.FVarSubset
+
+namespace Lean.Meta.Grind
+namespace Canon
+
+/-!
+A canonicalizer module for the `grind` tactic. The canonicalizer defined in `Meta/Canonicalizer.lean` is
+not suitable for the `grind` tactic. It was designed for tactics such as `omega`, where the goal is
+to detect when two structurally different atoms are definitionally equal.
+
+The `grind` tactic, on the other hand, uses congruence closure. Moreover, types, type formers, proofs, and instances
+are considered supporting elements and are not factored into congruence detection.
+
+This module minimizes the number of `isDefEq` checks by comparing two terms `a` and `b` only if they instances,
+types, or type formers and are the `i`-th arguments of two different `f`-applications. This approach is
+sufficient for the congruence closure procedure used by the `grind` tactic.
+
+To further optimize `isDefEq` checks, instances are compared using `TransparencyMode.instances`, which reduces
+the number of constants that need to be unfolded. If diagnostics are enabled, instances are compared using
+the default transparency mode too for sanity checking, and discrepancies are reported.
+Types and type formers are always checked using default transparency.
+
+Remark:
+The canonicalizer minimizes issues with non-canonical instances and structurally different but definitionally equal types,
+but it does not solve all problems. For example, consider a situation where we have `(a : BitVec n)`
+and `(b : BitVec m)`, along with instances `inst1 n : Add (BitVec n)` and `inst2 m : Add (BitVec m)` where `inst1`
+and `inst2` are structurally different. Now consider the terms `a + a` and `b + b`. After canonicalization, the two
+additions will still use structurally different (and definitionally different) instances: `inst1 n` and `inst2 m`.
+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`.
+-/
+
+structure State where
+  argMap     : PHashMap (Expr × Nat) (List Expr) := {}
+  canon      : PHashMap Expr Expr := {}
+  proofCanon : PHashMap Expr Expr := {}
+  deriving Inhabited
+
+/--
+Helper function for canonicalizing `e` occurring as the `i`th argument of an `f`-application.
+`isInst` is true if `e` is an type class instance.
+
+Recall that we use `TransparencyMode.instances` for checking whether two instances are definitionally equal or not.
+Thus, if diagnostics are enabled, we also check them using `TransparencyMode.default`. If the result is different
+we report to the user.
+-/
+def canonElemCore (f : Expr) (i : Nat) (e : Expr) (isInst : Bool) : StateT State MetaM Expr := do
+  let s ← get
+  if let some c := s.canon.find? e then
+    return c
+  let key := (f, i)
+  let cs := s.argMap.find? key |>.getD []
+  for c in cs do
+    if (← isDefEq e c) then
+      -- 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.
+      modify fun s => { s with canon := s.canon.insert e c }
+      return c
+    if isInst then
+      if (← isDiagnosticsEnabled <&&> pure (c.fvarsSubset e) <&&> (withDefault <| isDefEq e c)) then
+        -- TODO: consider storing this information in some structure that can be browsed later.
+        trace[grind.issues] "the following `grind` static elements are definitionally equal with `default` transparency, but not with `instances` transparency{indentExpr e}\nand{indentExpr c}"
+  modify fun s => { s with canon := s.canon.insert e e, argMap := s.argMap.insert key (e::cs) }
+  return e
+
+abbrev canonType (f : Expr) (i : Nat) (e : Expr) := withDefault <| canonElemCore f i e false
+abbrev canonInst (f : Expr) (i : Nat) (e : Expr) := withReducibleAndInstances <| canonElemCore f i e true
+
+/--
+Return type for the `shouldCanon` function.
+-/
+private inductive ShouldCanonResult where
+  | /- Nested types (and type formers) are canonicalized. -/
+    canonType
+  | /- Nested instances are canonicalized. -/
+    canonInst
+  | /-
+    Term is not a proof, type (former), nor an instance.
+    Thus, it must be recursively visited by the canonizer.
+    -/
+    visit
+  deriving Inhabited
+
+/--
+See comments at `ShouldCanonResult`.
+-/
+def shouldCanon (pinfos : Array ParamInfo) (i : Nat) (arg : Expr) : MetaM ShouldCanonResult := do
+  if h : i < pinfos.size then
+    let pinfo := pinfos[i]
+    if pinfo.isInstImplicit then
+      return .canonInst
+    else if pinfo.isProp then
+      return .visit
+  if (← isTypeFormer arg) then
+    return .canonType
+  else
+    return .visit
+
+unsafe def canonImpl (e : Expr) : StateT State MetaM Expr := do
+  visit e |>.run' mkPtrMap
+where
+  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
+      return r
+    let e' ← match e with
+      | .app .. => e.withApp fun f args => do
+        if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
+          let prop := args[0]!
+          let prop' ← visit prop
+          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')
+            modifyThe State fun s => { s with proofCanon := s.proofCanon.insert prop' e' }
+            pure e'
+        else
+          let pinfos := (← getFunInfo f).paramInfo
+          let mut modified := false
+          let mut args := args
+          for i in [:args.size] do
+            let arg := args[i]!
+            let arg' ← match (← shouldCanon pinfos i arg) with
+            | .canonType  => canonType f i arg
+            | .canonInst  => canonInst f i arg
+            | .visit      => visit arg
+            unless ptrEq arg arg' do
+              args := args.set! i arg'
+              modified := true
+          pure <| if modified then mkAppN f args else e
+      | .forallE _ d b _ =>
+        -- Recall that we have `ForallProp.lean`.
+        let d' ← visit d
+        -- Remark: users may not want to convert `p → q` into `¬p ∨ q`
+        let b' ← if b.hasLooseBVars then pure b else visit b
+        pure <| e.updateForallE! d' b'
+      | _ => unreachable!
+    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 :=
+  unsafe canonImpl e
+
+end Canon
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Cases.lean

@@ -11,28 +11,29 @@ namespace Lean.Meta.Grind
 The `grind` tactic includes an auxiliary `cases` tactic that is not intended for direct use by users.
 This method implements it.
 This tactic is automatically applied when introducing local declarations with a type tagged with `[grind_cases]`.
+It is also used for "case-splitting" on terms during the search.
+
 It differs from the user-facing Lean `cases` tactic in the following ways:
 
 - It avoids unnecessary `revert` and `intro` operations.
 
 - It does not introduce new local declarations for each minor premise. Instead, the `grind` tactic preprocessor is responsible for introducing them.
 
-- It assumes that the major premise (i.e., the parameter `fvarId`) is the latest local declaration in the current goal.
-
 - If the major premise type is an indexed family, auxiliary declarations and (heterogeneous) equalities are introduced.
   However, these equalities are not resolved using `unifyEqs`. Instead, the `grind` tactic employs union-find and
   congruence closure to process these auxiliary equalities. This approach avoids applying substitution to propositions
   that have already been internalized by `grind`.
 -/
-def cases (mvarId : MVarId) (fvarId : FVarId) : MetaM (List MVarId) := mvarId.withContext do
+def cases (mvarId : MVarId) (e : Expr) : MetaM (List MVarId) := mvarId.withContext do
   let tag ← mvarId.getTag
-  let type ← whnf (← fvarId.getType)
+  let type ← whnf (← inferType e)
   let .const declName _ := type.getAppFn | throwInductiveExpected type
   let .inductInfo _ ← getConstInfo declName | throwInductiveExpected type
   let recursorInfo ← mkRecursorInfo (mkCasesOnName declName)
-  let k (mvarId : MVarId) (fvarId : FVarId) (indices : Array Expr) (clearMajor : Bool) : MetaM (List MVarId) := do
-    let recursor ← mkRecursorAppPrefix mvarId `grind.cases fvarId recursorInfo indices
-    let mut recursor := mkApp (mkAppN recursor indices) (mkFVar fvarId)
+  let k (mvarId : MVarId) (fvarId : FVarId) (indices : Array FVarId) : MetaM (List MVarId) := do
+    let indicesExpr := indices.map mkFVar
+    let recursor ← mkRecursorAppPrefix mvarId `grind.cases fvarId recursorInfo indicesExpr
+    let mut recursor := mkApp (mkAppN recursor indicesExpr) (mkFVar fvarId)
     let mut recursorType ← inferType recursor
     let mut mvarIdsNew := #[]
     for _ in [:recursorInfo.numMinors] do
@@ -41,22 +42,22 @@ def cases (mvarId : MVarId) (fvarId : FVarId) : MetaM (List MVarId) := mvarId.wi
       recursorType := recursorTypeNew
       let mvar ← mkFreshExprSyntheticOpaqueMVar targetNew tag
       recursor := mkApp recursor mvar
-      let mvarIdNew ← if clearMajor then
-        mvar.mvarId!.clear fvarId
-      else
-        pure mvar.mvarId!
+      let mvarIdNew ← mvar.mvarId!.tryClearMany (indices.push fvarId)
       mvarIdsNew := mvarIdsNew.push mvarIdNew
     mvarId.assign recursor
     return mvarIdsNew.toList
   if recursorInfo.numIndices > 0 then
-    let s ← generalizeIndices mvarId fvarId
+    let s ← generalizeIndices' mvarId e
     s.mvarId.withContext do
-      k s.mvarId s.fvarId (s.indicesFVarIds.map mkFVar) (clearMajor := false)
+      k s.mvarId s.fvarId s.indicesFVarIds
+  else if let .fvar fvarId := e then
+    k mvarId fvarId #[]
   else
-    let indices ← getMajorTypeIndices mvarId `grind.cases recursorInfo type
-    k mvarId fvarId indices (clearMajor := true)
+    let mvarId ← mvarId.assert (← mkFreshUserName `x) type e
+    let (fvarId, mvarId) ← mvarId.intro1
+    mvarId.withContext do k mvarId fvarId #[]
 where
   throwInductiveExpected {α} (type : Expr) : MetaM α := do
-    throwTacticEx `grind.cases mvarId m!"(non-recursive) inductive type expected at {mkFVar fvarId}{indentExpr type}"
+    throwTacticEx `grind.cases mvarId m!"(non-recursive) inductive type expected at {e}{indentExpr type}"
 
 end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Core.lean

@@ -4,144 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Lean.Meta.Tactic.Grind.Types
+import Init.Grind.Util
 import Lean.Meta.LitValues
+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.Internalize
 
 namespace Lean.Meta.Grind
-/-- Helper function for pretty printing the state for debugging purposes. -/
-def ppENodeRef (e : Expr) : GoalM Format := do
-  let some n ← getENode? e | return "_"
-  return f!"#{n.idx}"
-
-/-- Returns expressions in the given expression equivalence class. -/
-partial def getEqc (e : Expr) : GoalM (List Expr) :=
-  go e e []
-where
-  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
-
-/-- Returns all equivalence classes in the current goal. -/
-partial def getEqcs : GoalM (List (List Expr)) := do
-  let mut r := []
-  for (_, node) in (← get).enodes do
-    if isSameExpr node.root node.self then
-      r := (← getEqc node.self) :: r
-  return r
-
-/-- Helper function for pretty printing the state for debugging purposes. -/
-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
-        ppExpr f
-      else
-        ppENodeRef f
-      let mut r := r
-      for arg in args do
-        r := r ++ " " ++ (← ppENodeRef arg)
-      return r
-  else
-    ppExpr e
-
-/-- Helper function for pretty printing the state for debugging purposes. -/
-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 ++ f!" ↦ {← ppENodeRef n.root}"
-  if n.interpreted then
-    r := r ++ ", [val]"
-  if n.ctor then
-    r := r ++ ", [ctor]"
-  return r
-
-/-- Pretty print goal state for debugging purposes. -/
-def ppState : GoalM Format := do
-  let mut r := f!"Goal:"
-  let nodes := (← get).enodes.toArray.map (·.2)
-  let nodes := nodes.qsort fun a b => a.idx < b.idx
-  for node in nodes do
-    r := r ++ "\n" ++ (← ppENodeDecl node.self)
-  let eqcs ← getEqcs
-  for eqc in eqcs do
-    if eqc.length > 1 then
-      r := r ++ "\n" ++ "{" ++ (Format.joinSep (← eqc.mapM ppENodeRef) ", ") ++  "}"
-  return r
-
-/--
-Returns `true` if `e` is `True`, `False`, or a literal value.
-See `LitValues` for supported literals.
--/
-def isInterpreted (e : Expr) : MetaM Bool := do
-  if e.isTrue || e.isFalse then return true
-  isLitValue e
-
-/--
-Creates an `ENode` for `e` if one does not already exist.
-This method assumes `e` has been hashconsed.
--/
-def mkENode (e : Expr) (generation : Nat) : GoalM Unit := do
-  if (← alreadyInternalized e) then return ()
-  let ctor := (← isConstructorAppCore? e).isSome
-  let interpreted ← isInterpreted e
-  mkENodeCore e interpreted ctor generation
-
-private def pushNewEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit :=
-  modify fun s => { s with newEqs := s.newEqs.push { lhs, rhs, proof, isHEq } }
-
-@[inline] private def pushNewEq (lhs rhs proof : Expr) : GoalM Unit :=
-  pushNewEqCore lhs rhs proof (isHEq := false)
-
-@[inline] private def pushNewHEq (lhs rhs proof : Expr) : GoalM Unit :=
-  pushNewEqCore lhs rhs proof (isHEq := true)
-
-/--
-Adds `e` to congruence table.
--/
-def addCongrTable (_e : Expr) : GoalM Unit := do
-  -- TODO
-  return ()
-
-partial def internalize (e : Expr) (generation : Nat) : GoalM Unit := do
-  if (← alreadyInternalized e) then return ()
-  match e with
-  | .bvar .. => unreachable!
-  | .sort .. => return ()
-  | .fvar .. | .letE .. | .lam .. | .forallE .. =>
-    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
-  | .lit .. | .const .. =>
-    mkENode e generation
-  | .mvar ..
-  | .mdata ..
-  | .proj .. =>
-    trace[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
-    else e.withApp fun f args => do
-      unless f.isConst do
-        internalize f generation
-      let info ← getFunInfo f
-      let shouldInternalize (i : Nat) : GoalM Bool := do
-        if h : i < info.paramInfo.size then
-          let pinfo := info.paramInfo[i]
-          if pinfo.binderInfo.isInstImplicit || pinfo.isProp then
-            return false
-        return true
-      for h : i in [: args.size] do
-        let arg := args[i]
-        if (← shouldInternalize i) then
-          unless (← isTypeFormer arg) do
-            internalize arg generation
-      mkENode e generation
-      addCongrTable e
 
 /--
 The fields `target?` and `proof?` in `e`'s `ENode` are encoding a transitivity proof
@@ -163,39 +34,95 @@ where
       proof?  := proofNew?
     }
 
-private def markAsInconsistent : GoalM Unit :=
-  modify fun s => { s with inconsistent := true }
+/--
+Remove `root` parents from the congruence table.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def removeParents (root : Expr) : GoalM ParentSet := do
+  let parents ← getParentsAndReset root
+  for parent in parents do
+    -- Recall that we may have `Expr.forallE` in `parents` because of `ForallProp.lean`
+    if (← pure parent.isApp <&&> isCongrRoot parent) then
+      trace[grind.debug.parent] "remove: {parent}"
+      modify fun s => { s with congrTable := s.congrTable.erase { e := parent } }
+  return parents
 
-def isInconsistent : GoalM Bool :=
-  return (← get).inconsistent
+/--
+Reinsert parents into the congruence table and detect new equalities.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def reinsertParents (parents : ParentSet) : GoalM Unit := do
+  for parent in parents do
+    if (← pure parent.isApp <&&> isCongrRoot parent) then
+      trace[grind.debug.parent] "reinsert: {parent}"
+      addCongrTable parent
+
+/-- Closes the goal when `True` and `False` are in the same equivalence class. -/
+private def closeGoalWithTrueEqFalse : GoalM Unit := do
+  let mvarId := (← get).mvarId
+  unless (← mvarId.isAssigned) do
+    let trueEqFalse ← mkEqFalseProof (← getTrueExpr)
+    let falseProof ← mkEqMP trueEqFalse (mkConst ``True.intro)
+    closeGoal falseProof
+
+/-- Closes the goal when `lhs` and `rhs` are both literal values and belong to the same equivalence class. -/
+private def closeGoalWithValuesEq (lhs rhs : Expr) : GoalM Unit := do
+  let p ← mkEq lhs rhs
+  let hp ← mkEqProof lhs rhs
+  let d ← mkDecide p
+  let pEqFalse := mkApp3 (mkConst ``eq_false_of_decide) p d.appArg! (mkApp2 (mkConst ``Eq.refl [1]) (mkConst ``Bool) (mkConst ``false))
+  let falseProof ← mkEqMP pEqFalse hp
+  closeGoal falseProof
+
+/--
+Updates the modification time to `gmt` for the parents of `root`.
+The modification time is used to decide which terms are considered during e-matching.
+-/
+private partial def updateMT (root : Expr) : GoalM Unit := do
+  let gmt := (← get).gmt
+  for parent in (← getParents root) do
+    let node ← getENode parent
+    if node.mt < gmt then
+      setENode parent { node with mt := gmt }
+      updateMT parent
 
 private partial def addEqStep (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
-  trace[grind.eq] "{lhs} {if isHEq then "≡" else "="} {rhs}"
   let lhsNode ← getENode lhs
   let rhsNode ← getENode rhs
   if isSameExpr lhsNode.root rhsNode.root then
     -- `lhs` and `rhs` are already in the same equivalence class.
     trace[grind.debug] "{← ppENodeRef lhs} and {← ppENodeRef rhs} are already in the same equivalence class"
     return ()
+  trace[grind.eqc] "{← if isHEq then mkHEq lhs rhs else mkEq lhs rhs}"
   let lhsRoot ← getENode lhsNode.root
   let rhsRoot ← getENode rhsNode.root
+  let mut valueInconsistency := false
+  let mut trueEqFalse := false
+  if lhsRoot.interpreted && rhsRoot.interpreted then
+    if lhsNode.root.isTrue || rhsNode.root.isTrue then
+      markAsInconsistent
+      trueEqFalse := true
+    else
+      valueInconsistency := true
   if    (lhsRoot.interpreted && !rhsRoot.interpreted)
      || (lhsRoot.ctor && !rhsRoot.ctor)
      || (lhsRoot.size > rhsRoot.size && !rhsRoot.interpreted && !rhsRoot.ctor) then
     go rhs lhs rhsNode lhsNode rhsRoot lhsRoot true
   else
     go lhs rhs lhsNode rhsNode lhsRoot rhsRoot false
+  if trueEqFalse then
+    closeGoalWithTrueEqFalse
+  unless (← isInconsistent) do
+    if lhsRoot.ctor && rhsRoot.ctor then
+      propagateCtor lhsRoot.self rhsRoot.self
+  unless (← isInconsistent) do
+    if valueInconsistency then
+      closeGoalWithValuesEq lhsRoot.self rhsRoot.self
   trace[grind.debug] "after addEqStep, {← ppState}"
+  checkInvariants
 where
   go (lhs rhs : Expr) (lhsNode rhsNode lhsRoot rhsRoot : ENode) (flipped : Bool) : GoalM Unit := do
     trace[grind.debug] "adding {← ppENodeRef lhs} ↦ {← ppENodeRef rhs}"
-    let mut valueInconsistency := false
-    if lhsRoot.interpreted && rhsRoot.interpreted then
-      if lhsNode.root.isTrue || rhsNode.root.isTrue then
-        markAsInconsistent
-      else
-        valueInconsistency := true
-    -- TODO: process valueInconsistency := true
     /-
     We have the following `target?/proof?`
     `lhs -> ... -> lhsNode.root`
@@ -210,14 +137,12 @@ where
       proof?  := proof
       flipped
     }
-    -- TODO: Remove parents from congruence table
-    -- TODO: set propagateBool
-    updateRoots lhs rhsNode.root true -- TODO
+    let parents ← removeParents lhsRoot.self
+    updateRoots lhs rhsNode.root
     trace[grind.debug] "{← ppENodeRef lhs} new root {← ppENodeRef rhsNode.root}, {← ppENodeRef (← getRoot lhs)}"
-    -- TODO: Reinsert parents into congruence table
-    setENode lhsNode.root { lhsRoot with
+    reinsertParents parents
+    setENode lhsNode.root { (← getENode lhsRoot.self) with -- We must retrieve `lhsRoot` since it was updated.
       next := rhsRoot.next
-      root := rhsNode.root
     }
     setENode rhsNode.root { rhsRoot with
       next := lhsRoot.next
@@ -225,22 +150,35 @@ where
       hasLambdas := rhsRoot.hasLambdas || lhsRoot.hasLambdas
       heqProofs  := isHEq || rhsRoot.heqProofs || lhsRoot.heqProofs
     }
-    -- TODO: copy parentst from lhsRoot parents to rhsRoot parents
+    copyParentsTo parents rhsNode.root
+    unless (← isInconsistent) do
+      for parent in parents do
+        propagateUp parent
+    unless (← isInconsistent) do
+      updateMT rhsRoot.self
 
-  updateRoots (lhs : Expr) (rootNew : Expr) (_propagateBool : Bool) : GoalM Unit := do
+  updateRoots (lhs : Expr) (rootNew : Expr) : GoalM Unit := do
     let rec loop (e : Expr) : GoalM Unit := do
-      -- TODO: propagateBool
       let n ← getENode e
       setENode e { n with root := rootNew }
+      unless (← isInconsistent) do
+        propagateDown e
       if isSameExpr lhs n.next then return ()
       loop n.next
     loop lhs
 
 /-- Ensures collection of equations to be processed is empty. -/
-def resetNewEqs : GoalM Unit :=
+private def resetNewEqs : GoalM Unit :=
   modify fun s => { s with newEqs := #[] }
 
-partial def addEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
+/-- Pops and returns the next equality to be processed. -/
+private def popNextEq? : GoalM (Option NewEq) := do
+  let r := (← get).newEqs.back?
+  if r.isSome then
+    modify fun s => { s with newEqs := s.newEqs.pop }
+  return r
+
+private partial def addEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
   addEqStep lhs rhs proof isHEq
   processTodo
 where
@@ -248,21 +186,29 @@ where
     if (← isInconsistent) then
       resetNewEqs
       return ()
-    let some { lhs, rhs, proof, isHEq } := (← get).newEqs.back? | return ()
+    checkSystem "grind"
+    let some { lhs, rhs, proof, isHEq } := (← popNextEq?) | return ()
     addEqStep lhs rhs proof isHEq
     processTodo
 
+/-- Adds a new equality `lhs = rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
 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. -/
 def addHEq (lhs rhs proof : Expr) : GoalM Unit := do
   addEqCore lhs rhs proof true
 
-/--
-Adds a new `fact` justified by the given proof and using the given generation.
--/
+/-- Internalizes `lhs` and `rhs`, and then adds equality `lhs = rhs`. -/
+def addNewEq (lhs rhs proof : Expr) (generation : Nat) : GoalM Unit := do
+  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
-  trace[grind.add] "{proof} : {fact}"
+  trace[grind.assert] "{fact}"
   if (← isInconsistent) then return ()
   resetNewEqs
   let_expr Not p := fact
@@ -270,10 +216,9 @@ def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
   go p true
 where
   go (p : Expr) (isNeg : Bool) : GoalM Unit := do
-    trace[grind.add] "isNeg: {isNeg}, {p}"
     match_expr p with
     | Eq _ lhs rhs => goEq p lhs rhs isNeg false
-    | HEq _ _ lhs rhs => goEq p lhs rhs isNeg true
+    | HEq _ lhs _ rhs => goEq p lhs rhs isNeg true
     | _ =>
       internalize p generation
       if isNeg then
@@ -290,10 +235,8 @@ where
       internalize rhs generation
       addEqCore lhs rhs proof isHEq
 
-/--
-Adds a new hypothesis.
--/
-def addHyp (fvarId : FVarId) (generation := 0) : GoalM Unit := do
+/-- Adds a new hypothesis. -/
+def addHypothesis (fvarId : FVarId) (generation := 0) : GoalM Unit := do
   add (← fvarId.getType) (mkFVar fvarId) generation
 
 end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Ctor.lean

@@ -0,0 +1,49 @@
+/-
+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 Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+private partial def propagateInjEqs (eqs : Expr) (proof : Expr) : GoalM Unit := do
+  match_expr eqs with
+  | And left right =>
+    propagateInjEqs left (.proj ``And 0 proof)
+    propagateInjEqs right (.proj ``And 1 proof)
+  | Eq _ lhs rhs    => pushEq lhs rhs proof
+  | HEq _ lhs _ rhs => pushHEq lhs rhs proof
+  | _ =>
+   trace[grind.issues] "unexpected injectivity theorem result type{indentExpr eqs}"
+   return ()
+
+/--
+Given constructors `a` and `b`, propagate equalities if they are the same,
+and close goal if they are different.
+-/
+def propagateCtor (a b : Expr) : GoalM Unit := do
+  let aType ← whnfD (← inferType a)
+  let bType ← whnfD (← inferType b)
+  unless (← withDefault <| isDefEq aType bType) do
+    return ()
+  let ctor₁ := a.getAppFn
+  let ctor₂ := b.getAppFn
+  if ctor₁ == ctor₂ then
+    let .const ctorName _ := a.getAppFn | return ()
+    let injDeclName := Name.mkStr ctorName "inj"
+    unless (← getEnv).contains injDeclName do return ()
+    let info ← getConstInfo injDeclName
+    let n := info.type.getForallArity
+    let mask : Array (Option Expr) := mkArray n none
+    let mask := mask.set! (n-1) (some (← mkEqProof a b))
+    let injLemma ← mkAppOptM injDeclName mask
+    propagateInjEqs (← inferType injLemma) injLemma
+  else
+    let .const declName _ := aType.getAppFn | return ()
+    let noConfusionDeclName := Name.mkStr declName "noConfusion"
+    unless (← getEnv).contains noConfusionDeclName do return ()
+    closeGoal (← mkNoConfusion (← getFalseExpr) (← mkEqProof a b))
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/DoNotSimp.lean

@@ -0,0 +1,35 @@
+/-
+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.Util
+import Init.Simproc
+import Lean.Meta.Tactic.Simp.Simproc
+
+namespace Lean.Meta.Grind
+
+/--
+Returns `Grind.doNotSimp e`.
+Recall that `Grind.doNotSimp` is an identity function, but the following simproc is used to prevent the term `e` from being simplified.
+-/
+def markAsDoNotSimp (e : Expr) : MetaM Expr :=
+  mkAppM ``Grind.doNotSimp #[e]
+
+builtin_dsimproc_decl reduceDoNotSimp (Grind.doNotSimp _) := fun e => do
+  let_expr Grind.doNotSimp _ _ ← e | return .continue
+  return .done e
+
+/-- Adds `reduceDoNotSimp` to `s` -/
+def addDoNotSimp (s : Simprocs) : CoreM Simprocs := do
+  s.add ``reduceDoNotSimp (post := false)
+
+/-- Erases `Grind.doNotSimp` annotations. -/
+def eraseDoNotSimp (e : Expr) : CoreM Expr := do
+  let pre (e : Expr) := do
+    let_expr Grind.doNotSimp _ a := e | return .continue e
+    return .continue a
+  Core.transform e (pre := pre)
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/EMatch.lean

@@ -0,0 +1,351 @@
+/-
+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 Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Intro
+import Lean.Meta.Tactic.Grind.DoNotSimp
+
+namespace Lean.Meta.Grind
+namespace EMatch
+/-! This module implements a simple E-matching procedure as a backtracking search. -/
+
+/-- We represent an `E-matching` problem as a list of constraints. -/
+inductive Cnstr where
+  | /-- Matches pattern `pat` with term `e` -/
+    «match» (pat : Expr) (e : Expr)
+  | /-- Matches offset pattern `pat+k` with term `e` -/
+    offset (pat : Expr) (k : Nat) (e : Expr)
+  | /-- This constraint is used to encode multi-patterns. -/
+    «continue» (pat : Expr)
+  deriving Inhabited
+
+/--
+Internal "marker" for representing unassigned elemens in the `assignment` field.
+This is a small hack to avoid one extra level of indirection by using `Option Expr` at `assignment`.
+-/
+private def unassigned : Expr := mkConst (Name.mkSimple "[grind_unassigned]")
+
+private def assignmentToMessageData (assignment : Array Expr) : Array MessageData :=
+  assignment.reverse.map fun e =>
+    if isSameExpr e unassigned then m!"_" else m!"{e}"
+
+/--
+Choice point for the backtracking search.
+The state of the procedure contains a stack of choices.
+-/
+structure Choice where
+  /-- Contraints to be processed. -/
+  cnstrs     : List Cnstr
+  /-- Maximum term generation found so far. -/
+  gen        : Nat
+  /-- Partial assignment so far. Recall that pattern variables are encoded as de-Bruijn variables. -/
+  assignment : Array Expr
+  deriving Inhabited
+
+/-- Context for the E-matching monad. -/
+structure Context where
+  /-- `useMT` is `true` if we are using the mod-time optimization. It is always set to false for new `EMatchTheorem`s. -/
+  useMT : Bool := true
+  /-- `EMatchTheorem` being processed. -/
+  thm   : EMatchTheorem := default
+  deriving Inhabited
+
+/-- State for the E-matching monad -/
+structure State where
+  /-- Choices that still have to be processed. -/
+  choiceStack  : List Choice := []
+  deriving Inhabited
+
+abbrev M := ReaderT Context $ StateRefT State GoalM
+
+def M.run' (x : M α) : GoalM α :=
+  x {} |>.run' {}
+
+/--
+Assigns `bidx := e` in `c`. If `bidx` is already assigned in `c`, we check whether
+`e` and `c.assignment[bidx]` are in the same equivalence class.
+This function assumes `bidx < c.assignment.size`.
+Recall that we initialize the assignment array with the number of theorem parameters.
+-/
+private def assign? (c : Choice) (bidx : Nat) (e : Expr) : OptionT GoalM Choice := do
+  if h : bidx < c.assignment.size then
+    let v := c.assignment[bidx]
+    if isSameExpr v unassigned then
+      return { c with assignment := c.assignment.set bidx e }
+    else
+      guard (← isEqv v e)
+      return c
+  else
+    -- `Choice` was not properly initialized
+    unreachable!
+
+/--
+Returns `true` if the function `pFn` of a pattern is equivalent to the function `eFn`.
+Recall that we ignore universe levels in patterns.
+-/
+private def eqvFunctions (pFn eFn : Expr) : Bool :=
+  (pFn.isFVar && pFn == eFn)
+  || (pFn.isConst && eFn.isConstOf pFn.constName!)
+
+/-- Matches a pattern argument. See `matchArgs?`. -/
+private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM Choice := do
+  if isPatternDontCare pArg then
+    return c
+  else if pArg.isBVar then
+    assign? c pArg.bvarIdx! eArg
+  else if let some pArg := groundPattern? pArg then
+    guard (← isEqv pArg eArg)
+    return c
+  else if let some (pArg, k) := isOffsetPattern? pArg then
+    assert! Option.isNone <| isOffsetPattern? pArg
+    assert! !isPatternDontCare pArg
+    return { c with cnstrs := .offset pArg k eArg :: c.cnstrs }
+  else
+    return { c with cnstrs := .match pArg eArg :: c.cnstrs }
+
+private def Choice.updateGen (c : Choice) (gen : Nat) : Choice :=
+  { c with gen := Nat.max gen c.gen }
+
+private def pushChoice (c : Choice) : M Unit :=
+  modify fun s => { s with choiceStack := c :: s.choiceStack }
+
+/--
+Matches arguments of pattern `p` with term `e`. Returns `some` if successful,
+and `none` otherwise. It may update `c`s assignment and list of contraints to be
+processed.
+-/
+private partial def matchArgs? (c : Choice) (p : Expr) (e : Expr) : OptionT GoalM Choice := do
+  if !p.isApp then return c -- Done
+  let pArg := p.appArg!
+  let eArg := e.appArg!
+  let c ← matchArg? c pArg eArg
+  matchArgs? c p.appFn! e.appFn!
+
+/--
+Matches pattern `p` with term `e` with respect to choice `c`.
+We traverse the equivalence class of `e` looking for applications compatible with `p`.
+For each candidate application, we match the arguments and may update `c`s assignments and contraints.
+We add the updated choices to the choice stack.
+-/
+private partial def processMatch (c : Choice) (p : Expr) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let pFn := p.getAppFn
+  let numArgs := p.getAppNumArgs
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    if n.generation <= maxGeneration
+       -- uses heterogeneous equality or is the root of its congruence class
+       && (n.heqProofs || n.isCongrRoot)
+       && eqvFunctions pFn curr.getAppFn
+       && curr.getAppNumArgs == numArgs then
+      if let some c ← matchArgs? c p curr |>.run then
+        pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/--
+Matches offset pattern `pArg+k` with term `e` with respect to choice `c`.
+-/
+private partial def processOffset (c : Choice) (pArg : Expr) (k : Nat) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    if n.generation <= maxGeneration then
+      if let some (eArg, k') ← isOffset? curr |>.run then
+        if k' < k then
+          let c := c.updateGen n.generation
+          pushChoice { c with cnstrs := .offset pArg (k - k') eArg :: c.cnstrs }
+        else if k' == k then
+          if let some c ← matchArg? c pArg eArg |>.run then
+            pushChoice (c.updateGen n.generation)
+        else if k' > k then
+          let eArg' := mkNatAdd eArg (mkNatLit (k' - k))
+          let eArg' ← shareCommon (← canon eArg')
+          internalize eArg' n.generation
+          if let some c ← matchArg? c pArg eArg' |>.run then
+            pushChoice (c.updateGen n.generation)
+      else if let some k' ← evalNat curr |>.run then
+        if k' >= k then
+          let eArg' := mkNatLit (k' - k)
+          let eArg' ← shareCommon (← canon eArg')
+          internalize eArg' n.generation
+          if let some c ← matchArg? c pArg eArg' |>.run then
+            pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/-- Processes `continue` contraint used to implement multi-patterns. -/
+private def processContinue (c : Choice) (p : Expr) : M Unit := do
+  let some apps := (← getThe Goal).appMap.find? p.toHeadIndex
+    | return ()
+  let maxGeneration ← getMaxGeneration
+  for app in apps do
+    let n ← getENode app
+    if n.generation <= maxGeneration
+       && (n.heqProofs || n.isCongrRoot) 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 }
+
+/-- Helper function for marking parts of `match`-equation theorem as "do-not-simplify" -/
+private partial def annotateMatchEqnType (prop : Expr) : M Expr := do
+  if let .forallE n d b bi := prop then
+    withLocalDecl n bi (← markAsDoNotSimp d) fun x => do
+      mkForallFVars #[x] (← annotateMatchEqnType (b.instantiate1 x))
+  else
+    let_expr f@Eq α lhs rhs := prop | return prop
+    return mkApp3 f α (← markAsDoNotSimp lhs) rhs
+
+/--
+Stores new theorem instance in the state.
+Recall that new instances are internalized later, after a full round of ematching.
+-/
+private def addNewInstance (origin : Origin) (proof : Expr) (generation : Nat) : M Unit := do
+  let proof ← instantiateMVars proof
+  if grind.debug.proofs.get (← getOptions) then
+    check proof
+  let mut prop ← inferType proof
+  if Match.isMatchEqnTheorem (← getEnv) origin.key then
+    prop ← annotateMatchEqnType prop
+  trace[grind.ematch.instance] "{← origin.pp}: {prop}"
+  addTheoremInstance proof prop generation
+
+/--
+After processing a (multi-)pattern, use the choice assignment to instantiate the proof.
+Missing parameters are synthesized using type inference and type class synthesis."
+-/
+private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do withNewMCtxDepth do
+  let thm := (← read).thm
+  unless (← markTheoremInstance thm.proof c.assignment) do
+    return ()
+  trace[grind.ematch.instance.assignment] "{← thm.origin.pp}: {assignmentToMessageData c.assignment}"
+  let proof ← thm.getProofWithFreshMVarLevels
+  let numParams := thm.numParams
+  assert! c.assignment.size == numParams
+  let (mvars, bis, _) ← forallMetaBoundedTelescope (← inferType proof) numParams
+  if mvars.size != thm.numParams then
+    trace[grind.issues] "unexpected number of parameters at {← thm.origin.pp}"
+    return ()
+  -- Apply assignment
+  for h : i in [:mvars.size] do
+    let v := c.assignment[numParams - i - 1]!
+    unless isSameExpr v unassigned do
+      let mvarId := mvars[i].mvarId!
+      unless (← isDefEq (← mvarId.getType) (← inferType v) <&&> mvarId.checkedAssign v) do
+        trace[grind.issues] "type error constructing proof for {← thm.origin.pp}\nwhen assigning metavariable {mvars[i]} with {indentExpr v}"
+        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
+        trace[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
+    addNewInstance thm.origin proof c.gen
+  else
+    let mvars ← mvars.filterM fun mvar => return !(← mvar.mvarId!.isAssigned)
+    if let some mvarBad ← mvars.findM? fun mvar => return !(← isProof mvar) then
+      trace[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
+  synthesizeInstance (x type : Expr) : MetaM Bool := do
+    let .some val ← trySynthInstance type | return false
+    isDefEq x val
+
+/-- Process choice stack until we don't have more choices to be processed. -/
+private partial def processChoices : M Unit := do
+  unless (← get).choiceStack.isEmpty do
+    checkSystem "ematch"
+    if (← checkMaxInstancesExceeded) then return ()
+    let c ← modifyGet fun s : State => (s.choiceStack.head!, { s with choiceStack := s.choiceStack.tail! })
+    match c.cnstrs with
+    | [] => instantiateTheorem c
+    | .match p e :: cnstrs => processMatch { c with cnstrs } p e
+    | .offset p k e :: cnstrs => processOffset { c with cnstrs } p k e
+    | .continue p :: cnstrs => processContinue { c with cnstrs } p
+    processChoices
+
+private def main (p : Expr) (cnstrs : List Cnstr) : M Unit := do
+  let some apps := (← getThe Goal).appMap.find? p.toHeadIndex
+    | return ()
+  let numParams  := (← read).thm.numParams
+  let assignment := mkArray numParams unassigned
+  let useMT      := (← read).useMT
+  let gmt        := (← getThe Goal).gmt
+  for app in apps do
+    if (← checkMaxInstancesExceeded) then return ()
+    let n ← getENode app
+    if (n.heqProofs || n.isCongrRoot) &&
+       (!useMT || n.mt == gmt) then
+      if let some c ← matchArgs? { cnstrs, assignment, gen := n.generation } p app |>.run then
+        modify fun s => { s with choiceStack := [c] }
+        processChoices
+
+def ematchTheorem (thm : EMatchTheorem) : M Unit := do
+  if (← checkMaxInstancesExceeded) then return ()
+  withReader (fun ctx => { ctx with thm }) do
+    let ps := thm.patterns
+    match ps, (← read).useMT with
+    | [p],   _     => main p []
+    | p::ps, false => main p (ps.map (.continue ·))
+    | _::_,  true  => tryAll ps []
+    | _,     _     => unreachable!
+where
+  /--
+  When using the mod-time optimization with multi-patterns,
+  we must start ematching at each different pattern. That is,
+  if we have `[p₁, p₂, p₃]`, we must execute
+  - `main p₁ [.continue p₂, .continue p₃]`
+  - `main p₂ [.continue p₁, .continue p₃]`
+  - `main p₃ [.continue p₁, .continue p₂]`
+  -/
+  tryAll (ps : List Expr) (cs : List Cnstr) : M Unit := do
+    match ps with
+    | []    => return ()
+    | p::ps =>
+      main p (cs.reverse ++ (ps.map (.continue ·)))
+      tryAll ps (.continue p :: cs)
+
+def ematchTheorems (thms : PArray EMatchTheorem) : M Unit := do
+  thms.forM ematchTheorem
+
+end EMatch
+
+open EMatch
+
+/-- Performs one round of E-matching, and returns new instances. -/
+def ematch : GoalM Unit := do
+  let go (thms newThms : PArray EMatchTheorem) : EMatch.M Unit := do
+    withReader (fun ctx => { ctx with useMT := true }) <| ematchTheorems thms
+    withReader (fun ctx => { ctx with useMT := false }) <| ematchTheorems newThms
+  if (← checkMaxInstancesExceeded) then
+    return ()
+  else
+    go (← get).thms (← get).newThms |>.run'
+    modify fun s => { s with
+      thms         := s.thms ++ s.newThms
+      newThms      := {}
+      gmt          := s.gmt + 1
+    }
+
+/-- Performs one round of E-matching, and assert new instances. -/
+def ematchAndAssert? (goal : Goal) : GrindM (Option (List Goal)) := do
+  let numInstances := goal.numInstances
+  let goal ← GoalM.run' goal ematch
+  if goal.numInstances == numInstances then
+    return none
+  assertAll goal
+
+def ematchStar (goal : Goal) : GrindM (List Goal) := do
+  iterate goal ematchAndAssert?
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/EMatchTheorem.lean

@@ -0,0 +1,454 @@
+/-
+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.Grind.Util
+import Lean.HeadIndex
+import Lean.PrettyPrinter
+import Lean.Util.FoldConsts
+import Lean.Util.CollectFVars
+import Lean.Meta.Basic
+import Lean.Meta.InferType
+import Lean.Meta.Tactic.Grind.Util
+
+namespace Lean.Meta.Grind
+
+def mkOffsetPattern (pat : Expr) (k : Nat) : Expr :=
+  mkApp2 (mkConst ``Grind.offset) pat (mkRawNatLit k)
+
+private def detectOffsets (pat : Expr) : MetaM Expr := do
+  let pre (e : Expr) := do
+    if e == pat then
+      -- We only consider nested offset patterns
+      return .continue e
+    else match e with
+      | .letE .. | .lam .. | .forallE .. => return .done e
+      | _ =>
+        let some (e, k) ← isOffset? e
+          | return .continue e
+        if k == 0 then return .continue e
+        return .continue <| mkOffsetPattern e k
+  Core.transform pat (pre := pre)
+
+def isOffsetPattern? (pat : Expr) : Option (Expr × Nat) := Id.run do
+  let_expr Grind.offset pat k := pat | none
+  let .lit (.natVal k) := k | none
+  return some (pat, k)
+
+def preprocessPattern (pat : Expr) : MetaM Expr := do
+  let pat ← instantiateMVars pat
+  let pat ← unfoldReducible pat
+  let pat ← detectOffsets pat
+  let pat ← foldProjs pat
+  return pat
+
+inductive Origin where
+  /-- A global declaration in the environment. -/
+  | decl (declName : Name)
+  /-- A local hypothesis. -/
+  | fvar (fvarId : FVarId)
+  /--
+  A proof term provided directly to a call to `grind` where `ref`
+  is the provided grind argument. The `id` is a unique identifier for the call.
+  -/
+  | stx (id : Name) (ref : Syntax)
+  | other
+  deriving Inhabited, Repr
+
+/-- A unique identifier corresponding to the origin. -/
+def Origin.key : Origin → Name
+  | .decl declName => declName
+  | .fvar fvarId   => fvarId.name
+  | .stx id _      => id
+  | .other         => `other
+
+def Origin.pp [Monad m] [MonadEnv m] [MonadError m] (o : Origin) : m MessageData := do
+  match o with
+  | .decl declName => return MessageData.ofConst (← mkConstWithLevelParams declName)
+  | .fvar fvarId   => return mkFVar fvarId
+  | .stx _ ref     => return ref
+  | .other         => return "[unknown]"
+
+/-- A theorem for heuristic instantiation based on E-matching. -/
+structure EMatchTheorem where
+  /--
+  It stores universe parameter names for universe polymorphic proofs.
+  Recall that it is non-empty only when we elaborate an expression provided by the user.
+  When `proof` is just a constant, we can use the universe parameter names stored in the declaration.
+  -/
+  levelParams : Array Name
+  proof       : Expr
+  numParams   : Nat
+  patterns    : List Expr
+  /-- Contains all symbols used in `pattterns`. -/
+  symbols     : List HeadIndex
+  origin      : Origin
+  deriving Inhabited
+
+/-- Set of E-matching theorems. -/
+structure EMatchTheorems where
+  /-- The key is a symbol from `EMatchTheorem.symbols`. -/
+  private map : PHashMap Name (List EMatchTheorem) := {}
+  /-- Set of theorem names that have been inserted using `insert`. -/
+  private thmNames : PHashSet Name := {}
+  deriving Inhabited
+
+/--
+Inserts a `thm` with symbols `[s_1, ..., s_n]` to `s`.
+We add `s_1 -> { thm with symbols := [s_2, ..., s_n] }`.
+When `grind` internalizes a term containing symbol `s`, we
+process all theorems `thm` associated with key `s`.
+If their `thm.symbols` is empty, we say they are activated.
+Otherwise, we reinsert into `map`.
+-/
+def EMatchTheorems.insert (s : EMatchTheorems) (thm : EMatchTheorem) : EMatchTheorems := Id.run do
+  let .const declName :: syms := thm.symbols
+    | unreachable!
+  let thm := { thm with symbols := syms }
+  let { map, thmNames } := s
+  let thmNames := thmNames.insert thm.origin.key
+  if let some thms := map.find? declName then
+    return { map := map.insert declName (thm::thms), thmNames }
+  else
+    return { map := map.insert declName [thm], thmNames }
+
+/--
+Retrieves theorems from `s` associated with the given symbol. See `EMatchTheorem.insert`.
+The theorems are removed from `s`.
+-/
+@[inline]
+def EMatchTheorems.retrieve? (s : EMatchTheorems) (sym : Name) : Option (List EMatchTheorem × EMatchTheorems) :=
+  if let some thms := s.map.find? sym then
+    some (thms, { s with map := s.map.erase sym })
+  else
+    none
+
+/-- Returns `true` if `declName` is the name of a theorem that was inserted using `insert`. -/
+def EMatchTheorems.containsTheoremName (s : EMatchTheorems) (declName : Name) : Bool :=
+  s.thmNames.contains declName
+
+def EMatchTheorem.getProofWithFreshMVarLevels (thm : EMatchTheorem) : MetaM Expr := do
+  if thm.proof.isConst && thm.levelParams.isEmpty then
+    let declName := thm.proof.constName!
+    let info ← getConstInfo declName
+    if info.levelParams.isEmpty then
+      return thm.proof
+    else
+      mkConstWithFreshMVarLevels declName
+  else if thm.levelParams.isEmpty then
+    return thm.proof
+  else
+    let us ← thm.levelParams.mapM fun _ => mkFreshLevelMVar
+    return thm.proof.instantiateLevelParamsArray thm.levelParams us
+
+private builtin_initialize ematchTheoremsExt : SimpleScopedEnvExtension EMatchTheorem EMatchTheorems ←
+  registerSimpleScopedEnvExtension {
+    addEntry := EMatchTheorems.insert
+    initial  := {}
+  }
+
+-- TODO: create attribute?
+private def forbiddenDeclNames := #[``Eq, ``HEq, ``Iff, ``And, ``Or, ``Not]
+
+private def isForbidden (declName : Name) := forbiddenDeclNames.contains declName
+
+private def dontCare := mkConst (Name.mkSimple "[grind_dontcare]")
+
+def mkGroundPattern (e : Expr) : Expr :=
+  mkAnnotation `grind.ground_pat e
+
+def groundPattern? (e : Expr) : Option Expr :=
+  annotation? `grind.ground_pat e
+
+private def isGroundPattern (e : Expr) : Bool :=
+  groundPattern? e |>.isSome
+
+def isPatternDontCare (e : Expr) : Bool :=
+  e == dontCare
+
+private def isAtomicPattern (e : Expr) : Bool :=
+  e.isBVar || isPatternDontCare e || isGroundPattern e
+
+partial def ppPattern (pattern : Expr) : MessageData := Id.run do
+  if let some e := groundPattern? pattern then
+    return m!"`[{e}]"
+  else if isPatternDontCare pattern then
+    return m!"?"
+  else match pattern with
+    | .bvar idx => return m!"#{idx}"
+    | _ =>
+      let mut r := m!"{pattern.getAppFn}"
+      for arg in pattern.getAppArgs do
+        let mut argFmt ← ppPattern arg
+        if !isAtomicPattern arg then
+          argFmt := MessageData.paren argFmt
+        r := r ++ " " ++ argFmt
+      return r
+
+namespace NormalizePattern
+
+structure State where
+  symbols    : Array HeadIndex := #[]
+  symbolSet  : Std.HashSet HeadIndex := {}
+  bvarsFound : Std.HashSet Nat := {}
+
+abbrev M := StateRefT State MetaM
+
+private def saveSymbol (h : HeadIndex) : M Unit := do
+  unless (← get).symbolSet.contains h do
+    modify fun s => { s with symbols := s.symbols.push h, symbolSet := s.symbolSet.insert h }
+
+private def foundBVar (idx : Nat) : M Bool :=
+  return (← get).bvarsFound.contains idx
+
+private def saveBVar (idx : Nat) : M Unit := do
+  modify fun s => { s with bvarsFound := s.bvarsFound.insert idx }
+
+private def getPatternFn? (pattern : Expr) : Option Expr :=
+  if !pattern.isApp then
+    none
+  else match pattern.getAppFn with
+    | f@(.const declName _) => if isForbidden declName then none else some f
+    | f@(.fvar _) => some f
+    | _ => none
+
+/--
+Returns a bit-mask `mask` s.t. `mask[i]` is true if the the corresponding argument is
+- a type or type former, or
+- a proof, or
+- an instance implicit argument
+
+When `mask[i]`, we say the corresponding argument is a "support" argument.
+-/
+private def getPatternFunMask (f : Expr) (numArgs : Nat) : MetaM (Array Bool) := do
+  forallBoundedTelescope (← inferType f) numArgs fun xs _ => do
+    xs.mapM fun x => do
+      if (← isTypeFormer x <||> isProof x) then
+        return true
+      else
+        return (← x.fvarId!.getDecl).binderInfo matches .instImplicit
+
+private partial def go (pattern : Expr) (root := false) : M Expr := do
+  if root && !pattern.hasLooseBVars then
+    throwError "invalid pattern, it does not have pattern variables"
+  if let some (e, k) := isOffsetPattern? pattern then
+    let e ← goArg e (isSupport := false)
+    if e == dontCare then
+      return dontCare
+    else
+      return mkOffsetPattern e k
+  let some f := getPatternFn? pattern
+    | throwError "invalid pattern, (non-forbidden) application expected"
+  assert! f.isConst || f.isFVar
+  saveSymbol f.toHeadIndex
+  let mut args := pattern.getAppArgs
+  let supportMask ← getPatternFunMask f args.size
+  for i in [:args.size] do
+    let arg := args[i]!
+    let isSupport := supportMask[i]?.getD false
+    args := args.set! i (← goArg arg isSupport)
+  return mkAppN f args
+where
+  goArg (arg : Expr) (isSupport : Bool) : M Expr := do
+    if !arg.hasLooseBVars then
+      if arg.hasMVar then
+        pure dontCare
+      else
+        pure <| mkGroundPattern arg
+    else match arg with
+      | .bvar idx =>
+        if isSupport && (← foundBVar idx) then
+          pure dontCare
+        else
+          saveBVar idx
+          pure arg
+      | _ =>
+        if isSupport then
+          pure dontCare
+        else if let some _ := getPatternFn? arg then
+          go arg
+        else
+          pure dontCare
+
+def main (patterns : List Expr) : MetaM (List Expr × List HeadIndex × Std.HashSet Nat) := do
+  let (patterns, s) ← patterns.mapM go |>.run {}
+  return (patterns, s.symbols.toList, s.bvarsFound)
+
+end NormalizePattern
+
+/--
+Returns `true` if free variables in `type` are not in `thmVars` or are in `fvarsFound`.
+We use this function to check whether `type` is fully instantiated.
+-/
+private def checkTypeFVars (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (type : Expr) : Bool :=
+  let typeFVars := (collectFVars {} type).fvarIds
+  typeFVars.all fun fvarId => !thmVars.contains fvarId || fvarsFound.contains fvarId
+
+/--
+Given an type class instance type `instType`, returns true if free variables in input parameters
+1- are not in `thmVars`, or
+2- are in `fvarsFound`.
+Remark: `fvarsFound` is a subset of `thmVars`
+-/
+private def canBeSynthesized (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (instType : Expr) : MetaM Bool := do
+  forallTelescopeReducing instType fun xs type => type.withApp fun classFn classArgs => do
+    for x in xs do
+      unless checkTypeFVars thmVars fvarsFound (← inferType x) do return false
+    forallBoundedTelescope (← inferType classFn) type.getAppNumArgs fun params _ => do
+      for param in params, classArg in classArgs do
+        let paramType ← inferType param
+        if !paramType.isAppOf ``semiOutParam && !paramType.isAppOf ``outParam then
+          unless checkTypeFVars thmVars fvarsFound classArg do
+            return false
+      return true
+
+/--
+Auxiliary type for the `checkCoverage` function.
+-/
+inductive CheckCoverageResult where
+  | /-- `checkCoverage` succeeded -/
+    ok
+  | /--
+    `checkCoverage` failed because some of the theorem parameters are missing,
+    `pos` contains their positions
+    -/
+    missing (pos : List Nat)
+
+/--
+After we process a set of patterns, we obtain the set of de Bruijn indices in these patterns.
+We say they are pattern variables. This function checks whether the set of pattern variables is sufficient for
+instantiating the theorem with proof `thmProof`. The theorem has `numParams` parameters.
+The missing parameters:
+1- we may be able to infer them using type inference or type class synthesis, or
+2- they are propositions, and may become hypotheses of the instantiated theorem.
+
+For type class instance parameters, we must check whether the free variables in class input parameters are available.
+-/
+private def checkCoverage (thmProof : Expr) (numParams : Nat) (bvarsFound : Std.HashSet Nat) : MetaM CheckCoverageResult := do
+  if bvarsFound.size == numParams then return .ok
+  forallBoundedTelescope (← inferType thmProof) numParams fun xs _ => do
+    assert! numParams == xs.size
+    let patternVars := bvarsFound.toList.map fun bidx => xs[numParams - bidx - 1]!.fvarId!
+    -- `xs` as a `FVarIdSet`.
+    let thmVars : FVarIdSet := RBTree.ofList <| xs.toList.map (·.fvarId!)
+    -- Collect free variables occurring in `e`, and insert the ones that are in `thmVars` into `fvarsFound`
+    let update (fvarsFound : FVarIdSet) (e : Expr) : FVarIdSet :=
+      (collectFVars {} e).fvarIds.foldl (init := fvarsFound) fun s fvarId =>
+        if thmVars.contains fvarId then s.insert fvarId else s
+    -- Theorem variables found so far. We initialize with the variables occurring in patterns
+    -- Remark: fvarsFound is a subset of thmVars
+    let mut fvarsFound : FVarIdSet := RBTree.ofList patternVars
+    for patternVar in patternVars do
+      let type ← patternVar.getType
+      fvarsFound := update fvarsFound type
+    if fvarsFound.size == numParams then return .ok
+    -- Now, we keep traversing remaining variables and collecting
+    -- `processed` contains the variables we have already processed.
+    let mut processed : FVarIdSet := RBTree.ofList patternVars
+    let mut modified := false
+    repeat
+      modified := false
+      for x in xs do
+        let fvarId := x.fvarId!
+        unless processed.contains fvarId do
+          let xType ← inferType x
+          if fvarsFound.contains fvarId then
+            -- Collect free vars in `x`s type and mark as processed
+            fvarsFound := update fvarsFound xType
+            processed := processed.insert fvarId
+            modified := true
+          else if (← isProp xType) then
+            -- If `x` is a proposition, and all theorem variables in `x`s type have already been found
+            -- add it to `fvarsFound` and mark it as processed.
+            if checkTypeFVars thmVars fvarsFound xType then
+              fvarsFound := fvarsFound.insert fvarId
+              processed := processed.insert fvarId
+              modified := true
+          else if (← fvarId.getDecl).binderInfo matches .instImplicit then
+            -- If `x` is instance implicit, check whether
+            -- we have found all free variables needed to synthesize instance
+            if (← canBeSynthesized thmVars fvarsFound xType) then
+              fvarsFound := fvarsFound.insert fvarId
+              fvarsFound := update fvarsFound xType
+              processed := processed.insert fvarId
+              modified := true
+      if fvarsFound.size == numParams then
+        return .ok
+      if !modified then
+        break
+    let mut pos := #[]
+    for h : i in [:xs.size] do
+      let fvarId := xs[i].fvarId!
+      unless fvarsFound.contains fvarId do
+        pos := pos.push i
+    return .missing pos.toList
+
+/--
+Given a theorem with proof `proof` and `numParams` parameters, returns a message
+containing the parameters at positions `paramPos`.
+-/
+private def ppParamsAt (proof : Expr) (numParams : Nat) (paramPos : List Nat) : MetaM MessageData := do
+  forallBoundedTelescope (← inferType proof) numParams fun xs _ => do
+    let mut msg := m!""
+    let mut first := true
+    for h : i in [:xs.size] do
+      if paramPos.contains i then
+        let x := xs[i]
+        if first then first := false else msg := msg ++ "\n"
+        msg := msg ++ m!"{x} : {← inferType x}"
+    addMessageContextFull msg
+
+/--
+Creates an E-matching theorem for `declName` with `numParams` parameters, and the given set of patterns.
+Pattern variables are represented using de Bruijn indices.
+-/
+def mkEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) : MetaM EMatchTheorem := do
+  let .thmInfo info ← getConstInfo declName
+    | throwError "`{declName}` is not a theorem, you cannot assign patterns to non-theorems for the `grind` tactic"
+  let us := info.levelParams.map mkLevelParam
+  let proof := mkConst declName us
+  let (patterns, symbols, bvarFound) ← NormalizePattern.main patterns
+  assert! symbols.all fun s => s matches .const _
+  trace[grind.ematch.pattern] "{MessageData.ofConst proof}: {patterns.map ppPattern}"
+  if let .missing pos ← checkCoverage proof numParams bvarFound then
+     let pats : MessageData := m!"{patterns.map ppPattern}"
+     throwError "invalid pattern(s) for `{declName}`{indentD pats}\nthe following theorem parameters cannot be instantiated:{indentD (← ppParamsAt proof numParams pos)}"
+  return {
+    proof, patterns, numParams, symbols
+    levelParams := #[]
+    origin      := .decl declName
+  }
+
+/--
+Given theorem with name `declName` and type of the form `∀ (a_1 ... a_n), lhs = rhs`,
+creates an E-matching pattern for it using `addEMatchTheorem n [lhs]`
+-/
+def mkEMatchEqTheorem (declName : Name) : MetaM EMatchTheorem := do
+  let info ← getConstInfo declName
+  let (numParams, patterns) ← forallTelescopeReducing info.type fun xs type => do
+    let_expr Eq _ lhs _ := type | throwError "invalid E-matching equality theorem, conclusion must be an equality{indentExpr type}"
+    let lhs ← preprocessPattern lhs
+    return (xs.size, [lhs.abstract xs])
+  mkEMatchTheorem declName numParams patterns
+
+/--
+Adds an E-matching theorem to the environment.
+See `mkEMatchTheorem`.
+-/
+def addEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchTheorem declName numParams patterns)
+
+/--
+Adds an E-matching equality theorem to the environment.
+See `mkEMatchEqTheorem`.
+-/
+def addEMatchEqTheorem (declName : Name) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchEqTheorem declName)
+
+/-- Returns the E-matching theorems registered in the environment. -/
+def getEMatchTheorems : CoreM EMatchTheorems :=
+  return ematchTheoremsExt.getState (← getEnv)
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/ForallProp.lean

@@ -0,0 +1,34 @@
+/-
+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.Grind.Lemmas
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Internalize
+import Lean.Meta.Tactic.Grind.Simp
+
+namespace Lean.Meta.Grind
+/--
+If `parent` is a projection-application `proj_i c`,
+check whether the root of the equivalence class containing `c` is a constructor-application `ctor ... a_i ...`.
+If so, internalize the term `proj_i (ctor ... a_i ...)` and add the equality `proj_i (ctor ... a_i ...) = a_i`.
+-/
+def propagateForallProp (parent : Expr) : GoalM Unit := do
+  let .forallE n p q bi := parent | return ()
+  trace[grind.debug.forallPropagator] "{parent}"
+  unless (← isEqTrue p) do return ()
+  trace[grind.debug.forallPropagator] "isEqTrue, {parent}"
+  let h₁ ← mkEqTrueProof p
+  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
+  internalize q' (← getGeneration parent)
+  trace[grind.debug.forallPropagator] "q': {q'} for{indentExpr parent}"
+  let h₂ ← r.getProof
+  let h := mkApp5 (mkConst ``Lean.Grind.forall_propagator) p q q' h₁ h₂
+  pushEq parent q' h
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Internalize.lean

@@ -0,0 +1,138 @@
+/-
+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.Grind.Util
+import Lean.Meta.LitValues
+import Lean.Meta.Match.MatcherInfo
+import Lean.Meta.Match.MatchEqsExt
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Util
+
+namespace Lean.Meta.Grind
+
+/-- Adds `e` to congruence table. -/
+def addCongrTable (e : Expr) : GoalM Unit := do
+  if let some { e := e' } := (← get).congrTable.find? { e } then
+    -- `f` and `g` must have the same type.
+    -- See paper: Congruence Closure in Intensional Type Theory
+    let f := e.getAppFn
+    let g := e'.getAppFn
+    unless isSameExpr f g do
+      unless (← hasSameType f g) do
+        trace[grind.issues] "found congruence between{indentExpr e}\nand{indentExpr e'}\nbut functions have different types"
+        return ()
+    trace[grind.debug.congr] "{e} = {e'}"
+    pushEqHEq e e' congrPlaceholderProof
+    let node ← getENode e
+    setENode e { node with congr := e' }
+  else
+    modify fun s => { s with congrTable := s.congrTable.insert { e } }
+
+private def updateAppMap (e : Expr) : GoalM Unit := do
+  let key := e.toHeadIndex
+  modify fun s => { s with
+    appMap := if let some es := s.appMap.find? key then
+      s.appMap.insert key (e :: es)
+    else
+      s.appMap.insert key [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 ← 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))
+
+private partial def activateTheorem (thm : EMatchTheorem) (generation : Nat) : GoalM Unit := do
+  -- Recall that we use the proof as part of the key for a set of instances found so far.
+  -- We don't want to use structural equality when comparing keys.
+  let proof ← shareCommon thm.proof
+  let thm := { thm with proof, patterns := (← thm.patterns.mapM (internalizePattern · generation)) }
+  trace[grind.ematch] "activated `{thm.origin.key}`, {thm.patterns.map ppPattern}"
+  modify fun s => { s with newThms := s.newThms.push thm }
+
+/--
+If `Config.matchEqs` is set to `true`, and `f` is `match`-auxiliary function,
+adds its equations to `newThms`.
+-/
+private partial def addMatchEqns (f : Expr) (generation : Nat) : GoalM Unit := do
+  if !(← getConfig).matchEqs then return ()
+  let .const declName _ := f | return ()
+  if !(← isMatcher declName) then return ()
+  if (← get).matchEqNames.contains declName then return ()
+  modify fun s => { s with matchEqNames := s.matchEqNames.insert declName }
+  for eqn in (← Match.getEquationsFor declName).eqnNames do
+    activateTheorem (← mkEMatchEqTheorem eqn) generation
+
+private partial def activateTheoremPatterns (fName : Name) (generation : Nat) : GoalM Unit := do
+  if let some (thms, thmMap) := (← get).thmMap.retrieve? fName then
+    modify fun s => { s with thmMap }
+    let appMap := (← get).appMap
+    for thm in thms do
+      let symbols := thm.symbols.filter fun sym => !appMap.contains sym
+      let thm := { thm with symbols }
+      match symbols with
+      | [] => activateTheorem thm generation
+      | _ =>
+        trace[grind.ematch] "reinsert `{thm.origin.key}`"
+        modify fun s => { s with thmMap := s.thmMap.insert thm }
+
+partial def internalize (e : Expr) (generation : Nat) : GoalM Unit := do
+  if (← alreadyInternalized e) then return ()
+  trace[grind.internalize] "{e}"
+  match e with
+  | .bvar .. => unreachable!
+  | .sort .. => return ()
+  | .fvar .. | .letE .. | .lam .. =>
+    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
+  | .forallE _ d _ _ =>
+    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
+    if (← isProp d <&&> isProp e) then
+      internalize d generation
+      registerParent e d
+      propagateUp e
+  | .lit .. | .const .. =>
+    mkENode e generation
+  | .mvar ..
+  | .mdata ..
+  | .proj .. =>
+    trace[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
+    else e.withApp fun f args => do
+      addMatchEqns f generation
+      if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
+        -- We only internalize the proposition. We can skip the proof because of
+        -- proof irrelevance
+        let c := args[0]!
+        internalize c generation
+        registerParent e c
+      else
+        if let .const fName _ := f then
+          activateTheoremPatterns fName generation
+        else
+          internalize f generation
+          registerParent e f
+        for h : i in [: args.size] do
+          let arg := args[i]
+          internalize arg generation
+          registerParent e arg
+      mkENode e generation
+      addCongrTable e
+      updateAppMap e
+      propagateUp e
+end
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Intro.lean

@@ -0,0 +1,154 @@
+/-
+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.Lemmas
+import Lean.Meta.Tactic.Assert
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Cases
+import Lean.Meta.Tactic.Grind.Injection
+import Lean.Meta.Tactic.Grind.Core
+
+namespace Lean.Meta.Grind
+
+private inductive IntroResult where
+  | done
+  | newHyp (fvarId : FVarId) (goal : Goal)
+  | newDepHyp (goal : Goal)
+  | newLocal (fvarId : FVarId) (goal : Goal)
+  deriving Inhabited
+
+private def introNext (goal : Goal) (generation : Nat) : GrindM IntroResult := do
+  let target ← goal.mvarId.getType
+  if target.isArrow then
+    goal.mvarId.withContext do
+      let p := target.bindingDomain!
+      if !(← isProp p) then
+        let (fvarId, mvarId) ← goal.mvarId.intro1P
+        return .newLocal fvarId { goal with mvarId }
+      else
+        let tag ← goal.mvarId.getTag
+        let q := target.bindingBody!
+        -- TODO: keep applying simp/eraseIrrelevantMData/canon/shareCommon until no progress
+        let r ← simp p
+        let fvarId ← mkFreshFVarId
+        let lctx := (← getLCtx).mkLocalDecl fvarId target.bindingName! r.expr target.bindingInfo!
+        let mvarNew ← mkFreshExprMVarAt lctx (← getLocalInstances) q .syntheticOpaque tag
+        let mvarIdNew := mvarNew.mvarId!
+        mvarIdNew.withContext do
+          let h ← mkLambdaFVars #[mkFVar fvarId] mvarNew
+          match r.proof? with
+          | some he =>
+            let hNew := mkAppN (mkConst ``Lean.Grind.intro_with_eq) #[p, r.expr, q, he, h]
+            goal.mvarId.assign hNew
+            return .newHyp fvarId { goal with mvarId := mvarIdNew }
+          | none =>
+            -- `p` and `p'` are definitionally equal
+            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
+      let localDecl ← fvarId.getDecl
+      if (← isProp localDecl.type) then
+        -- Add a non-dependent copy
+        let mvarId ← mvarId.assert (← mkFreshUserName localDecl.userName) localDecl.type (mkFVar fvarId)
+        return .newDepHyp { goal with mvarId }
+      else
+        let goal := { goal with mvarId }
+        if target.isLet || target.isLetFun then
+          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
+  else
+    return .done
+
+private def isCasesCandidate (type : Expr) : MetaM Bool := do
+  let .const declName _ := type.getAppFn | return false
+  isGrindCasesTarget declName
+
+private def applyCases? (goal : Goal) (fvarId : FVarId) : MetaM (Option (List Goal)) := goal.mvarId.withContext do
+  if (← isCasesCandidate (← fvarId.getType)) then
+    let mvarIds ← cases goal.mvarId (mkFVar fvarId)
+    return mvarIds.map fun mvarId => { goal with mvarId }
+  else
+    return none
+
+private def applyInjection? (goal : Goal) (fvarId : FVarId) : MetaM (Option Goal) := do
+  if let some mvarId ← injection? goal.mvarId fvarId then
+    return some { goal with mvarId }
+  else
+    return none
+
+/-- Introduce new hypotheses (and apply `by_contra`) until goal is of the form `... ⊢ False` -/
+partial def intros (goal : Goal) (generation : Nat) : GrindM (List Goal) := do
+  let rec go (goal : Goal) : StateRefT (Array Goal) GrindM Unit := do
+    if goal.inconsistent then
+      return ()
+    match (← introNext goal generation) with
+    | .done =>
+      if let some mvarId ← goal.mvarId.byContra? then
+        go { goal with mvarId }
+      else
+        modify fun s => s.push goal
+    | .newHyp fvarId goal =>
+      if let some goals ← applyCases? goal fvarId then
+        goals.forM go
+      else if let some goal ← applyInjection? goal fvarId then
+        go goal
+      else
+        go (← GoalM.run' goal <| addHypothesis fvarId generation)
+    | .newDepHyp goal =>
+      go goal
+    | .newLocal fvarId goal =>
+      if let some goals ← applyCases? goal fvarId then
+        goals.forM go
+      else
+        go goal
+  let (_, goals) ← (go goal).run #[]
+  return goals.toList
+
+/-- Asserts a new fact `prop` with proof `proof` to the given `goal`. -/
+def assertAt (goal : Goal) (proof : Expr) (prop : Expr) (generation : Nat) : GrindM (List Goal) := do
+  if (← isCasesCandidate prop) then
+    let mvarId ← goal.mvarId.assert (← mkFreshUserName `h) prop proof
+    let goal := { goal with mvarId }
+    intros goal generation
+  else
+    let goal ← GoalM.run' goal do
+      let r ← simp prop
+      let prop' := r.expr
+      let proof' ← mkEqMP (← r.getProof) proof
+      add prop' proof' generation
+    if goal.inconsistent then return [] else return [goal]
+
+/-- Asserts next fact in the `goal` fact queue. -/
+def assertNext? (goal : Goal) : GrindM (Option (List Goal)) := do
+  let some (fact, newFacts) := goal.newFacts.dequeue?
+    | return none
+  assertAt { goal with newFacts } fact.proof fact.prop fact.generation
+
+partial def iterate (goal : Goal) (f : Goal → GrindM (Option (List Goal))) : GrindM (List Goal) := do
+  go [goal] []
+where
+  go (todo : List Goal) (result : List Goal) : GrindM (List Goal) := do
+    match todo with
+    | [] => return result
+    | goal :: todo =>
+      if let some goalsNew ← f goal then
+        go (goalsNew ++ todo) result
+      else
+        go todo (goal :: result)
+
+/-- Asserts all facts in the `goal` fact queue. -/
+partial def assertAll (goal : Goal) : GrindM (List Goal) := do
+  iterate goal assertNext?
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Inv.lean

@@ -0,0 +1,109 @@
+/-
+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 Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Proof
+
+namespace Lean.Meta.Grind
+
+/-!
+Debugging support code for checking basic invariants.
+-/
+
+private def checkEqc (root : ENode) : GoalM Unit := do
+  let mut size := 0
+  let mut curr := root.self
+  repeat
+    size := size + 1
+    -- The root of `curr` must be `root`
+    assert! isSameExpr (← getRoot curr) root.self
+    -- Check congruence root
+    if curr.isApp then
+      if let some { e } := (← get).congrTable.find? { e := curr } then
+        if (← hasSameType e.getAppFn curr.getAppFn) then
+          assert! isSameExpr e (← getCongrRoot curr)
+      else
+        assert! (← isCongrRoot curr)
+    -- If the equivalence class does not have HEq proofs, then the types must be definitionally equal.
+    unless root.heqProofs do
+      assert! (← hasSameType curr root.self)
+    -- Starting at `curr`, following the `target?` field leads to `root`.
+    let mut n := curr
+    repeat
+      if let some target ← getTarget? n then
+        n := target
+      else
+        break
+    assert! isSameExpr n root.self
+    -- Go to next element
+    curr ← getNext curr
+    if isSameExpr root.self curr then
+      break
+  -- The size of the equivalence class is correct.
+  assert! root.size == size
+
+private def checkParents (e : Expr) : GoalM Unit := do
+  if (← isRoot e) then
+    for parent in (← getParents e) do
+      let mut found := false
+      let checkChild (child : Expr) : GoalM Bool := do
+        let some childRoot ← getRoot? child | return false
+        return isSameExpr childRoot e
+      -- There is an argument `arg` s.t. root of `arg` is `e`.
+      for arg in parent.getAppArgs do
+        if (← checkChild arg) then
+          found := true
+          break
+      -- Recall that we have support for `Expr.forallE` propagation. See `ForallProp.lean`.
+      if let .forallE _ d _ _ := parent then
+        if (← checkChild d) then
+          found := true
+      unless found do
+        assert! (← checkChild parent.getAppFn)
+  else
+    -- All the parents are stored in the root of the equivalence class.
+    assert! (← getParents e).isEmpty
+
+private def checkPtrEqImpliesStructEq : GoalM Unit := do
+  let nodes ← getENodes
+  for h₁ : i in [: nodes.size] do
+    let n₁ := nodes[i]
+    for h₂ : j in [i+1 : nodes.size] do
+      let n₂ := nodes[j]
+      -- We don't have multiple nodes for the same expression
+      assert! !isSameExpr n₁.self n₂.self
+      -- and the two expressions must not be structurally equal
+      assert! !Expr.equal n₁.self n₂.self
+
+private def checkProofs : GoalM Unit := do
+  let eqcs ← getEqcs
+  for eqc in eqcs do
+    for a in eqc do
+      for b in eqc do
+        unless isSameExpr a b do
+          let p ← mkEqHEqProof a b
+          trace[grind.debug.proofs] "{a} = {b}"
+          check p
+          trace[grind.debug.proofs] "checked: {← inferType p}"
+
+/--
+Checks basic invariants if `grind.debug` is enabled.
+-/
+def checkInvariants (expensive := false) : GoalM Unit := do
+  if grind.debug.get (← getOptions) then
+    for (_, node) in (← get).enodes do
+      checkParents node.self
+      if isSameExpr node.self node.root then
+        checkEqc node
+    if expensive then
+      checkPtrEqImpliesStructEq
+  if expensive && grind.debug.proofs.get (← getOptions) then
+    checkProofs
+
+def Goal.checkInvariants (goal : Goal) (expensive := false) : GrindM Unit :=
+  discard <| GoalM.run' goal <| Grind.checkInvariants expensive
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Main.lean

@@ -0,0 +1,96 @@
+/-
+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.Lemmas
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Simp.Simproc
+import Lean.Meta.Tactic.Grind.RevertAll
+import Lean.Meta.Tactic.Grind.PropagatorAttr
+import Lean.Meta.Tactic.Grind.Proj
+import Lean.Meta.Tactic.Grind.ForallProp
+import Lean.Meta.Tactic.Grind.Util
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.Intro
+import Lean.Meta.Tactic.Grind.EMatch
+import Lean.Meta.Tactic.Grind.DoNotSimp
+
+namespace Lean.Meta.Grind
+
+def mkMethods (fallback : Fallback) : CoreM Methods := do
+  let builtinPropagators ← builtinPropagatorsRef.get
+  return {
+    fallback
+    propagateUp := fun e => do
+     propagateForallProp e
+     let .const declName _ := e.getAppFn | return ()
+     propagateProjEq e
+     if let some prop := builtinPropagators.up[declName]? then
+       prop e
+    propagateDown := fun e => do
+     let .const declName _ := e.getAppFn | return ()
+     if let some prop := builtinPropagators.down[declName]? then
+       prop e
+  }
+
+private def getGrindSimprocs : MetaM Simprocs := do
+  let s ← grindNormSimprocExt.getSimprocs
+  let s ← addDoNotSimp s
+  return s
+
+def GrindM.run (x : GrindM α) (mainDeclName : Name) (config : Grind.Config) (fallback : Fallback) : MetaM α := do
+  let scState := ShareCommon.State.mk _
+  let (falseExpr, scState) := ShareCommon.State.shareCommon scState (mkConst ``False)
+  let (trueExpr, scState)  := ShareCommon.State.shareCommon scState (mkConst ``True)
+  let thms ← grindNormExt.getTheorems
+  let simprocs := #[(← getGrindSimprocs), (← Simp.getSEvalSimprocs)]
+  let simp ← Simp.mkContext
+    (config := { arith := true })
+    (simpTheorems := #[thms])
+    (congrTheorems := (← getSimpCongrTheorems))
+  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 thmMap ← getEMatchTheorems
+  GoalM.run' { mvarId, thmMap } do
+    mkENodeCore falseExpr (interpreted := true) (ctor := false) (generation := 0)
+    mkENodeCore trueExpr (interpreted := true) (ctor := false) (generation := 0)
+
+private def initCore (mvarId : MVarId) : GrindM (List Goal) := do
+  mvarId.ensureProp
+  -- TODO: abstract metavars
+  mvarId.ensureNoMVar
+  let mvarId ← mvarId.clearAuxDecls
+  let mvarId ← mvarId.revertAll
+  let mvarId ← mvarId.unfoldReducible
+  let mvarId ← mvarId.betaReduce
+  let goals ← intros (← mkGoal mvarId) (generation := 0)
+  goals.forM (·.checkInvariants (expensive := true))
+  return goals.filter fun goal => !goal.inconsistent
+
+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
+  all goals ematchStar
+
+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 ← simple goals
+    let goals ← goals.filterMapM fun goal => do
+      if goal.inconsistent then return none
+      let goal ← GoalM.run' goal fallback
+      if goal.inconsistent then return none
+      if (← goal.mvarId.isAssigned) then return none
+      return some goal
+    trace[grind.debug.final] "{← ppGoals goals}"
+    return goals.map (·.mvarId)
+  go.run mainDeclName config fallback
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/MarkNestedProofs.lean

@@ -0,0 +1,66 @@
+/-
+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.Grind.Util
+import Lean.Util.PtrSet
+import Lean.Meta.Basic
+import Lean.Meta.InferType
+
+namespace Lean.Meta.Grind
+
+unsafe def markNestedProofsImpl (e : Expr) : MetaM Expr := do
+  visit e |>.run' mkPtrMap
+where
+  visit (e : Expr) : StateRefT (PtrMap Expr Expr) MetaM Expr := do
+    if (← isProof e) then
+      if e.isAppOf ``Lean.Grind.nestedProof then
+        return e -- `e` is already marked
+      if let some r := (← get).find? e then
+        return r
+      let prop ← inferType e
+      let e' := mkApp2 (mkConst ``Lean.Grind.nestedProof) prop e
+      modify fun s => s.insert e e'
+      return e'
+    -- Remark: we have to process `Expr.proj` since we only
+    -- fold projections later during term internalization
+    unless e.isApp || e.isForall || e.isProj do
+      return e
+    -- Check whether it is cached
+    if let some r := (← get).find? e then
+      return r
+    let e' ← match e with
+      | .app .. => e.withApp fun f args => do
+        let mut modified := false
+        let mut args := args
+        for i in [:args.size] do
+          let arg := args[i]!
+          let arg' ← visit arg
+          unless ptrEq arg arg' do
+            args := args.set! i arg'
+            modified := true
+        if modified then
+          pure <| mkAppN f args
+        else
+          pure e
+      | .proj _ _ b =>
+        pure <| e.updateProj! (← visit b)
+      | .forallE _ d b _ =>
+        -- Recall that we have `ForallProp.lean`.
+        let d' ← visit d
+        let b' ← if b.hasLooseBVars then pure b else visit b
+        pure <| e.updateForallE! d' b'
+      | _ => unreachable!
+    modify fun s => s.insert e e'
+    return e'
+
+/--
+Wrap nested proofs `e` with `Lean.Grind.nestedProof`-applications.
+Recall that the congruence closure module has special support for `Lean.Grind.nestedProof`.
+-/
+def markNestedProofs (e : Expr) : MetaM Expr :=
+  unsafe markNestedProofsImpl e
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/PP.lean

@@ -0,0 +1,66 @@
+/-
+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.Grind.Util
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+/-- Helper function for pretty printing the state for debugging purposes. -/
+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. -/
+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
+        ppExpr f
+      else
+        ppENodeRef f
+      let mut r := r
+      for arg in args do
+        r := r ++ " " ++ (← ppENodeRef arg)
+      return r
+  else
+    ppExpr e
+
+/-- Helper function for pretty printing the state for debugging purposes. -/
+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 ++ 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 ← getTarget? e then
+      r := r ++ f!" ↝ {← ppENodeRef target}"
+  return r
+
+/-- Pretty print goal state for debugging purposes. -/
+def ppState : GoalM Format := do
+  let mut r := f!"Goal:"
+  let nodes ← getENodes
+  for node in nodes do
+    r := r ++ "\n" ++ (← ppENodeDecl node.self)
+  let eqcs ← getEqcs
+  for eqc in eqcs do
+    if eqc.length > 1 then
+      r := r ++ "\n" ++ "{" ++ (Format.joinSep (← eqc.mapM ppENodeRef) ", ") ++  "}"
+  return r
+
+def ppGoals (goals : List Goal) : GrindM Format := do
+  let mut r := f!""
+  for goal in goals do
+    let (f, _) ← GoalM.run goal ppState
+    r := r ++ Format.line ++ f
+  return r
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Parser.lean

@@ -0,0 +1,15 @@
+/-
+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 Lean.Parser.Command
+
+namespace Lean.Parser.Command
+/-!
+Builtin parsers for `grind` related commands
+-/
+@[builtin_command_parser] def grindPattern := leading_parser
+  "grind_pattern " >>  ident >> darrow >> sepBy1 termParser ","
+end Lean.Parser.Command

src/Lean/Meta/Tactic/Grind/Preprocessor.lean

@@ -1,191 +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.Grind.Lemmas
-import Lean.Meta.Canonicalizer
-import Lean.Meta.Tactic.Util
-import Lean.Meta.Tactic.Intro
-import Lean.Meta.Tactic.Simp.Main
-import Lean.Meta.Tactic.Grind.Attr
-import Lean.Meta.Tactic.Grind.RevertAll
-import Lean.Meta.Tactic.Grind.Types
-import Lean.Meta.Tactic.Grind.Util
-import Lean.Meta.Tactic.Grind.Cases
-import Lean.Meta.Tactic.Grind.Injection
-import Lean.Meta.Tactic.Grind.Core
-
-namespace Lean.Meta.Grind
-namespace Preprocessor
-
--- TODO: use congruence closure and decision procedures during pre-processing
--- TODO: implement `simp` discharger using preprocessor state
-
-structure Context where
-  simp     : Simp.Context
-  simprocs : Array Simp.Simprocs
-  deriving Inhabited
-
-structure State where
-  simpStats : Simp.Stats := {}
-  goals     : PArray Goal := {}
-  deriving Inhabited
-
-abbrev PreM := ReaderT Context $ StateRefT State GrindM
-
-def PreM.run (x : PreM α) : GrindM α := do
-  let thms ← grindNormExt.getTheorems
-  let simprocs := #[(← grindNormSimprocExt.getSimprocs)]
-  let simp ← Simp.mkContext
-    (config := { arith := true })
-    (simpTheorems := #[thms])
-    (congrTheorems := (← getSimpCongrTheorems))
-  x { simp, simprocs } |>.run' {}
-
-def simp (_goal : Goal) (e : Expr) : PreM Simp.Result := do
-  -- TODO: use `goal` state in the simplifier
-  let simpStats := (← get).simpStats
-  let (r, simpStats) ← Meta.simp e (← read).simp (← read).simprocs (stats := simpStats)
-  modify fun s => { s with simpStats }
-  return r
-
-inductive IntroResult where
-  | done
-  | newHyp (fvarId : FVarId) (goal : Goal)
-  | newDepHyp (goal : Goal)
-  | newLocal (fvarId : FVarId) (goal : Goal)
-
-def introNext (goal : Goal) : PreM IntroResult := do
-  let target ← goal.mvarId.getType
-  if target.isArrow then
-    goal.mvarId.withContext do
-      let p := target.bindingDomain!
-      if !(← isProp p) then
-        let (fvarId, mvarId) ← goal.mvarId.intro1P
-        return .newLocal fvarId { goal with mvarId }
-      else
-        let tag ← goal.mvarId.getTag
-        let q := target.bindingBody!
-        -- TODO: keep applying simp/eraseIrrelevantMData/canon/shareCommon until no progress
-        let r ← simp goal p
-        let p' := r.expr
-        let p' ← eraseIrrelevantMData p'
-        let p' ← foldProjs p'
-        let p' ← normalizeLevels p'
-        let p' ← canon p'
-        let p' ← shareCommon p'
-        let fvarId ← mkFreshFVarId
-        let lctx := (← getLCtx).mkLocalDecl fvarId target.bindingName! p' target.bindingInfo!
-        let mvarNew ← mkFreshExprMVarAt lctx (← getLocalInstances) q .syntheticOpaque tag
-        let mvarIdNew := mvarNew.mvarId!
-        mvarIdNew.withContext do
-          let h ← mkLambdaFVars #[mkFVar fvarId] mvarNew
-          match r.proof? with
-          | some he =>
-            let hNew := mkAppN (mkConst ``Lean.Grind.intro_with_eq) #[p, p', q, he, h]
-            goal.mvarId.assign hNew
-            return .newHyp fvarId { goal with mvarId := mvarIdNew }
-          | none =>
-            -- `p` and `p'` are definitionally equal
-            goal.mvarId.assign h
-            return .newHyp fvarId { goal with mvarId := mvarIdNew }
-  else if target.isLet || target.isForall then
-    let (fvarId, mvarId) ← goal.mvarId.intro1P
-    mvarId.withContext do
-      let localDecl ← fvarId.getDecl
-      if (← isProp localDecl.type) then
-        -- Add a non-dependent copy
-        let mvarId ← mvarId.assert localDecl.userName localDecl.type (mkFVar fvarId)
-        return .newDepHyp { goal with mvarId }
-      else
-        return .newLocal fvarId { goal with mvarId }
-  else
-    return .done
-
-def pushResult (goal : Goal) : PreM Unit :=
-  modify fun s => { s with goals := s.goals.push goal }
-
-def isCasesCandidate (fvarId : FVarId) : MetaM Bool := do
-  let .const declName _ := (← fvarId.getType).getAppFn | return false
-  isGrindCasesTarget declName
-
-def applyCases? (goal : Goal) (fvarId : FVarId) : MetaM (Option (List Goal)) := goal.mvarId.withContext do
-  if (← isCasesCandidate fvarId) then
-    let mvarIds ← cases goal.mvarId fvarId
-    return mvarIds.map fun mvarId => { goal with mvarId }
-  else
-    return none
-
-def applyInjection? (goal : Goal) (fvarId : FVarId) : MetaM (Option Goal) := do
-  if let some mvarId ← injection? goal.mvarId fvarId then
-    return some { goal with mvarId }
-  else
-    return none
-
-partial def loop (goal : Goal) : PreM Unit := do
-  match (← introNext goal) with
-  | .done =>
-    if let some mvarId ← goal.mvarId.byContra? then
-      loop { goal with mvarId }
-    else
-      pushResult goal
-  | .newHyp fvarId goal =>
-    if let some goals ← applyCases? goal fvarId then
-      goals.forM loop
-    else if let some goal ← applyInjection? goal fvarId then
-      loop goal
-    else
-      loop (← GoalM.run' goal <| addHyp fvarId)
-  | .newDepHyp goal =>
-    loop goal
-  | .newLocal fvarId goal =>
-    if let some goals ← applyCases? goal fvarId then
-      goals.forM loop
-    else
-      loop goal
-
-def ppGoals : PreM Format := do
-  let mut r := f!""
-  for goal in (← get).goals do
-    let (f, _) ← GoalM.run goal ppState
-    r := r ++ Format.line ++ f
-  return r
-
-def preprocess (mvarId : MVarId) : PreM State := do
-  mvarId.ensureProp
-  -- TODO: abstract metavars
-  mvarId.ensureNoMVar
-  let mvarId ← mvarId.clearAuxDecls
-  let mvarId ← mvarId.revertAll
-  mvarId.ensureNoMVar
-  let mvarId ← mvarId.abstractNestedProofs (← getMainDeclName)
-  let mvarId ← mvarId.unfoldReducible
-  let mvarId ← mvarId.betaReduce
-  loop (← mkGoal mvarId)
-  if (← isTracingEnabledFor `grind.pre) then
-    trace[grind.pre] (← ppGoals)
-  get
-
-def preprocessAndProbe (mvarId : MVarId) (p : GoalM Unit) : PreM Unit := do
-  let s ← preprocess mvarId
-  s.goals.forM fun goal =>
-    discard <| GoalM.run' goal p
-
-end Preprocessor
-
-open Preprocessor
-
-def preprocessAndProbe (mvarId : MVarId) (mainDeclName : Name) (p : GoalM Unit) : MetaM Unit :=
-  withoutModifyingMCtx do
-    Preprocessor.preprocessAndProbe mvarId p |>.run |>.run mainDeclName
-
-def preprocess (mvarId : MVarId) (mainDeclName : Name) : MetaM Preprocessor.State :=
-  Preprocessor.preprocess mvarId |>.run |>.run mainDeclName
-
-def main (mvarId : MVarId) (mainDeclName : Name) : MetaM (List MVarId) := do
-  let s ← preprocess mvarId mainDeclName
-  return s.goals.toList.map (·.mvarId)
-
-end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Proj.lean

@@ -0,0 +1,39 @@
+/-
+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 Lean.ProjFns
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Internalize
+
+namespace Lean.Meta.Grind
+
+/--
+If `parent` is a projection-application `proj_i c`,
+check whether the root of the equivalence class containing `c` is a constructor-application `ctor ... a_i ...`.
+If so, internalize the term `proj_i (ctor ... a_i ...)` and add the equality `proj_i (ctor ... a_i ...) = a_i`.
+-/
+def propagateProjEq (parent : Expr) : GoalM Unit := do
+  let .const declName _ := parent.getAppFn | return ()
+  let some info ← getProjectionFnInfo? declName | return ()
+  unless info.numParams + 1 == parent.getAppNumArgs do return ()
+  -- It is wasteful to add equation if `parent` is not the root of its congruence class
+  unless (← isCongrRoot parent) do return ()
+  let arg := parent.appArg!
+  let ctor ← getRoot arg
+  unless ctor.isAppOf info.ctorName do return ()
+  let parentNew ← if isSameExpr arg ctor then
+    pure parent
+  else
+    let parentNew ← shareCommon (mkApp parent.appFn! ctor)
+    internalize parentNew (← getGeneration parent)
+    pure parentNew
+  trace[grind.debug.proj] "{parentNew}"
+  let idx := info.numParams + info.i
+  unless idx < ctor.getAppNumArgs do return ()
+  let v := ctor.getArg! idx
+  pushEq parentNew v (← mkEqRefl v)
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Proof.lean

@@ -0,0 +1,260 @@
+/-
+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.Grind.Lemmas
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+private def isEqProof (h : Expr) : MetaM Bool := do
+  return (← whnfD (← inferType h)).isAppOf ``Eq
+
+private def flipProof (h : Expr) (flipped : Bool) (heq : Bool) : MetaM Expr := do
+  let mut h' := h
+  if (← pure heq <&&> isEqProof h') then
+    h' ← mkHEqOfEq h'
+  if flipped then
+    if heq then mkHEqSymm h' else mkEqSymm h'
+  else
+    return h'
+
+private def mkRefl (a : Expr) (heq : Bool) : MetaM Expr :=
+  if heq then mkHEqRefl a else mkEqRefl a
+
+private def mkTrans (h₁ h₂ : Expr) (heq : Bool) : MetaM Expr :=
+  if heq then
+    mkHEqTrans h₁ h₂
+  else
+    mkEqTrans h₁ h₂
+
+private def mkTrans' (h₁ : Option Expr) (h₂ : Expr) (heq : Bool) : MetaM Expr := do
+  let some h₁ := h₁ | return h₂
+  mkTrans h₁ h₂ heq
+
+/--
+Given `h : HEq a b`, returns a proof `a = b` if `heq == false`.
+Otherwise, it returns `h`.
+-/
+private def mkEqOfHEqIfNeeded (h : Expr) (heq : Bool) : MetaM Expr := do
+  if heq then return h else mkEqOfHEq h
+
+/--
+Given `lhs` and `rhs` that are in the same equivalence class,
+find the common expression that are in the paths from `lhs` and `rhs` to
+the root of their equivalence class.
+Recall that this expression must exist since it is the root itself in the
+worst case.
+-/
+private def findCommon (lhs rhs : Expr) : GoalM Expr := do
+  let mut visited : RBMap Nat Expr compare := {}
+  let mut it := lhs
+  -- Mark elements found following the path from `lhs` to the root.
+  repeat
+    let n ← getENode it
+    visited := visited.insert n.idx n.self
+    let some target := n.target? | break
+    it := target
+  -- Find the marked element from the path from `rhs` to the root.
+  it := rhs
+  repeat
+    let n ← getENode it
+    if let some common := visited.find? n.idx then
+      return common
+    let some target := n.target? | unreachable! --
+    it := target
+  unreachable!
+
+/--
+Returns `true` if we can construct a congruence proof for `lhs = rhs` using `congrArg`, `congrFun`, and `congr`.
+`f` (`g`) is the function of the `lhs` (`rhs`) application. `numArgs` is the number of arguments.
+-/
+private partial def isCongrDefaultProofTarget (lhs rhs : Expr) (f g : Expr) (numArgs : Nat) : GoalM Bool := do
+  unless isSameExpr f g do return false
+  let info := (← getFunInfo f).paramInfo
+  let rec loop (lhs rhs : Expr) (i : Nat) : GoalM Bool := do
+    if lhs.isApp then
+      let a₁ := lhs.appArg!
+      let a₂ := rhs.appArg!
+      let i  := i - 1
+      unless isSameExpr a₁ a₂ do
+        if h : i < info.size then
+          if info[i].hasFwdDeps then
+            -- Cannot use `congrArg` because there are forward dependencies
+            return false
+        else
+          return false -- Don't have information about argument
+      loop lhs.appFn! rhs.appFn! i
+    else
+      return true
+  loop lhs rhs numArgs
+
+mutual
+  /--
+  Given `lhs` and `rhs` proof terms of the form `nestedProof p hp` and `nestedProof q hq`,
+  constructs a congruence proof for `HEq (nestedProof p hp) (nestedProof q hq)`.
+  `p` and `q` are in the same equivalence class.
+  -/
+  private partial def mkNestedProofCongr (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    let p  := lhs.appFn!.appArg!
+    let hp := lhs.appArg!
+    let q  := rhs.appFn!.appArg!
+    let hq := rhs.appArg!
+    let h  := mkApp5 (mkConst ``Lean.Grind.nestedProof_congr) p q (← mkEqProofCore p q false) hp hq
+    mkEqOfHEqIfNeeded h heq
+
+  /--
+  Constructs a congruence proof for `lhs` and `rhs` using `congr`, `congrFun`, and `congrArg`.
+  This function assumes `isCongrDefaultProofTarget` returned `true`.
+  -/
+  private partial def mkCongrDefaultProof (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    let rec loop (lhs rhs : Expr) : GoalM (Option Expr) := do
+      if lhs.isApp then
+        let a₁ := lhs.appArg!
+        let a₂ := rhs.appArg!
+        if let some proof ← loop lhs.appFn! rhs.appFn! then
+          if isSameExpr a₁ a₂ then
+            mkCongrFun proof a₁
+          else
+            mkCongr proof (← mkEqProofCore a₁ a₂ false)
+        else if isSameExpr a₁ a₂ then
+          return none -- refl case
+        else
+          mkCongrArg lhs.appFn! (← mkEqProofCore a₁ a₂ false)
+      else
+        return none
+    let r := (← loop lhs rhs).get!
+    if heq then mkHEqOfEq r else return r
+
+  private partial def mkHCongrProof (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    let f := lhs.getAppFn
+    let g := rhs.getAppFn
+    let numArgs := lhs.getAppNumArgs
+    assert! rhs.getAppNumArgs == numArgs
+    let thm ← mkHCongrWithArity f numArgs
+    assert! thm.argKinds.size == numArgs
+    let rec loop (lhs rhs : Expr) (i : Nat) : GoalM Expr := do
+      let i := i - 1
+      if lhs.isApp then
+        let proof ← loop lhs.appFn! rhs.appFn! i
+        let a₁  := lhs.appArg!
+        let a₂  := rhs.appArg!
+        let k   := thm.argKinds[i]!
+        return mkApp3 proof a₁ a₂ (← mkEqProofCore a₁ a₂ (k matches .heq))
+      else
+        return thm.proof
+    let proof ← loop lhs rhs numArgs
+    if isSameExpr f g then
+      mkEqOfHEqIfNeeded proof heq
+    else
+      /-
+      `lhs` is of the form `f a_1 ... a_n`
+      `rhs` is of the form `g b_1 ... b_n`
+      `proof : HEq (f a_1 ... a_n) (f b_1 ... b_n)`
+      We construct a proof for `HEq (f a_1 ... a_n) (g b_1 ... b_n)` using `Eq.ndrec`
+      -/
+      let motive ← withLocalDeclD (← mkFreshUserName `x) (← inferType f) fun x => do
+        mkLambdaFVars #[x] (← mkHEq lhs (mkAppN x rhs.getAppArgs))
+      let fEq ← mkEqProofCore f g false
+      let proof ← mkEqNDRec motive proof fEq
+      mkEqOfHEqIfNeeded proof heq
+
+  private partial def mkEqCongrProof (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    let_expr f@Eq α₁ a₁ b₁ := lhs | unreachable!
+    let_expr Eq α₂ a₂ b₂ := rhs | unreachable!
+    let enodes := (← get).enodes
+    let us := f.constLevels!
+    if !isSameExpr α₁ α₂ then
+      mkHCongrProof lhs rhs heq
+    else if hasSameRoot enodes a₁ a₂ && hasSameRoot enodes b₁ b₂ then
+      return mkApp7 (mkConst ``Grind.eq_congr us) α₁ a₁ b₁ a₂ b₂ (← mkEqProofCore a₁ a₂ false) (← mkEqProofCore b₁ b₂ false)
+    else
+      assert! hasSameRoot enodes a₁ b₂ && hasSameRoot enodes b₁ a₂
+      return mkApp7 (mkConst ``Grind.eq_congr' us) α₁ a₁ b₁ a₂ b₂ (← mkEqProofCore a₁ b₂ false) (← mkEqProofCore b₁ a₂ false)
+
+  /-- Constructs a congruence proof for `lhs` and `rhs`. -/
+  private partial def mkCongrProof (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    let f := lhs.getAppFn
+    let g := rhs.getAppFn
+    let numArgs := lhs.getAppNumArgs
+    assert! rhs.getAppNumArgs == numArgs
+    if f.isConstOf ``Lean.Grind.nestedProof && g.isConstOf ``Lean.Grind.nestedProof && numArgs == 2 then
+      mkNestedProofCongr lhs rhs heq
+    else if f.isConstOf ``Eq && g.isConstOf ``Eq && numArgs == 3 then
+      mkEqCongrProof lhs rhs heq
+    else if (← isCongrDefaultProofTarget lhs rhs f g numArgs) then
+      mkCongrDefaultProof lhs rhs heq
+    else
+      mkHCongrProof lhs rhs heq
+
+  private partial def realizeEqProof (lhs rhs : Expr) (h : Expr) (flipped : Bool) (heq : Bool) : GoalM Expr := do
+    let h ← if h == congrPlaceholderProof then
+      mkCongrProof lhs rhs heq
+    else
+      flipProof h flipped heq
+
+  /-- Given `acc : lhs₀ = lhs`, returns a proof of `lhs₀ = common`. -/
+  private partial def mkProofTo (lhs : Expr) (common : Expr) (acc : Option Expr) (heq : Bool) : GoalM (Option Expr) := do
+    if isSameExpr lhs common then
+      return acc
+    let n ← getENode lhs
+    let some target := n.target? | unreachable!
+    let some h := n.proof? | unreachable!
+    let h ← realizeEqProof lhs target h n.flipped heq
+    -- h : lhs = target
+    let acc ← mkTrans' acc h heq
+    mkProofTo target common (some acc) heq
+
+  /-- Given `lhsEqCommon : lhs = common`, returns a proof for `lhs = rhs`. -/
+  private partial def mkProofFrom (rhs : Expr) (common : Expr) (lhsEqCommon? : Option Expr) (heq : Bool) : GoalM (Option Expr) := do
+    if isSameExpr rhs common then
+      return lhsEqCommon?
+    let n ← getENode rhs
+    let some target := n.target? | unreachable!
+    let some h := n.proof? | unreachable!
+    let h ← realizeEqProof target rhs h (!n.flipped) heq
+    -- `h : target = rhs`
+    let h' ← mkProofFrom target common lhsEqCommon? heq
+    -- `h' : lhs = target`
+    mkTrans' h' h heq
+
+  /--
+  Returns a proof of `lhs = rhs` (`HEq lhs rhs`) if `heq = false` (`heq = true`).
+  If `heq = false`, this function assumes that `lhs` and `rhs` have the same type.
+  -/
+  private partial def mkEqProofCore (lhs rhs : Expr) (heq : Bool) : GoalM Expr := do
+    if isSameExpr lhs rhs then
+      return (← mkRefl lhs heq)
+    -- The equivalence class contains `HEq` proofs. So, we build a proof using HEq. Otherwise, we use `Eq`.
+    let heqProofs := (← getRootENode lhs).heqProofs
+    let n₁ ← getENode lhs
+    let n₂ ← getENode rhs
+    assert! isSameExpr n₁.root n₂.root
+    let common ← findCommon lhs rhs
+    let lhsEqCommon? ← mkProofTo lhs common none heqProofs
+    let some lhsEqRhs ← mkProofFrom rhs common lhsEqCommon? heqProofs | unreachable!
+    if heq == heqProofs then
+      return lhsEqRhs
+    else if heq then
+      mkHEqOfEq lhsEqRhs
+    else
+      mkEqOfHEq lhsEqRhs
+
+end
+
+/--
+Returns a proof that `a = b`.
+It assumes `a` and `b` are in the same equivalence class.
+-/
+@[export lean_grind_mk_eq_proof]
+def mkEqProofImpl (a b : Expr) : GoalM Expr := do
+  assert! (← hasSameType a b)
+  mkEqProofCore a b (heq := false)
+
+@[export lean_grind_mk_heq_proof]
+def mkHEqProofImpl (a b : Expr) : GoalM Expr :=
+  mkEqProofCore a b (heq := true)
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Propagate.lean

@@ -0,0 +1,177 @@
+/-
+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.Grind
+import Lean.Meta.Tactic.Grind.Proof
+import Lean.Meta.Tactic.Grind.PropagatorAttr
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Internalize
+
+namespace Lean.Meta.Grind
+
+/--
+Propagates equalities for a conjunction `a ∧ b` based on the truth values
+of its components `a` and `b`. This function checks the truth value of `a` and `b`,
+and propagates the following equalities:
+
+- If `a = True`, propagates `(a ∧ b) = b`.
+- If `b = True`, propagates `(a ∧ b) = a`.
+- If `a = False`, propagates `(a ∧ b) = False`.
+- If `b = False`, propagates `(a ∧ b) = False`.
+-/
+builtin_grind_propagator propagateAndUp ↑And := fun e => do
+  let_expr And a b := e | return ()
+  if (← isEqTrue a) then
+    -- a = True → (a ∧ b) = b
+    pushEq e b <| mkApp3 (mkConst ``Lean.Grind.and_eq_of_eq_true_left) a b (← mkEqTrueProof a)
+  else if (← isEqTrue b) then
+    -- b = True → (a ∧ b) = a
+    pushEq e a <| mkApp3 (mkConst ``Lean.Grind.and_eq_of_eq_true_right) a b (← mkEqTrueProof b)
+  else if (← isEqFalse a) then
+    -- a = False → (a ∧ b) = False
+    pushEqFalse e <| mkApp3 (mkConst ``Lean.Grind.and_eq_of_eq_false_left) a b (← mkEqFalseProof a)
+  else if (← isEqFalse b) then
+    -- b = False → (a ∧ b) = False
+    pushEqFalse e <| mkApp3 (mkConst ``Lean.Grind.and_eq_of_eq_false_right) a b (← mkEqFalseProof b)
+
+/--
+Propagates truth values downwards for a conjunction `a ∧ b` when the
+expression itself is known to be `True`.
+-/
+builtin_grind_propagator propagateAndDown ↓And := fun e => do
+  if (← isEqTrue e) then
+    let_expr And a b := e | return ()
+    let h ← mkEqTrueProof e
+    pushEqTrue a <| mkApp3 (mkConst ``Lean.Grind.eq_true_of_and_eq_true_left) a b h
+    pushEqTrue b <| mkApp3 (mkConst ``Lean.Grind.eq_true_of_and_eq_true_right) a b h
+
+/--
+Propagates equalities for a disjunction `a ∨ b` based on the truth values
+of its components `a` and `b`. This function checks the truth value of `a` and `b`,
+and propagates the following equalities:
+
+- If `a = False`, propagates `(a ∨ b) = b`.
+- If `b = False`, propagates `(a ∨ b) = a`.
+- If `a = True`, propagates `(a ∨ b) = True`.
+- If `b = True`, propagates `(a ∨ b) = True`.
+-/
+builtin_grind_propagator propagateOrUp ↑Or := fun e => do
+  let_expr Or a b := e | return ()
+  if (← isEqFalse a) then
+    -- a = False → (a ∨ b) = b
+    pushEq e b <| mkApp3 (mkConst ``Lean.Grind.or_eq_of_eq_false_left) a b (← mkEqFalseProof a)
+  else if (← isEqFalse b) then
+    -- b = False → (a ∨ b) = a
+    pushEq e a <| mkApp3 (mkConst ``Lean.Grind.or_eq_of_eq_false_right) a b (← mkEqFalseProof b)
+  else if (← isEqTrue a) then
+    -- a = True → (a ∨ b) = True
+    pushEqTrue e <| mkApp3 (mkConst ``Lean.Grind.or_eq_of_eq_true_left) a b (← mkEqTrueProof a)
+  else if (← isEqTrue b) then
+    -- b = True → (a ∧ b) = True
+    pushEqTrue e <| mkApp3 (mkConst ``Lean.Grind.or_eq_of_eq_true_right) a b (← mkEqTrueProof b)
+
+/--
+Propagates truth values downwards for a disjuction `a ∨ b` when the
+expression itself is known to be `False`.
+-/
+builtin_grind_propagator propagateOrDown ↓Or := fun e => do
+  if (← isEqFalse e) then
+    let_expr Or a b := e | return ()
+    let h ← mkEqFalseProof e
+    pushEqFalse a <| mkApp3 (mkConst ``Lean.Grind.eq_false_of_or_eq_false_left) a b h
+    pushEqFalse b <| mkApp3 (mkConst ``Lean.Grind.eq_false_of_or_eq_false_right) a b h
+
+/--
+Propagates equalities for a negation `Not a` based on the truth value of `a`.
+This function checks the truth value of `a` and propagates the following equalities:
+
+- If `a = False`, propagates `(Not a) = True`.
+- If `a = True`, propagates `(Not a) = False`.
+-/
+builtin_grind_propagator propagateNotUp ↑Not := fun e => do
+  let_expr Not a := e | return ()
+  if (← isEqFalse a) then
+    -- a = False → (Not a) = True
+    pushEqTrue e <| mkApp2 (mkConst ``Lean.Grind.not_eq_of_eq_false) a (← mkEqFalseProof a)
+  else if (← isEqTrue a) then
+    -- a = True → (Not a) = False
+    pushEqFalse e <| mkApp2 (mkConst ``Lean.Grind.not_eq_of_eq_true) a (← mkEqTrueProof a)
+  else if (← isEqv e a) then
+    closeGoal <| mkApp2 (mkConst ``Lean.Grind.false_of_not_eq_self) a (← mkEqProof e a)
+
+/--
+Propagates truth values downwards for a negation expression `Not a` based on the truth value of `Not a`.
+This function performs the following:
+
+- If `(Not a) = False`, propagates `a = True`.
+- If `(Not a) = True`, propagates `a = False`.
+-/
+builtin_grind_propagator propagateNotDown ↓Not := fun e => do
+  let_expr Not a := e | return ()
+  if (← isEqFalse e) then
+    pushEqTrue a <| mkApp2 (mkConst ``Lean.Grind.eq_true_of_not_eq_false) a (← mkEqFalseProof e)
+  else if (← isEqTrue e) then
+    pushEqFalse a <| mkApp2 (mkConst ``Lean.Grind.eq_false_of_not_eq_true) a (← mkEqTrueProof e)
+  else if (← isEqv e a) then
+    closeGoal <| mkApp2 (mkConst ``Lean.Grind.false_of_not_eq_self) a (← mkEqProof e a)
+
+/-- Propagates `Eq` upwards -/
+builtin_grind_propagator propagateEqUp ↑Eq := fun e => do
+  let_expr Eq _ a b := e | return ()
+  if (← isEqTrue a) then
+    pushEq e b <| mkApp3 (mkConst ``Lean.Grind.eq_eq_of_eq_true_left) a b (← mkEqTrueProof a)
+  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 <| 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 <| 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 <| 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 <| mkApp2 (mkConst ``eq_true) e (← mkHEqProof a b)
+
+/-- Propagates `ite` upwards -/
+builtin_grind_propagator propagateIte ↑ite := fun e => do
+  let_expr f@ite α c h a b := e | return ()
+  if (← isEqTrue c) then
+    pushEq e a <| mkApp6 (mkConst ``ite_cond_eq_true f.constLevels!) α c h a b (← mkEqTrueProof c)
+  else if (← isEqFalse c) then
+    pushEq e b <| mkApp6 (mkConst ``ite_cond_eq_false f.constLevels!) α c h a b (← mkEqFalseProof c)
+
+/-- Propagates `dite` upwards -/
+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 (mkApp2 (mkConst ``of_eq_true) c h₁)
+     let p ← simp ah₁
+     let r := p.expr
+     let h₂ ← p.getProof
+     internalize r (← getGeneration e)
+     pushEq e r <| mkApp8 (mkConst ``Grind.dite_cond_eq_true' f.constLevels!) α c h a b r h₁ h₂
+  else if (← isEqFalse c) then
+     let h₁ ← mkEqFalseProof c
+     let bh₁ := mkApp b (mkApp2 (mkConst ``of_eq_false) c h₁)
+     let p ← simp bh₁
+     let r := p.expr
+     let h₂ ← p.getProof
+     internalize r (← getGeneration e)
+     pushEq e r <| mkApp8 (mkConst ``Grind.dite_cond_eq_false' f.constLevels!) α c h a b r h₁ h₂
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/PropagatorAttr.lean

@@ -0,0 +1,61 @@
+/-
+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.Grind
+import Lean.Meta.Tactic.Grind.Proof
+
+namespace Lean.Meta.Grind
+
+/-- Builtin propagators. -/
+structure BuiltinPropagators where
+  up   : Std.HashMap Name Propagator := {}
+  down : Std.HashMap Name Propagator := {}
+  deriving Inhabited
+
+builtin_initialize builtinPropagatorsRef : IO.Ref BuiltinPropagators ← IO.mkRef {}
+
+private def registerBuiltinPropagatorCore (declName : Name) (up : Bool) (proc : Propagator) : IO Unit := do
+  unless (← initializing) do
+    throw (IO.userError s!"invalid builtin `grind` propagator declaration, it can only be registered during initialization")
+  if up then
+    if (← builtinPropagatorsRef.get).up.contains declName then
+      throw (IO.userError s!"invalid builtin `grind` upward propagator `{declName}`, it has already been declared")
+    builtinPropagatorsRef.modify fun { up, down } => { up := up.insert declName proc, down }
+  else
+    if (← builtinPropagatorsRef.get).down.contains declName then
+      throw (IO.userError s!"invalid builtin `grind` downward propagator `{declName}`, it has already been declared")
+    builtinPropagatorsRef.modify fun { up, down } => { up, down := down.insert declName proc }
+
+def registerBuiltinUpwardPropagator (declName : Name) (proc : Propagator) : IO Unit :=
+  registerBuiltinPropagatorCore declName true proc
+
+def registerBuiltinDownwardPropagator (declName : Name) (proc : Propagator) : IO Unit :=
+  registerBuiltinPropagatorCore declName false proc
+
+private def addBuiltin (propagatorName : Name) (stx : Syntax) : AttrM Unit := do
+  let go : MetaM Unit := do
+    let up := stx[1].getKind == ``Lean.Parser.Tactic.simpPost
+    let addDeclName := if up then
+      ``registerBuiltinUpwardPropagator
+    else
+      ``registerBuiltinDownwardPropagator
+    let declName ← resolveGlobalConstNoOverload stx[2]
+    let val := mkAppN (mkConst addDeclName) #[toExpr declName, mkConst propagatorName]
+    let initDeclName ← mkFreshUserName (propagatorName ++ `declare)
+    declareBuiltin initDeclName val
+  go.run' {}
+
+builtin_initialize
+  registerBuiltinAttribute {
+    ref             := by exact decl_name%
+    name            := `grindPropagatorBuiltinAttr
+    descr           := "Builtin `grind` propagator procedure"
+    applicationTime := AttributeApplicationTime.afterCompilation
+    erase           := fun _ => throwError "Not implemented yet, [-builtin_simproc]"
+    add             := fun declName stx _ => addBuiltin declName stx
+  }
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Simp.lean

@@ -0,0 +1,43 @@
+/-
+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.Grind.Lemmas
+import Lean.Meta.Tactic.Assert
+import Lean.Meta.Tactic.Simp.Main
+import Lean.Meta.Tactic.Grind.Util
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.DoNotSimp
+import Lean.Meta.Tactic.Grind.MarkNestedProofs
+
+namespace Lean.Meta.Grind
+/-- Simplifies the given expression using the `grind` simprocs and normalization theorems. -/
+def simpCore (e : Expr) : GrindM Simp.Result := do
+  let simpStats := (← get).simpStats
+  let (r, simpStats) ← Meta.simp e (← readThe Context).simp (← readThe Context).simprocs (stats := simpStats)
+  modify fun s => { s with simpStats }
+  return r
+
+/--
+Simplifies `e` using `grind` normalization theorems and simprocs,
+and then applies several other preprocessing steps.
+-/
+def simp (e : Expr) : GrindM Simp.Result := do
+  let e ← instantiateMVars e
+  let r ← simpCore e
+  let e' := r.expr
+  let e' ← abstractNestedProofs e'
+  let e' ← markNestedProofs e'
+  let e' ← unfoldReducible e'
+  let e' ← eraseIrrelevantMData e'
+  let e' ← foldProjs e'
+  let e' ← normalizeLevels e'
+  let e' ← eraseDoNotSimp e'
+  let e' ← canon e'
+  let e' ← shareCommon e'
+  trace[grind.simp] "{e}\n===>\n{e'}"
+  return { r with expr := e' }
+
+end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Types.lean

@@ -4,12 +4,18 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
+import Init.Grind.Tactics
+import Init.Data.Queue
 import Lean.Util.ShareCommon
+import Lean.HeadIndex
 import Lean.Meta.Basic
 import Lean.Meta.CongrTheorems
 import Lean.Meta.AbstractNestedProofs
-import Lean.Meta.Canonicalizer
+import Lean.Meta.Tactic.Simp.Types
 import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Grind.Canon
+import Lean.Meta.Tactic.Grind.Attr
+import Lean.Meta.Tactic.Grind.EMatchTheorem
 
 namespace Lean.Meta.Grind
 
@@ -18,12 +24,37 @@ namespace Lean.Meta.Grind
   -- inserted into the E-graph
   unsafe ptrEq a b
 
-structure Context where
-  mainDeclName : Name
+/-- We use this auxiliary constant to mark delayed congruence proofs. -/
+def congrPlaceholderProof := mkConst (Name.mkSimple "[congruence]")
 
 /--
-Key for the congruence theorem cache.
+Returns `true` if `e` is `True`, `False`, or a literal value.
+See `LitValues` for supported literals.
 -/
+def isInterpreted (e : Expr) : MetaM Bool := do
+  if e.isTrue || e.isFalse then return true
+  isLitValue e
+
+register_builtin_option grind.debug : Bool := {
+  defValue := false
+  group    := "debug"
+  descr    := "check invariants after updates"
+}
+
+register_builtin_option grind.debug.proofs : Bool := {
+  defValue := false
+  group    := "debug"
+  descr    := "check proofs between the elements of all equivalence classes"
+}
+
+/-- Context for `GrindM` monad. -/
+structure Context where
+  simp         : Simp.Context
+  simprocs     : Array Simp.Simprocs
+  mainDeclName : Name
+  config       : Grind.Config
+
+/-- Key for the congruence theorem cache. -/
 structure CongrTheoremCacheKey where
   f       : Expr
   numArgs : Nat
@@ -36,8 +67,9 @@ instance : BEq CongrTheoremCacheKey where
 instance : Hashable CongrTheoremCacheKey where
   hash a := mixHash (unsafe ptrAddrUnsafe a.f).toUInt64 (hash a.numArgs)
 
-structure State where
-  canon      : Canonicalizer.State := {}
+/-- State for the `GrindM` monad. -/
+structure CoreState where
+  canon      : Canon.State := {}
   /-- `ShareCommon` (aka `Hashconsing`) state. -/
   scState    : ShareCommon.State.{0} ShareCommon.objectFactory := ShareCommon.State.mk _
   /-- Next index for creating auxiliary theorems. -/
@@ -48,25 +80,37 @@ structure State where
   Remark: we currently do not reuse congruence theorems
   -/
   congrThms  : PHashMap CongrTheoremCacheKey CongrTheorem := {}
+  simpStats  : Simp.Stats := {}
   trueExpr   : Expr
   falseExpr  : Expr
 
-abbrev GrindM := ReaderT Context $ StateRefT State MetaM
+private opaque MethodsRefPointed : NonemptyType.{0}
+private def MethodsRef : Type := MethodsRefPointed.type
+instance : Nonempty MethodsRef := MethodsRefPointed.property
 
-def GrindM.run (x : GrindM α) (mainDeclName : Name) : MetaM α := do
-  let scState := ShareCommon.State.mk _
-  let (falseExpr, scState) := ShareCommon.State.shareCommon scState (mkConst ``False)
-  let (trueExpr, scState)  := ShareCommon.State.shareCommon scState (mkConst ``True)
-  x { mainDeclName } |>.run' { scState, trueExpr, falseExpr }
+abbrev GrindM := ReaderT MethodsRef $ ReaderT Context $ StateRefT CoreState MetaM
 
+/-- Returns the user-defined configuration options -/
+def getConfig : GrindM Grind.Config :=
+  return (← readThe Context).config
+
+/-- Returns the internalized `True` constant.  -/
 def getTrueExpr : GrindM Expr := do
   return (← get).trueExpr
 
+/-- Returns the internalized `False` constant.  -/
 def getFalseExpr : GrindM Expr := do
   return (← get).falseExpr
 
 def getMainDeclName : GrindM Name :=
-  return (← read).mainDeclName
+  return (← readThe Context).mainDeclName
+
+@[inline] def getMethodsRef : GrindM MethodsRef :=
+  read
+
+/-- Returns maximum term generation that is considered during ematching. -/
+def getMaxGeneration : GrindM Nat := do
+  return (← getConfig).gen
 
 /--
 Abtracts nested proofs in `e`. This is a preprocessing step performed before internalization.
@@ -82,30 +126,26 @@ Applies hash-consing to `e`. Recall that all expressions in a `grind` goal have
 been hash-consing. We perform this step before we internalize expressions.
 -/
 def shareCommon (e : Expr) : GrindM Expr := do
-  modifyGet fun { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr } =>
+  modifyGet fun { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr, simpStats } =>
     let (e, scState) := ShareCommon.State.shareCommon scState e
-    (e, { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr })
+    (e, { canon, scState, nextThmIdx, congrThms, trueExpr, falseExpr, simpStats })
 
 /--
-Applies the canonicalizer to all subterms of `e`.
+Canonicalizes nested types, type formers, and instances in `e`.
 -/
--- TODO: the current canonicalizer is not a good solution for `grind`.
--- The problem is that two different applications `@f inst_1 a` and `@f inst_2 b`
--- may still have syntaticaally different instances. Thus, if we learn that `a = b`,
--- congruence closure will fail to see that the two applications are congruent.
 def canon (e : Expr) : GrindM Expr := do
   let canonS ← modifyGet fun s => (s.canon, { s with canon := {} })
-  let (e, canonS) ← Canonicalizer.CanonM.run (canonRec e) (s := canonS)
+  let (e, canonS) ← Canon.canon e |>.run canonS
   modify fun s => { s with canon := canonS }
   return e
-where
-  canonRec (e : Expr) : CanonM Expr := do
-    let post (e : Expr) : CanonM TransformStep := do
-      if e.isApp then
-        return .done (← Meta.canon e)
-      else
-        return .done e
-    transform e post
+
+/-- Returns `true` if `e` is the internalized `True` expression.  -/
+def isTrueExpr (e : Expr) : GrindM Bool :=
+  return isSameExpr e (← getTrueExpr)
+
+/-- Returns `true` if `e` is the internalized `False` expression.  -/
+def isFalseExpr (e : Expr) : GrindM Bool :=
+  return isSameExpr e (← getFalseExpr)
 
 /--
 Creates a congruence theorem for a `f`-applications with `numArgs` arguments.
@@ -133,8 +173,12 @@ structure ENode where
   next : Expr
   /-- Root (aka canonical representative) of the equivalence class -/
   root : Expr
-  /-- Root of the congruence class. This is field is a don't care if `e` is not an application. -/
-  cgRoot : Expr
+  /--
+  `congr` is the term `self` is congruent to.
+  We say `self` is the congruence class root if `isSameExpr congr self`.
+  This field is initialized to `self` even if `e` is not an application.
+  -/
+  congr : Expr
   /--
   When `e` was added to this equivalence class because of an equality `h : e = target`,
   then we store `target` here, and `h` at `proof?`.
@@ -166,15 +210,152 @@ structure ENode where
   -- TODO: see Lean 3 implementation
   deriving Inhabited, Repr
 
+def ENode.isCongrRoot (n : ENode) :=
+  isSameExpr n.self n.congr
+
+/-- New equality to be processed. -/
 structure NewEq where
   lhs   : Expr
   rhs   : Expr
   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
+
+/--
+Key for the congruence table.
+We need access to the `enodes` to be able to retrieve the equivalence class roots.
+-/
+structure CongrKey (enodes : ENodeMap) where
+  e : Expr
+
+private def hashRoot (enodes : ENodeMap) (e : Expr) : UInt64 :=
+  if let some node := enodes.find? { expr := e } then
+    unsafe (ptrAddrUnsafe node.root).toUInt64
+  else
+    13
+
+def hasSameRoot (enodes : ENodeMap) (a b : Expr) : Bool := Id.run do
+  if isSameExpr a b then
+    return true
+  else
+    let some n1 := enodes.find? { expr := a } | return false
+    let some n2 := enodes.find? { expr := b } | return false
+    isSameExpr n1.root n2.root
+
+def congrHash (enodes : ENodeMap) (e : Expr) : UInt64 :=
+  match_expr e with
+  | Grind.nestedProof p _ => hashRoot enodes p
+  | Eq _ lhs rhs => goEq lhs rhs
+  | _ => go e 17
+where
+  goEq (lhs rhs : Expr) : UInt64 :=
+    let h₁ := hashRoot enodes lhs
+    let h₂ := hashRoot enodes rhs
+    if h₁ > h₂ then mixHash h₂ h₁ else mixHash h₁ h₂
+  go (e : Expr) (r : UInt64) : UInt64 :=
+    match e with
+    | .app f a => go f (mixHash r (hashRoot enodes a))
+    | _ => mixHash r (hashRoot enodes e)
+
+/-- Returns `true` if `a` and `b` are congruent modulo the equivalence classes in `enodes`. -/
+partial def isCongruent (enodes : ENodeMap) (a b : Expr) : Bool :=
+  match_expr a with
+  | Grind.nestedProof p₁ _ =>
+    let_expr Grind.nestedProof p₂ _ := b | false
+    hasSameRoot enodes p₁ p₂
+  | Eq α₁ lhs₁ rhs₁ =>
+    let_expr Eq α₂ lhs₂ rhs₂ := b | false
+    if isSameExpr α₁ α₂ then
+      goEq lhs₁ rhs₁ lhs₂ rhs₂
+    else
+      go a b
+  | _ => go a b
+where
+  goEq (lhs₁ rhs₁ lhs₂ rhs₂ : Expr) : Bool :=
+    (hasSameRoot enodes lhs₁ lhs₂ && hasSameRoot enodes rhs₁ rhs₂)
+    ||
+    (hasSameRoot enodes lhs₁ rhs₂ && hasSameRoot enodes rhs₁ lhs₂)
+  go (a b : Expr) : Bool :=
+    if a.isApp && b.isApp then
+      hasSameRoot enodes a.appArg! b.appArg! && go a.appFn! b.appFn!
+    else
+      -- Remark: we do not check whether the types of the functions are equal here
+      -- because we are not in the `MetaM` monad.
+      hasSameRoot enodes a b
+
+instance : Hashable (CongrKey enodes) where
+  hash k := congrHash enodes k.e
+
+instance : BEq (CongrKey enodes) where
+  beq k1 k2 := isCongruent enodes k1.e k2.e
+
+abbrev CongrTable (enodes : ENodeMap) := PHashSet (CongrKey enodes)
+
+-- Remark: we cannot use pointer addresses here because we have to traverse the tree.
+abbrev ParentSet := RBTree Expr Expr.quickComp
+abbrev ParentMap := PHashMap ENodeKey ParentSet
+
+/--
+The E-matching module instantiates theorems using the `EMatchTheorem proof` and a (partial) assignment.
+We want to avoid instantiating the same theorem with the same assignment more than once.
+Therefore, we store the (pre-)instance information in set.
+Recall that the proofs of activated theorems have been hash-consed.
+The assignment contains internalized expressions, which have also been hash-consed.
+-/
+structure PreInstance where
+  proof      : Expr
+  assignment : Array Expr
+
+instance : Hashable PreInstance where
+  hash i := Id.run do
+    let mut r := unsafe (ptrAddrUnsafe i.proof >>> 3).toUInt64
+    for v in i.assignment do
+      r := mixHash r (unsafe (ptrAddrUnsafe v >>> 3).toUInt64)
+    return r
+
+instance : BEq PreInstance where
+  beq i₁ i₂ := Id.run do
+    unless isSameExpr i₁.proof i₂.proof do return false
+    unless i₁.assignment.size == i₂.assignment.size do return false
+    for v₁ in i₁.assignment, v₂ in i₂.assignment do
+      unless isSameExpr v₁ v₂ do return false
+    return true
+
+abbrev PreInstanceSet := PHashSet PreInstance
+
+/-- New fact to be processed. -/
+structure NewFact where
+  proof      : Expr
+  prop       : Expr
+  generation : Nat
+  deriving Inhabited
+
 structure Goal where
   mvarId       : MVarId
-  enodes       : PHashMap USize ENode := {}
+  enodes       : ENodeMap := {}
+  parents      : ParentMap := {}
+  congrTable   : CongrTable enodes := {}
+  /--
+  A mapping from each function application index (`HeadIndex`) to a list of applications with that index.
+  Recall that the `HeadIndex` for a constant is its constant name, and for a free variable,
+  it is its unique id.
+  -/
+  appMap       : PHashMap HeadIndex (List Expr) := {}
   /-- Equations to be processed. -/
   newEqs       : Array NewEq := #[]
   /-- `inconsistent := true` if `ENode`s for `True` and `False` are in the same equivalence class. -/
@@ -183,6 +364,23 @@ structure Goal where
   gmt          : Nat := 0
   /-- Next unique index for creating ENodes -/
   nextIdx      : Nat := 0
+  /-- 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. -/
+  newThms      : PArray EMatchTheorem := {}
+  /--
+  Inactive global theorems. As we internalize terms, we activate theorems as we find their symbols.
+  Local theorem provided by users are added directly into `newThms`.
+  -/
+  thmMap       : EMatchTheorems
+  /-- Number of theorem instances generated so far -/
+  numInstances : Nat := 0
+  /-- (pre-)instances found so far. It includes instances that failed to be instantiated. -/
+  preInstances : PreInstanceSet := {}
+  /-- new facts to be processed. -/
+  newFacts     : Std.Queue NewFact := ∅
+  /-- `match` auxiliary functions whose equations have already been created and activated. -/
+  matchEqNames : PHashSet Name := {}
   deriving Inhabited
 
 def Goal.admit (goal : Goal) : MetaM Unit :=
@@ -196,36 +394,174 @@ abbrev GoalM := StateRefT Goal GrindM
 @[inline] def GoalM.run' (goal : Goal) (x : GoalM Unit) : GrindM Goal :=
   goal.mvarId.withContext do StateRefT'.run' (x *> get) goal
 
+/--
+A helper function used to mark a theorem instance found by the E-matching module.
+It returns `true` if it is a new instance and `false` otherwise.
+-/
+def markTheoremInstance (proof : Expr) (assignment : Array Expr) : GoalM Bool := do
+  let k := { proof, assignment }
+  if (← get).preInstances.contains k then
+    return false
+  modify fun s => { s with preInstances := s.preInstances.insert k }
+  return true
+
+/-- Adds a new fact `prop` with proof `proof` to the queue for processing. -/
+def addNewFact (proof : Expr) (prop : Expr) (generation : Nat) : GoalM Unit := do
+  modify fun s => { s with newFacts := s.newFacts.enqueue { proof, prop, generation } }
+
+/-- Adds a new theorem instance produced using E-matching. -/
+def addTheoremInstance (proof : Expr) (prop : Expr) (generation : Nat) : GoalM Unit := do
+  addNewFact proof prop generation
+  modify fun s => { s with numInstances := s.numInstances + 1 }
+
+/-- Returns `true` if the maximum number of instances has been reached. -/
+def checkMaxInstancesExceeded : GoalM Bool := do
+  return (← get).numInstances >= (← getConfig).instances
+
 /--
 Returns `some n` if `e` has already been "internalized" into the
 Otherwise, returns `none`s.
 -/
 def getENode? (e : Expr) : GoalM (Option ENode) :=
-  return (← get).enodes.find? (unsafe ptrAddrUnsafe e)
+  return (← get).enodes.find? { expr := e }
 
 /-- Returns node associated with `e`. It assumes `e` has already been internalized. -/
 def getENode (e : Expr) : GoalM ENode := do
-  let some n := (← get).enodes.find? (unsafe ptrAddrUnsafe e) | unreachable!
+  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 :=
+  return (← getENode e).generation
+
+/-- Returns `true` if `e` is in the equivalence class of `True`. -/
+def isEqTrue (e : Expr) : GoalM Bool := do
+  let n ← getENode e
+  return isSameExpr n.root (← getTrueExpr)
+
+/-- Returns `true` if `e` is in the equivalence class of `False`. -/
+def isEqFalse (e : Expr) : GoalM Bool := do
+  let n ← getENode e
+  return isSameExpr n.root (← getFalseExpr)
+
+/-- Returns `true` if `a` and `b` are in the same equivalence class. -/
+def isEqv (a b : Expr) : GoalM Bool := do
+  if isSameExpr a b then
+    return true
+  else
+    let na ← getENode a
+    let nb ← getENode b
+    return isSameExpr na.root nb.root
+
+/-- Returns `true` if the root of its equivalence class. -/
+def isRoot (e : Expr) : GoalM Bool := do
+  let some n ← getENode? e | return false -- `e` has not been internalized. Panic instead?
+  return isSameExpr n.root e
+
+/-- Returns the root element in the equivalence class of `e` IF `e` has been internalized. -/
+def getRoot? (e : Expr) : GoalM (Option Expr) := do
+  let some n ← getENode? e | return none
+  return some n.root
+
 /-- Returns the root element in the equivalence class of `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`. -/
 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 (unsafe ptrAddrUnsafe e)
+  return (← get).enodes.contains { expr := e }
+
+def getTarget? (e : Expr) : GoalM (Option Expr) := do
+  let some n ← getENode? e | return none
+  return n.target?
+
+/--
+If `isHEq` is `false`, it pushes `lhs = rhs` with `proof` to `newEqs`.
+Otherwise, it pushes `HEq lhs rhs`.
+-/
+def pushEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit :=
+  modify fun s => { s with newEqs := s.newEqs.push { lhs, rhs, proof, isHEq } }
+
+/-- Return `true` if `a` and `b` have the same type. -/
+def hasSameType (a b : Expr) : MetaM Bool :=
+  withDefault do isDefEq (← inferType a) (← inferType b)
+
+@[inline] def pushEqHEq (lhs rhs proof : Expr) : GoalM Unit := do
+  if (← hasSameType lhs rhs) then
+    pushEqCore lhs rhs proof (isHEq := false)
+  else
+    pushEqCore lhs rhs proof (isHEq := true)
+
+/-- Pushes `lhs = rhs` with `proof` to `newEqs`. -/
+@[inline] def pushEq (lhs rhs proof : Expr) : GoalM Unit :=
+  pushEqCore lhs rhs proof (isHEq := false)
+
+/-- Pushes `HEq lhs rhs` with `proof` to `newEqs`. -/
+@[inline] def pushHEq (lhs rhs proof : Expr) : GoalM Unit :=
+  pushEqCore lhs rhs proof (isHEq := true)
+
+/-- Pushes `a = True` with `proof` to `newEqs`. -/
+def pushEqTrue (a proof : Expr) : GoalM Unit := do
+  pushEq a (← getTrueExpr) proof
+
+/-- Pushes `a = False` with `proof` to `newEqs`. -/
+def pushEqFalse (a proof : Expr) : GoalM Unit := do
+  pushEq a (← getFalseExpr) proof
+
+/--
+Records that `parent` is a parent of `child`. This function actually stores the
+information in the root (aka canonical representative) of `child`.
+-/
+def registerParent (parent : Expr) (child : Expr) : GoalM Unit := do
+  let some childRoot ← getRoot? child | return ()
+  let parents := if let some parents := (← get).parents.find? { expr := childRoot } then parents else {}
+  modify fun s => { s with parents := s.parents.insert { expr := childRoot } (parents.insert parent) }
+
+/--
+Returns the set of expressions `e` is a child of, or an expression in
+`e`s equivalence class is a child of.
+The information is only up to date if `e` is the root (aka canonical representative) of the equivalence class.
+-/
+def getParents (e : Expr) : GoalM ParentSet := do
+  let some parents := (← get).parents.find? { expr := e } | return {}
+  return parents
+
+/--
+Similar to `getParents`, but also removes the entry `e ↦ parents` from the parent map.
+-/
+def getParentsAndReset (e : Expr) : GoalM ParentSet := do
+  let parents ← getParents e
+  modify fun s => { s with parents := s.parents.erase { expr := e } }
+  return parents
+
+/--
+Copy `parents` to the parents of `root`.
+`root` must be the root of its equivalence class.
+-/
+def copyParentsTo (parents : ParentSet) (root : Expr) : GoalM Unit := do
+  let mut curr := if let some parents := (← get).parents.find? { expr := root } then parents else {}
+  for parent in parents do
+    curr := curr.insert parent
+  modify fun s => { s with parents := s.parents.insert { expr := root } curr }
 
 def setENode (e : Expr) (n : ENode) : GoalM Unit :=
-  modify fun s => { s with enodes := s.enodes.insert (unsafe ptrAddrUnsafe e) n }
+  modify fun s => { s with
+    enodes := s.enodes.insert { expr := e } n
+    congrTable := unsafe unsafeCast s.congrTable
+  }
 
 def mkENodeCore (e : Expr) (interpreted ctor : Bool) (generation : Nat) : GoalM Unit := do
   setENode e {
-    self := e, next := e, root := e, cgRoot := e, size := 1
+    self := e, next := e, root := e, congr := e, size := 1
     flipped := false
     heqProofs := false
     hasLambdas := e.isLambda
@@ -235,17 +571,96 @@ def mkENodeCore (e : Expr) (interpreted ctor : Bool) (generation : Nat) : GoalM
   }
   modify fun s => { s with nextIdx := s.nextIdx + 1 }
 
-def mkGoal (mvarId : MVarId) : GrindM Goal := do
-  let trueExpr ← getTrueExpr
-  let falseExpr ← getFalseExpr
-  GoalM.run' { mvarId } do
-    mkENodeCore falseExpr (interpreted := true) (ctor := false) (generation := 0)
-    mkENodeCore trueExpr (interpreted := true) (ctor := false) (generation := 0)
+/--
+Creates an `ENode` for `e` if one does not already exist.
+This method assumes `e` has been hashconsed.
+-/
+def mkENode (e : Expr) (generation : Nat) : GoalM Unit := do
+  if (← alreadyInternalized e) then return ()
+  let ctor := (← isConstructorAppCore? e).isSome
+  let interpreted ← isInterpreted e
+  mkENodeCore e interpreted ctor generation
+
+/-- Returns `true` is `e` is the root of its congruence class. -/
+def isCongrRoot (e : Expr) : GoalM Bool := do
+  return (← getENode e).isCongrRoot
+
+/-- Returns the root of the congruence class containing `e`. -/
+partial def getCongrRoot (e : Expr) : GoalM Expr := do
+  let n ← getENode e
+  if isSameExpr n.congr e then return e
+  getCongrRoot n.congr
+
+/-- Return `true` if the goal is inconsistent. -/
+def isInconsistent : GoalM Bool :=
+  return (← get).inconsistent
+
+/--
+Returns a proof that `a = b`.
+It assumes `a` and `b` are in the same equivalence class, and have the same type.
+-/
+-- Forward definition
+@[extern "lean_grind_mk_eq_proof"]
+opaque mkEqProof (a b : Expr) : GoalM Expr
+
+/--
+Returns a proof that `HEq a b`.
+It assumes `a` and `b` are in the same equivalence class.
+-/
+-- Forward definition
+@[extern "lean_grind_mk_heq_proof"]
+opaque mkHEqProof (a b : Expr) : GoalM Expr
+
+/--
+Returns a proof that `a = b` if they have the same type. Otherwise, returns a proof of `HEq a b`.
+It assumes `a` and `b` are in the same equivalence class.
+-/
+def mkEqHEqProof (a b : Expr) : GoalM Expr := do
+  if (← hasSameType a b) then
+    mkEqProof a b
+  else
+    mkHEqProof a b
+
+/--
+Returns a proof that `a = True`.
+It assumes `a` and `True` are in the same equivalence class.
+-/
+def mkEqTrueProof (a : Expr) : GoalM Expr := do
+  mkEqProof a (← getTrueExpr)
+
+/--
+Returns a proof that `a = False`.
+It assumes `a` and `False` are in the same equivalence class.
+-/
+def mkEqFalseProof (a : Expr) : GoalM Expr := do
+  mkEqProof a (← getFalseExpr)
+
+/-- Marks current goal as inconsistent without assigning `mvarId`. -/
+def markAsInconsistent : GoalM Unit := do
+  modify fun s => { s with inconsistent := true }
+
+/--
+Closes the current goal using the given proof of `False` and
+marks it as inconsistent if it is not already marked so.
+-/
+def closeGoal (falseProof : Expr) : GoalM Unit := do
+  markAsInconsistent
+  let mvarId := (← get).mvarId
+  unless (← mvarId.isAssigned) do
+    let target ← mvarId.getType
+    if target.isFalse then
+      mvarId.assign falseProof
+    else
+      mvarId.assign (← mkFalseElim target falseProof)
+
+/-- Returns all enodes in the goal -/
+def getENodes : GoalM (Array ENode) := do
+  -- 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
-  -- We must sort because we are using pointer addresses to hash
-  let nodes := (← get).enodes.toArray.map (·.2)
-  let nodes := nodes.qsort fun a b => a.idx < b.idx
+  let nodes ← getENodes
   for n in nodes do
     f n
 
@@ -256,4 +671,59 @@ def filterENodes (p : ENode → GoalM Bool) : GoalM (Array ENode) := do
       ref.modify (·.push n)
   ref.get
 
+def forEachEqc (f : ENode → GoalM Unit) : GoalM Unit := do
+  let nodes ← getENodes
+  for n in nodes do
+    if isSameExpr n.self n.root then
+      f n
+
+abbrev Propagator := Expr → GoalM Unit
+abbrev Fallback := GoalM Unit
+
+structure Methods where
+  propagateUp   : Propagator := fun _ => return ()
+  propagateDown : Propagator := fun _ => return ()
+  fallback      : Fallback := pure ()
+  deriving Inhabited
+
+def Methods.toMethodsRef (m : Methods) : MethodsRef :=
+  unsafe unsafeCast m
+
+private def MethodsRef.toMethods (m : MethodsRef) : Methods :=
+  unsafe unsafeCast m
+
+@[inline] def getMethods : GrindM Methods :=
+  return (← getMethodsRef).toMethods
+
+def propagateUp (e : Expr) : GoalM Unit := do
+  (← getMethods).propagateUp e
+
+def propagateDown (e : Expr) : GoalM Unit := do
+  (← getMethods).propagateDown e
+
+def applyFallback : GoalM Unit := do
+  let fallback : GoalM Unit := (← getMethods).fallback
+  fallback
+
+/-- Returns expressions in the given expression equivalence class. -/
+partial def getEqc (e : Expr) : GoalM (List Expr) :=
+  go e e []
+where
+  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
+
+/-- Returns all equivalence classes in the current goal. -/
+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 := (← getEqc node.self) :: r
+  return r
+
 end Lean.Meta.Grind

src/Lean/Meta/Tactic/Grind/Util.lean

@@ -100,12 +100,14 @@ def _root_.Lean.MVarId.clearAuxDecls (mvarId : MVarId) : MetaM MVarId := mvarId.
 /--
 In the `grind` tactic, during `Expr` internalization, we don't expect to find `Expr.mdata`.
 This function ensures `Expr.mdata` is not found during internalization.
-Recall that we do not internalize `Expr.forallE` and `Expr.lam` components.
+Recall that we do not internalize `Expr.lam` children.
+Recall that we still have to process `Expr.forallE` because of `ForallProp.lean`.
+Moreover, we may not want to reduce `p → q` to `¬p ∨ q` when `(p q : Prop)`.
 -/
 def eraseIrrelevantMData (e : Expr) : CoreM Expr := do
   let pre (e : Expr) := do
     match e with
-    | .letE .. | .lam .. | .forallE .. => return .done e
+    | .letE .. | .lam .. => return .done e
     | .mdata _ e => return .continue e
     | _ => return .continue e
   Core.transform e (pre := pre)
@@ -116,11 +118,14 @@ Converts nested `Expr.proj`s into projection applications if possible.
 def foldProjs (e : Expr) : MetaM Expr := do
   let post (e : Expr) := do
     let .proj structName idx s := e | return .done e
-    let some info := getStructureInfo? (← getEnv) structName | return .done e
+    let some info := getStructureInfo? (← getEnv) structName |
+      trace[grind.issues] "found `Expr.proj` but `{structName}` is not marked as structure{indentExpr e}"
+      return .done e
     if h : idx < info.fieldNames.size then
       let fieldName := info.fieldNames[idx]
       return .done (← mkProjection s fieldName)
     else
+      trace[grind.issues] "found `Expr.proj` with invalid field index `{idx}`{indentExpr e}"
       return .done e
   Meta.transform e (post := post)
 

src/Lean/Meta/Tactic/Simp/BuiltinSimprocs/Int.lean

@@ -49,17 +49,13 @@ If they do, they must disable the following `simprocs`.
 -/
 
 builtin_dsimproc [simp, seval] reduceNeg ((- _ : Int)) := fun e => do
-  unless e.isAppOfArity ``Neg.neg 3 do return .continue
-  let arg := e.appArg!
+  let_expr Neg.neg _ _ arg ← e | return .continue
   if arg.isAppOfArity ``OfNat.ofNat 3 then
     -- We return .done to ensure `Neg.neg` is not unfolded even when `ground := true`.
     return .done e
   else
     let some v ← fromExpr? arg | return .continue
-    if v < 0 then
-      return .done <| toExpr (- v)
-    else
-      return .done <| toExpr v
+    return .done <| toExpr (- v)
 
 /-- Return `.done` for positive Int values. We don't want to unfold in the symbolic evaluator. -/
 builtin_dsimproc [seval] isPosValue ((OfNat.ofNat _ : Int)) := fun e => do

src/Lean/Meta/Tactic/Simp/Main.lean

@@ -47,6 +47,17 @@ def isOfScientificLit (e : Expr) : Bool :=
 def isCharLit (e : Expr) : Bool :=
   e.isAppOfArity ``Char.ofNat 1 && e.appArg!.isRawNatLit
 
+/--
+Unfold definition even if it is not marked as `@[reducible]`.
+Remark: We never unfold irreducible definitions. Mathlib relies on that in the implementation of the
+command `irreducible_def`.
+-/
+private def unfoldDefinitionAny? (e : Expr) : MetaM (Option Expr) := do
+  if let .const declName _ := e.getAppFn then
+    if (← isIrreducible declName) then
+      return none
+  unfoldDefinition? e (ignoreTransparency := true)
+
 private def reduceProjFn? (e : Expr) : SimpM (Option Expr) := do
   matchConst e.getAppFn (fun _ => pure none) fun cinfo _ => do
     match (← getProjectionFnInfo? cinfo.name) with
@@ -83,7 +94,7 @@ private def reduceProjFn? (e : Expr) : SimpM (Option Expr) := do
           let major := e.getArg! projInfo.numParams
           unless (← isConstructorApp major) do
             return none
-          reduceProjCont? (← withDefault <| unfoldDefinition? e)
+          reduceProjCont? (← unfoldDefinitionAny? e)
       else
         -- `structure` projections
         reduceProjCont? (← unfoldDefinition? e)
@@ -133,7 +144,7 @@ private def unfold? (e : Expr) : SimpM (Option Expr) := do
     if cfg.unfoldPartialApp -- If we are unfolding partial applications, ignore issue #2042
        -- When smart unfolding is enabled, and `f` supports it, we don't need to worry about issue #2042
        || (smartUnfolding.get options && (← getEnv).contains (mkSmartUnfoldingNameFor fName)) then
-      withDefault <| unfoldDefinition? e
+      unfoldDefinitionAny? e
     else
       -- `We are not unfolding partial applications, and `fName` does not have smart unfolding support.
       -- Thus, we must check whether the arity of the function >= number of arguments.
@@ -142,16 +153,16 @@ private def unfold? (e : Expr) : SimpM (Option Expr) := do
       let arity := value.getNumHeadLambdas
       -- Partially applied function, return `none`. See issue #2042
       if arity > e.getAppNumArgs then return none
-      withDefault <| unfoldDefinition? e
+      unfoldDefinitionAny? e
   if (← isProjectionFn fName) then
     return none -- should be reduced by `reduceProjFn?`
   else if ctx.config.autoUnfold then
     if ctx.simpTheorems.isErased (.decl fName) then
       return none
     else if hasSmartUnfoldingDecl (← getEnv) fName then
-      withDefault <| unfoldDefinition? e
+      unfoldDefinitionAny? e
     else if (← isMatchDef fName) then
-      let some value ← withDefault <| unfoldDefinition? e | return none
+      let some value ← unfoldDefinitionAny? e | return none
       let .reduced value ← withSimpMetaConfig <| reduceMatcher? value | return none
       return some value
     else

src/Lean/Meta/WHNF.lean

@@ -64,10 +64,38 @@ def isAuxDef (constName : Name) : MetaM Bool := do
   let env ← getEnv
   return isAuxRecursor env constName || isNoConfusion env constName
 
-@[inline] private def matchConstAux {α} (e : Expr) (failK : Unit → MetaM α) (k : ConstantInfo → List Level → MetaM α) : MetaM α := do
-  let .const name lvls := e
+/--
+Retrieves `ConstInfo` for `declName`.
+Remark: if `ignoreTransparency = false`, then `getUnfoldableConst?` is used.
+For example, if `ignoreTransparency = false` and `transparencyMode = .reducible` and `declName` is not reducible,
+then the result is `none`.
+-/
+private def getConstInfo? (declName : Name) (ignoreTransparency : Bool) : MetaM (Option ConstantInfo) := do
+  if ignoreTransparency then
+    return (← getEnv).find? declName
+  else
+    getUnfoldableConst? declName
+
+/--
+Similar to `getConstInfo?` but using `getUnfoldableConstNoEx?`.
+-/
+private def getConstInfoNoEx? (declName : Name) (ignoreTransparency : Bool) : MetaM (Option ConstantInfo) := do
+  if ignoreTransparency then
+    return (← getEnv).find? declName
+  else
+    getUnfoldableConstNoEx? declName
+
+/--
+If `e` is of the form `Expr.const declName us`, executes `k info us` if
+- `declName` is in the `Environment` and (is unfoldable or `ignoreTransparency = true`)
+- `info` is the `ConstantInfo` associated with `declName`.
+
+Otherwise executes `failK`.
+-/
+@[inline] private def matchConstAux {α} (e : Expr) (failK : Unit → MetaM α) (k : ConstantInfo → List Level → MetaM α) (ignoreTransparency := false) : MetaM α := do
+  let .const declName lvls := e
     | failK ()
-  let (some cinfo) ← getUnfoldableConst? name
+  let some cinfo ← getConstInfo? declName ignoreTransparency
     | failK ()
   k cinfo lvls
 
@@ -713,11 +741,14 @@ mutual
     else
       unfoldProjInst? e
 
-  /-- Unfold definition using "smart unfolding" if possible. -/
-  partial def unfoldDefinition? (e : Expr) : MetaM (Option Expr) :=
+  /--
+  Unfold definition using "smart unfolding" if possible.
+  If `ignoreTransparency = true`, then the definition is unfolded even if the transparency setting does not allow it.
+  -/
+  partial def unfoldDefinition? (e : Expr) (ignoreTransparency := false) : MetaM (Option Expr) :=
     match e with
     | .app f _ =>
-      matchConstAux f.getAppFn (fun _ => unfoldProjInstWhenInstances? e) fun fInfo fLvls => do
+      matchConstAux (ignoreTransparency := ignoreTransparency) f.getAppFn (fun _ => unfoldProjInstWhenInstances? e) fun fInfo fLvls => do
         if fInfo.levelParams.length != fLvls.length then
           return none
         else
@@ -756,7 +787,8 @@ mutual
 
                   Remark 2: the match expression reduces reduces to `cons a xs` when the discriminants are `⟨0, h⟩` and `xs`.
 
-                  Remark 3: this check is unnecessary in most cases, but we don't need dependent elimination to trigger the issue                        fixed by this extra check. Here is another example that triggers the issue fixed by this check.
+                  Remark 3: this check is unnecessary in most cases, but we don't need dependent elimination to trigger the issue
+                  fixed by this extra check. Here is another example that triggers the issue fixed by this check.
                   ```
                   def f : Nat → Nat → Nat
                     | 0,   y   => y
@@ -788,7 +820,7 @@ mutual
           else
             unfoldDefault ()
     | .const declName lvls => do
-      let some cinfo ← getUnfoldableConstNoEx? declName | pure none
+      let some cinfo ← getConstInfoNoEx? declName ignoreTransparency | pure none
       -- check smart unfolding only after `getUnfoldableConstNoEx?` because smart unfoldings have a
       -- significant chance of not existing and `Environment.contains` misses are more costly
       if smartUnfolding.get (← getOptions) && (← getEnv).contains (mkSmartUnfoldingNameFor declName) then

src/Lean/PrettyPrinter/Delaborator/Basic.lean

@@ -123,6 +123,15 @@ unsafe def mkDelabAttribute : IO (KeyedDeclsAttribute Delab) :=
   } `Lean.PrettyPrinter.Delaborator.delabAttribute
 @[builtin_init mkDelabAttribute] opaque delabAttribute : KeyedDeclsAttribute Delab
 
+/--
+`@[app_delab c]` registers a delaborator for applications with head constant `c`.
+Such delaborators also apply to the constant `c` itself (known as a "nullary application").
+
+This attribute should be applied to definitions of type `Lean.PrettyPrinter.Delaborator.Delab`.
+
+When defining delaborators for constant applications, one should prefer this attribute over `@[delab app.c]`,
+as `@[app_delab c]` first performs name resolution on `c` in the current scope.
+-/
 macro "app_delab" id:ident : attr => do
   match ← Macro.resolveGlobalName id.getId with
   | [] => Macro.throwErrorAt id s!"unknown declaration '{id.getId}'"

src/Lean/PrettyPrinter/Delaborator/Builtins.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Sebastian Ullrich, Leonardo de Moura, Gabriel Ebner, Mario Carneiro
 -/
 prelude
-import Lean.Parser
 import Lean.PrettyPrinter.Delaborator.Attributes
 import Lean.PrettyPrinter.Delaborator.Basic
 import Lean.PrettyPrinter.Delaborator.SubExpr

src/Lean/Server/Completion.lean

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura, Marc Huisinga
 -/
 prelude
 import Lean.Server.Completion.CompletionCollectors
+import Std.Data.HashMap
 
 namespace Lean.Server.Completion
 open Lsp

src/Lean/ToExpr.lean

@@ -14,10 +14,15 @@ namespace Lean
 /--
 We use the `ToExpr` type class to convert values of type `α` into
 expressions that denote these values in Lean.
-Example:
+
+Examples:
 ```
 toExpr true = .const ``Bool.true []
+
+toTypeExpr Bool = .const ``Bool []
 ```
+
+See also `ToLevel` for representing universe levels as `Level` expressions.
 -/
 class ToExpr (α : Type u) where
   /-- Convert a value `a : α` into an expression that denotes `a` -/

src/Lean/Util/ShareCommon.lean

@@ -5,8 +5,8 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.ShareCommon
-import Std.Data.HashSet
-import Std.Data.HashMap
+import Std.Data.HashSet.Basic
+import Std.Data.HashMap.Basic
 import Lean.Data.PersistentHashMap
 import Lean.Data.PersistentHashSet
 

src/Std/Sat/AIG/Basic.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Henrik Böving
 -/
 prelude
-import Std.Data.HashMap
 import Std.Data.HashSet
 
 namespace Std

src/Std/Tactic/BVDecide/Bitblast/BVExpr/Basic.lean

@@ -293,8 +293,15 @@ The semantics for `BVExpr`.
 -/
 def eval (assign : Assignment) : BVExpr w → BitVec w
   | .var idx =>
-    let ⟨bv⟩ := assign.get idx
-    bv.truncate w
+    let packedBv := assign.get idx
+    /-
+    This formulation improves performance, as in a well formed expression the condition always holds
+    so there is no need for the more involved `BitVec.truncate` logic.
+    -/
+    if h : packedBv.w = w then
+      h ▸ packedBv.bv
+    else
+      packedBv.bv.truncate w
   | .const val => val
   | .zeroExtend v expr => BitVec.zeroExtend v (eval assign expr)
   | .extract start len expr => BitVec.extractLsb' start len (eval assign expr)
@@ -308,8 +315,13 @@ def eval (assign : Assignment) : BVExpr w → BitVec w
   | .arithShiftRight lhs rhs => BitVec.sshiftRight' (eval assign lhs) (eval assign rhs)
 
 @[simp]
-theorem eval_var : eval assign ((.var idx) : BVExpr w) = (assign.get idx).bv.truncate _ := by
-  rfl
+theorem eval_var : eval assign ((.var idx) : BVExpr w) = (assign.get idx).bv.truncate w := by
+  rw [eval]
+  split
+  · next h =>
+    subst h
+    simp
+  · rfl
 
 @[simp]
 theorem eval_const : eval assign (.const val) = val := by rfl
@@ -454,7 +466,7 @@ def eval (assign : BVExpr.Assignment) (expr : BVLogicalExpr) : Bool :=
 @[simp] theorem eval_not : eval assign (.not x) = !eval assign x := rfl
 @[simp] theorem eval_gate : eval assign (.gate g x y) = g.eval (eval assign x) (eval assign y) := rfl
 @[simp] theorem eval_ite :
-  eval assign (.ite d l r) = if (eval assign d) then (eval assign l) else (eval assign r) := rfl
+  eval assign (.ite d l r) = bif (eval assign d) then (eval assign l) else (eval assign r) := rfl
 
 def Sat (x : BVLogicalExpr) (assign : BVExpr.Assignment) : Prop := eval assign x = true
 

src/Std/Tactic/BVDecide/Bitblast/BoolExpr/Basic.lean

@@ -18,7 +18,7 @@ inductive Gate
   | and
   | xor
   | beq
-  | imp
+  | or
 
 namespace Gate
 
@@ -26,13 +26,13 @@ def toString : Gate → String
   | and => "&&"
   | xor => "^^"
   | beq => "=="
-  | imp => "->"
+  | or => "||"
 
 def eval : Gate → Bool → Bool → Bool
   | and => (· && ·)
   | xor => (· ^^ ·)
   | beq => (· == ·)
-  | imp => (· → ·)
+  | or => (· || ·)
 
 end Gate
 
@@ -59,13 +59,13 @@ def eval (a : α → Bool) : BoolExpr α → Bool
   | .const b => b
   | .not x => !eval a x
   | .gate g x y => g.eval (eval a x) (eval a y)
-  | .ite d l r => if d.eval a then l.eval a else r.eval a
+  | .ite d l r => bif d.eval a then l.eval a else r.eval a
 
 @[simp] theorem eval_literal : eval a (.literal l) = a l := rfl
 @[simp] theorem eval_const : eval a (.const b) = b := rfl
 @[simp] theorem eval_not : eval a (.not x) = !eval a x := rfl
 @[simp] theorem eval_gate : eval a (.gate g x y) = g.eval (eval a x) (eval a y) := rfl
-@[simp] theorem eval_ite : eval a (.ite d l r) = if d.eval a then l.eval a else r.eval a := rfl
+@[simp] theorem eval_ite : eval a (.ite d l r) = bif d.eval a then l.eval a else r.eval a := rfl
 
 def Sat (a : α → Bool) (x : BoolExpr α) : Prop := eval a x = true
 def Unsat (x : BoolExpr α) : Prop := ∀ f, eval f x = false

src/Std/Tactic/BVDecide/Bitblast/BoolExpr/Circuit.lean

@@ -75,9 +75,9 @@ where
         let ret := aig.mkBEqCached input
         have := LawfulOperator.le_size (f := mkBEqCached) aig input
         ⟨ret, by dsimp only [ret] at lextend rextend ⊢; omega⟩
-      | .imp =>
-        let ret := aig.mkImpCached input
-        have := LawfulOperator.le_size (f := mkImpCached) aig input
+      | .or =>
+        let ret := aig.mkOrCached input
+        have := LawfulOperator.le_size (f := mkOrCached) aig input
         ⟨ret, by dsimp only [ret] at lextend rextend ⊢; omega⟩
 
 namespace ofBoolExprCached
@@ -127,9 +127,9 @@ theorem go_decl_eq (idx) (aig : AIG β) (h : idx < aig.decls.size) (hbounds) :
     | beq =>
       simp only [go]
       rw [AIG.LawfulOperator.decl_eq (f := mkBEqCached), rih, lih]
-    | imp =>
+    | or =>
       simp only [go]
-      rw [AIG.LawfulOperator.decl_eq (f := mkImpCached), rih, lih]
+      rw [AIG.LawfulOperator.decl_eq (f := mkOrCached), rih, lih]
 
 theorem go_isPrefix_aig {aig : AIG β} :
     IsPrefix aig.decls (go aig expr atomHandler).val.aig.decls := by

src/Std/Tactic/BVDecide/LRAT/Internal/Formula/Implementation.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Josh Clune
 -/
 prelude
-import Init.Data.Array
 import Std.Tactic.BVDecide.LRAT.Internal.Formula.Class
 import Std.Tactic.BVDecide.LRAT.Internal.Assignment
 import Std.Sat.CNF.Basic

src/Std/Tactic/BVDecide/Normalize/BitVec.lean

@@ -118,7 +118,6 @@ theorem BitVec.srem_umod (x y : BitVec w) :
   rw [BitVec.srem_eq]
   cases x.msb <;> cases y.msb <;> simp
 
-attribute [bv_normalize] Bool.cond_eq_if
 attribute [bv_normalize] BitVec.abs_eq
 attribute [bv_normalize] BitVec.twoPow_eq
 

src/Std/Tactic/BVDecide/Normalize/Bool.lean

@@ -41,7 +41,14 @@ attribute [bv_normalize] Bool.not_not
 attribute [bv_normalize] Bool.and_self_left
 attribute [bv_normalize] Bool.and_self_right
 attribute [bv_normalize] eq_self
-attribute [bv_normalize] ite_self
+attribute [bv_normalize] Bool.cond_self
+attribute [bv_normalize] cond_false
+attribute [bv_normalize] cond_true
+attribute [bv_normalize] Bool.cond_not
+
+@[bv_normalize]
+theorem if_eq_cond {b : Bool} {x y : α} : (if b = true then x else y) = (bif b then x else y) := by
+  rw [cond_eq_if]
 
 @[bv_normalize]
 theorem Bool.not_xor : ∀ (a b : Bool), !(a ^^ b) = (a == b) := by decide

src/Std/Tactic/BVDecide/Normalize/Prop.lean

@@ -13,8 +13,6 @@ This module contains the `Prop` simplifying part of the `bv_normalize` simp set.
 namespace Std.Tactic.BVDecide
 namespace Frontend.Normalize
 
-attribute [bv_normalize] ite_true
-attribute [bv_normalize] ite_false
 attribute [bv_normalize] dite_true
 attribute [bv_normalize] dite_false
 attribute [bv_normalize] and_true

src/Std/Tactic/BVDecide/Reflect.lean

@@ -123,12 +123,12 @@ theorem umod_congr (lhs rhs lhs' rhs' : BitVec w) (h1 : lhs' = lhs) (h2 : rhs' =
     (lhs' % rhs') = (lhs % rhs) := by
   simp[*]
 
-theorem if_true (discr : Bool) (lhs rhs : BitVec w) :
-    decide ((discr == true) = true → ((if discr = true then lhs else rhs) == lhs) = true) = true := by
+theorem cond_true (discr : Bool) (lhs rhs : BitVec w) :
+    (!discr || ((bif discr then lhs else rhs) == lhs)) = true := by
   cases discr <;> simp
 
-theorem if_false (discr : Bool) (lhs rhs : BitVec w) :
-    decide ((discr == false) = true → ((if discr = true then lhs else rhs) == rhs) = true) = true := by
+theorem cond_false (discr : Bool) (lhs rhs : BitVec w) :
+    (discr || ((bif discr then lhs else rhs) == rhs)) = true := by
   cases discr <;> simp
 
 end BitVec
@@ -150,13 +150,13 @@ theorem beq_congr (lhs rhs lhs' rhs' : Bool) (h1 : lhs' = lhs) (h2 : rhs' = rhs)
     (lhs' == rhs') = (lhs == rhs) := by
   simp[*]
 
-theorem imp_congr (lhs rhs lhs' rhs' : Bool) (h1 : lhs' = lhs) (h2 : rhs' = rhs) :
-    (decide (lhs' → rhs')) = (decide (lhs → rhs)) := by
+theorem or_congr (lhs rhs lhs' rhs' : Bool) (h1 : lhs' = lhs) (h2 : rhs' = rhs) :
+    (lhs' || rhs') = (lhs || rhs) := by
   simp[*]
 
-theorem ite_congr (discr lhs rhs discr' lhs' rhs' : Bool) (h1 : discr' = discr) (h2 : lhs' = lhs)
+theorem cond_congr (discr lhs rhs discr' lhs' rhs' : Bool) (h1 : discr' = discr) (h2 : lhs' = lhs)
     (h3 : rhs' = rhs) :
-    (if discr' = true then lhs' else rhs') = (if discr = true then lhs else rhs) := by
+    (bif discr' then lhs' else rhs') = (bif discr then lhs else rhs) := by
   simp[*]
 
 theorem false_of_eq_true_of_eq_false (h₁ : x = true) (h₂ : x = false) : False := by

src/Std/Time/DateTime/Timestamp.lean

@@ -5,7 +5,6 @@ Authors: Sofia Rodrigues
 -/
 prelude
 import Std.Time.Internal
-import Init.Data.Int
 import Init.System.IO
 import Std.Time.Time
 import Std.Time.Date

src/Std/Time/Internal/Bounded.lean

@@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Sofia Rodrigues
 -/
 prelude
-import Init.Data.Int
+import Init.Omega
 
 namespace Std
 namespace Time