Update src/Lean/Meta/Tactic/Apply.lean

Co-authored-by: Kyle Miller <kmill31415@gmail.com>

.github/workflows/ci.yml

@@ -140,10 +140,12 @@ jobs:
                 "shell": "msys2 {0}",
                 "CMAKE_OPTIONS": "-G \"Unix Makefiles\" -DUSE_GMP=OFF",
                 // for reasons unknown, interactivetests are flaky on Windows
-                "CTEST_OPTIONS": "--repeat until-pass:2",
+                // also, the liasolver test hits “too many exported symbols”
+                "CTEST_OPTIONS": "--repeat until-pass:2 -E 'leanbenchtest_liasolver.lean'",
                 "llvm-url": "https://github.com/leanprover/lean-llvm/releases/download/15.0.1/lean-llvm-x86_64-w64-windows-gnu.tar.zst",
                 "prepare-llvm": "../script/prepare-llvm-mingw.sh lean-llvm*",
-                "binary-check": "ldd"
+                // TEMP while compiler tests are deactivated
+                "binary-check": "true"
               },
               {
                 "name": "Linux aarch64",

.github/workflows/nix-ci.yml

@@ -6,6 +6,7 @@ on:
     tags:
       - '*'
   pull_request:
+    types: [opened, synchronize, reopened, labeled]
   merge_group:
 
 concurrency:

RELEASES.md

@@ -8,7 +8,61 @@ This file contains work-in-progress notes for the upcoming release, as well as p
 Please check the [releases](https://github.com/leanprover/lean4/releases) page for the current status
 of each version.
 
-v4.7.0 (development in progress)
+v4.8.0 (development in progress)
+---------
+
+* Lean now generates an error if the type of a theorem is **not** a proposition.
+
+* Importing two different files containing proofs of the same theorem is no longer considered an error. This feature is particularly useful for theorems that are automatically generated on demand (e.g., equational theorems).
+
+* New command `derive_functinal_induction`:
+
+  Derived from the definition of a (possibly mutually) recursive function
+  defined by well-founded recursion, a **functional induction principle** is
+  tailored to proofs about that function. For example from:
+  ```
+  def ackermann : Nat → Nat → Nat
+    | 0, m => m + 1
+    | n+1, 0 => ackermann n 1
+    | n+1, m+1 => ackermann n (ackermann (n + 1) m)
+  derive_functional_induction ackermann
+  ```
+  we get
+  ```
+  ackermann.induct (motive : Nat → Nat → Prop) (case1 : ∀ (m : Nat), motive 0 m)
+    (case2 : ∀ (n : Nat), motive n 1 → motive (Nat.succ n) 0)
+    (case3 : ∀ (n m : Nat), motive (n + 1) m → motive n (ackermann (n + 1) m) → motive (Nat.succ n) (Nat.succ m))
+    (x x : Nat) : motive x x
+  ```
+
+Breaking changes:
+
+* Automatically generated equational theorems are now named using suffix `.eq_<idx>` instead of `._eq_<idx>`, and `.def` instead of `._unfold`. Example:
+```
+def fact : Nat → Nat
+  | 0 => 1
+  | n+1 => (n+1) * fact n
+
+theorem ex : fact 0 = 1 := by unfold fact; decide
+
+#check fact.eq_1
+-- fact.eq_1 : fact 0 = 1
+
+#check fact.eq_2
+-- fact.eq_2 (n : Nat) : fact (Nat.succ n) = (n + 1) * fact n
+
+#check fact.def
+/-
+fact.def :
+  ∀ (x : Nat),
+    fact x =
+      match x with
+      | 0 => 1
+      | Nat.succ n => (n + 1) * fact n
+-/
+```
+
+v4.7.0
 ---------
 
 * `simp` and `rw` now use instance arguments found by unification,

doc/SUMMARY.md

@@ -89,5 +89,6 @@
 - [Testing](./dev/testing.md)
 - [Debugging](./dev/debugging.md)
 - [Commit Convention](./dev/commit_convention.md)
+- [Release checklist](./dev/release_checklist.md)
 - [Building This Manual](./dev/mdbook.md)
 - [Foreign Function Interface](./dev/ffi.md)

doc/dev/ffi.md

@@ -111,6 +111,15 @@ if (lean_io_result_is_ok(res)) {
 lean_io_mark_end_initialization();
 ```
 
+In addition, any other thread not spawned by the Lean runtime itself must be initialized for Lean use by calling
+```c
+void lean_initialize_thread();
+```
+and should be finalized in order to free all thread-local resources by calling
+```c
+void lean_finalize_thread();
+```
+
 ## `@[extern]` in the Interpreter
 
 The interpreter can run Lean declarations for which symbols are available in loaded shared libraries, which includes `@[extern]` declarations.

doc/dev/release_checklist.md

@@ -0,0 +1,201 @@
+# Releasing a stable version
+
+This checklist walks you through releasing a stable version.
+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 someone has written the first draft of the release blog post
+- `git checkout releases/v4.6.0`
+  (This branch should already exist, from the release candidates.)
+- `git pull`
+- In `src/CMakeLists.txt`, verify you see
+  - `set(LEAN_VERSION_MINOR 6)` (for whichever `6` is appropriate)
+  - `set(LEAN_VERSION_IS_RELEASE 1)`
+  - (both of these should already be in place from the release candidates)
+- It is possible that the `v4.6.0` section of `RELEASES.md` is out of sync between
+  `releases/v4.6.0` and `master`. This should be reconciled:
+  - Run `git diff master RELEASES.md`.
+  - You should expect to see additons on `master` in the `v4.7.0-rc1` section; ignore these.
+    (i.e. the new release notes for the upcoming release candidate).
+  - Reconcile discrepancies in the `v4.6.0` section,
+    usually via copy and paste and a commit to `releases/v4.6.0`.
+- `git tag v4.6.0`
+- `git push origin v4.6.0`
+- Now wait, while CI runs.
+  - You can monitor this at `https://github.com/leanprover/lean4/actions/workflows/ci.yml`,
+    looking for the `v4.6.0` tag.
+  - This step can take up to an hour.
+  - If you are intending to cut the next release candidate on the same day,
+    you may want to start on the release candidate checklist now.
+- Go to https://github.com/leanprover/lean4/releases and verify that the `v4.6.0` release appears.
+  - Edit the release notes on Github to select the "Set as the latest release".
+  - Copy and paste the Github release notes from the previous releases candidate for this version
+    (e.g. `v4.6.0-rc1`), and quickly sanity check.
+- Next, we will move a curated list of downstream repos to the latest stable release.
+  - For each of the repositories listed below:
+    - Make a PR to `master`/`main` changing the toolchain to `v4.6.0`.
+      The PR title should be "chore: bump toolchain to v4.6.0".
+      Since the `v4.6.0` release should be functionally identical to the last release candidate,
+      which the repository should already be on, this PR is a no-op besides changing the toolchain.
+    - Once this is merged, create the tag `v4.6.0` from `master`/`main` and push it.
+    - Merge the tag `v4.6.0` into the stable branch.
+  - We do this for the repositories:
+    - [lean4checker](https://github.com/leanprover/lean4checker)
+      - `lean4checker` uses a different version tagging scheme: use `toolchain/v4.6.0` rather than `v4.6.0`.
+    - [Std](https://github.com/leanprover-community/repl)
+    - [ProofWidgets4](https://github.com/leanprover-community/ProofWidgets4)
+      - `ProofWidgets` uses a sequential version tagging scheme, e.g. `v0.0.29`,
+        which does not refer to the toolchain being used.
+      - Make a new release in this sequence after merging the toolchain bump PR.
+      - `ProofWidgets` does not maintain a `stable` branch.
+    - [Aesop](https://github.com/leanprover-community/aesop)
+    - [Mathlib](https://github.com/leanprover-community/mathlib4)
+      - In addition to updating the `lean-toolchain` and `lakefile.lean`,
+        in `.github/workflows/build.yml.in` in the `lean4checker` section update the line
+        `git checkout toolchain/v4.6.0` to the appropriate tag,
+        and then run `.github/workflows/mk_build_yml.sh`.
+    - [REPL](https://github.com/leanprover-community/repl)
+      - Note that there are two copies of `lean-toolchain`/`lakefile.lean`:
+        in the root, and in `test/Mathlib/`.
+  - Note that there are dependencies between these packages:
+    you should update the lakefile so that you are using the `v4.6.0` tag of upstream repositories
+    (or the sequential tag for `ProofWidgets4`), and run `lake update` before committing.
+  - This means that this process is sequential; each repository must have its bump PR merged,
+    and the new tag pushed, before you can make the PR for the downstream repositories.
+    - `lean4checker` has no dependencies
+    - `Std` has no dependencies
+    - `Aesop` depends on `Std`
+    - `ProofWidgets4` depends on `Std`
+    - `Mathlib` depends on `Aesop`, `ProofWidgets4`, and `lean4checker` (and transitively on `Std`)
+    - `REPL` depends on `Mathlib` (this dependency is only for testing).
+- Merge the release announcement PR for the Lean website - it will be deployed automatically
+- Finally, make an announcement!
+  This should go in https://leanprover.zulipchat.com/#narrow/stream/113486-announce, with topic `v4.6.0`.
+  Please see previous announcements for suggested language.
+  You will want a few bullet points for main topics from the release notes.
+  Link to the blog post from the Zulip announcement.
+  Please also make sure that whoever is handling social media knows the release is out.
+
+## Optimistic(?) time estimates:
+- Initial checks and push the tag: 30 minutes.
+- Note that if `RELEASES.md` has discrepancies this could take longer!
+- Waiting for the release: 60 minutes.
+- Fixing release notes: 10 minutes.
+- Bumping toolchains in downstream repositories, up to creating the Mathlib PR: 30 minutes.
+- Waiting for Mathlib CI and bors: 120 minutes.
+- Finalizing Mathlib tags and stable branch, and updating REPL: 15 minutes.
+- Posting announcement and/or blog post: 20 minutes.
+
+# Creating a release candidate.
+
+This checklist walks you through creating the first release candidate for a version of Lean.
+
+We'll use `v4.7.0-rc1` as the intended release version in this example.
+
+- Decide which nightly release you want to turn into a release candidate.
+  We will use `nightly-2024-02-29` in this example.
+- It is essential that Std and Mathlib already have reviewed branches compatible with this nightly.
+  - Check that both Std and Mathlib's `bump/v4.7.0` branch contain `nightly-2024-02-29`
+    in their `lean-toolchain`.
+  - The steps required to reach that state are beyond the scope of this checklist, but see below!
+- Create the release branch from this nightly tag:
+    ```
+    git remote add nightly https://github.com/leanprover/lean4-nightly.git
+    git fetch nightly tag nightly-2024-02-29
+    git checkout nightly-2024-02-29
+    git checkout -b releases/v4.7.0
+    ```
+- In `RELEASES.md` remove `(development in progress)` from the `v4.7.0` section header.
+- Our current goal is to have written release notes only about major language features or breaking changes,
+  and to rely on automatically generated release notes for bugfixes and minor changes.
+  - Do not wait on `RELEASES.md` being perfect before creating the `release/v4.7.0` branch. It is essential to choose the nightly which will become the release candidate as early as possible, to avoid confusion.
+  - If there are major changes not reflected in `RELEASES.md` already, you may need to solicit help from the authors.
+  - Minor changes and bug fixes do not need to be documented in `RELEASES.md`: they will be added automatically on the Github release page.
+  - Commit your changes to `RELEASES.md`, and push.
+  - Remember that changes to `RELEASES.md` after you have branched `releases/v4.7.0` should also be cherry-picked back to `master`.
+- 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`
+- 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.
+- Once the release appears at https://github.com/leanprover/lean4/releases/
+  - Edit the release notes on Github to select the "Set as a pre-release box".
+  - Copy the section of `RELEASES.md` for this version into the Github release notes.
+  - Use the title "Changes since v4.6.0 (from RELEASES.md)"
+  - Then in the "previous tag" dropdown, select `v4.6.0`, and click "Generate release notes".
+  - This will add a list of all the commits since the last stable version.
+    - Delete anything already mentioned in the hand-written release notes above.
+    - Delete "update stage0" commits, and anything with a completely inscrutable commit message.
+    - Briefly rearrange the remaining items by category (e.g. `simp`, `lake`, `bug fixes`),
+      but for minor items don't put any work in expanding on commit messages.
+  - (How we want to release notes to look is evolving: please update this section if it looks wrong!)
+- Next, we will move a curated list of downstream repos to the release candidate.
+  - This assumes that there is already a *reviewed* branch `bump/v4.7.0` on each repository
+    containing the required adaptations (or no adaptations are required).
+    The preparation of this branch is beyond the scope of this document.
+  - For each of the target repositories:
+    - Checkout the `bump/v4.7.0` branch.
+    - Verify that the `lean-toolchain` is set to the nightly from which the release candidate was created.
+    - `git merge origin/master`
+    - Change the `lean-toolchain` to `leanprover/lean4:v4.7.0-rc1`
+    - In `lakefile.lean`, change any dependencies which were using `nightly-testing` or `bump/v4.7.0` branches
+      back to `master` or `main`, and run `lake update` for those dependencies.
+    - Run `lake build` to ensure that dependencies are found (but it's okay to stop it after a moment).
+    - `git commit`
+    - `git push`
+    - Open a PR from `bump/v4.7.0` to `master`, and either merge it yourself after CI, if appropriate,
+      or notify the maintainers that it is ready to go.
+    - Once this PR has been merged, tag `master` with `v4.7.0-rc1` and push this tag.
+  - We do this for the same list of repositories as for stable releases, see above.
+    As above, there are dependencies between these, and so the process above is iterative.
+    It greatly helps if you can merge the `bump/v4.7.0` PRs yourself!
+  - For Std/Aesop/Mathlib, which maintain a `nightly-testing` branch, make sure there is a tag
+    `nightly-testing-2024-02-29` with date corresponding to the nightly used for the release
+    (create it if not), and then on the `nightly-testing` branch `git reset --hard master`, and force push.
+- Make an announcement!
+  This should go in https://leanprover.zulipchat.com/#narrow/stream/113486-announce, with topic `v4.7.0-rc1`.
+  Please see previous announcements for suggested language.
+  You will want a few bullet points for main topics from the release notes.
+  Please also make sure that whoever is handling social media knows the release is out.
+- Begin the next development cycle (i.e. for `v4.8.0`) on the Lean repository, by making a PR that:
+  - Updates `src/CMakeLists.txt` to say `set(LEAN_VERSION_MINOR 8)`
+  - Removes `(in development)` from the section heading in `RELEASES.md` for `v4.7.0`,
+    and creates a new `v4.8.0 (in development)` section heading.
+
+## Time estimates:
+Slightly longer than the corresponding steps for a stable release.
+Similar process, but more things go wrong.
+In particular, updating the downstream repositories is significantly more work
+(because we need to merge existing `bump/v4.7.0` branches, not just update a toolchain).
+
+# Preparing `bump/v4.7.0` branches
+
+While not part of the release process per se,
+this is a brief summary of the work that goes into updating Std/Aesop/Mathlib to new versions.
+
+Please read https://leanprover-community.github.io/contribute/tags_and_branches.html
+
+* Each repo has an unreviewed `nightly-testing` branch that
+  receives commits automatically from `master`, and
+  has its toolchain updated automatically for every nightly.
+  (Note: the aesop branch is not automated, and is updated on an as needed basis.)
+  As a consequence this branch is often broken.
+  A bot posts in the (private!) "Mathlib reviewers" stream on Zulip about the status of these branches.
+* We fix the breakages by committing directly to `nightly-testing`: there is no PR process.
+  * This can either be done by the person managing this process directly,
+    or by soliciting assistance from authors of files, or generally helpful people on Zulip!
+* Each repo has a `bump/v4.7.0` which accumulates reviewed changes adapting to new versions.
+* Once `nightly-testing` is working on a given nightly, say `nightly-2024-02-15`, we:
+  * Make sure `bump/v4.7.0` is up to date with `master` (by merging `master`, no PR necessary)
+  * Create from `bump/v4.7.0` a `bump/nightly-2024-02-15` branch.
+  * In that branch, `git merge --squash nightly-testing` to bring across changes from `nightly-testing`.
+  * Sanity check changes, commit, and make a PR to `bump/v4.7.0` from the `bump/nightly-2024-02-15` branch.
+  * Solicit review, merge the PR into `bump/v4,7,0`.
+* It is always okay to merge in the following directions:
+  `master` -> `bump/v4.7.0` -> `bump/nightly-2024-02-15` -> `nightly-testing`.
+  Please remember to push any merges you make to intermediate steps!

src/CMakeLists.txt

@@ -9,7 +9,7 @@ endif()
 include(ExternalProject)
 project(LEAN CXX C)
 set(LEAN_VERSION_MAJOR 4)
-set(LEAN_VERSION_MINOR 7)
+set(LEAN_VERSION_MINOR 8)
 set(LEAN_VERSION_PATCH 0)
 set(LEAN_VERSION_IS_RELEASE 0)  # This number is 1 in the release revision, and 0 otherwise.
 set(LEAN_SPECIAL_VERSION_DESC "" CACHE STRING "Additional version description like 'nightly-2018-03-11'")

src/Init/Control/ExceptCps.lean

@@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Init.Control.Lawful
+import Init.Control.Lawful.Basic
 
 /-!
 The Exception monad transformer using CPS style.

src/Init/Control/Lawful.lean

@@ -4,373 +4,5 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Sebastian Ullrich, Leonardo de Moura, Mario Carneiro
 -/
 prelude
-import Init.SimpLemmas
-import Init.Control.Except
-import Init.Control.StateRef
-
-open Function
-
-@[simp] theorem monadLift_self [Monad m] (x : m α) : monadLift x = x :=
-  rfl
-
-class LawfulFunctor (f : Type u → Type v) [Functor f] : Prop where
-  map_const          : (Functor.mapConst : α → f β → f α) = Functor.map ∘ const β
-  id_map   (x : f α) : id <$> x = x
-  comp_map (g : α → β) (h : β → γ) (x : f α) : (h ∘ g) <$> x = h <$> g <$> x
-
-export LawfulFunctor (map_const id_map comp_map)
-
-attribute [simp] id_map
-
-@[simp] theorem id_map' [Functor m] [LawfulFunctor m] (x : m α) : (fun a => a) <$> x = x :=
-  id_map x
-
-class LawfulApplicative (f : Type u → Type v) [Applicative f] extends LawfulFunctor f : Prop where
-  seqLeft_eq  (x : f α) (y : f β)     : x <* y = const β <$> x <*> y
-  seqRight_eq (x : f α) (y : f β)     : x *> y = const α id <$> x <*> y
-  pure_seq    (g : α → β) (x : f α)   : pure g <*> x = g <$> x
-  map_pure    (g : α → β) (x : α)     : g <$> (pure x : f α) = pure (g x)
-  seq_pure    {α β : Type u} (g : f (α → β)) (x : α) : g <*> pure x = (fun h => h x) <$> g
-  seq_assoc   {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)) : h <*> (g <*> x) = ((@comp α β γ) <$> h) <*> g <*> x
-  comp_map g h x := (by
-    repeat rw [← pure_seq]
-    simp [seq_assoc, map_pure, seq_pure])
-
-export LawfulApplicative (seqLeft_eq seqRight_eq pure_seq map_pure seq_pure seq_assoc)
-
-attribute [simp] map_pure seq_pure
-
-@[simp] theorem pure_id_seq [Applicative f] [LawfulApplicative f] (x : f α) : pure id <*> x = x := by
-  simp [pure_seq]
-
-class LawfulMonad (m : Type u → Type v) [Monad m] extends LawfulApplicative m : Prop where
-  bind_pure_comp (f : α → β) (x : m α) : x >>= (fun a => pure (f a)) = f <$> x
-  bind_map       {α β : Type u} (f : m (α → β)) (x : m α) : f >>= (. <$> x) = f <*> x
-  pure_bind      (x : α) (f : α → m β) : pure x >>= f = f x
-  bind_assoc     (x : m α) (f : α → m β) (g : β → m γ) : x >>= f >>= g = x >>= fun x => f x >>= g
-  map_pure g x    := (by rw [← bind_pure_comp, pure_bind])
-  seq_pure g x    := (by rw [← bind_map]; simp [map_pure, bind_pure_comp])
-  seq_assoc x g h := (by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind])
-
-export LawfulMonad (bind_pure_comp bind_map pure_bind bind_assoc)
-attribute [simp] pure_bind bind_assoc
-
-@[simp] theorem bind_pure [Monad m] [LawfulMonad m] (x : m α) : x >>= pure = x := by
-  show x >>= (fun a => pure (id a)) = x
-  rw [bind_pure_comp, id_map]
-
-theorem map_eq_pure_bind [Monad m] [LawfulMonad m] (f : α → β) (x : m α) : f <$> x = x >>= fun a => pure (f a) := by
-  rw [← bind_pure_comp]
-
-theorem seq_eq_bind_map {α β : Type u} [Monad m] [LawfulMonad m] (f : m (α → β)) (x : m α) : f <*> x = f >>= (. <$> x) := by
-  rw [← bind_map]
-
-theorem bind_congr [Bind m] {x : m α} {f g : α → m β} (h : ∀ a, f a = g a) : x >>= f = x >>= g := by
-  simp [funext h]
-
-@[simp] theorem bind_pure_unit [Monad m] [LawfulMonad m] {x : m PUnit} : (x >>= fun _ => pure ⟨⟩) = x := by
-  rw [bind_pure]
-
-theorem map_congr [Functor m] {x : m α} {f g : α → β} (h : ∀ a, f a = g a) : (f <$> x : m β) = g <$> x := by
-  simp [funext h]
-
-theorem seq_eq_bind {α β : Type u} [Monad m] [LawfulMonad m] (mf : m (α → β)) (x : m α) : mf <*> x = mf >>= fun f => f <$> x := by
-  rw [bind_map]
-
-theorem seqRight_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x *> y = x >>= fun _ => y := by
-  rw [seqRight_eq]
-  simp [map_eq_pure_bind, seq_eq_bind_map, const]
-
-theorem seqLeft_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x <* y = x >>= fun a => y >>= fun _ => pure a := by
-  rw [seqLeft_eq]; simp [map_eq_pure_bind, seq_eq_bind_map]
-
-/--
-An alternative constructor for `LawfulMonad` which has more
-defaultable fields in the common case.
--/
-theorem LawfulMonad.mk' (m : Type u → Type v) [Monad m]
-    (id_map : ∀ {α} (x : m α), id <$> x = x)
-    (pure_bind : ∀ {α β} (x : α) (f : α → m β), pure x >>= f = f x)
-    (bind_assoc : ∀ {α β γ} (x : m α) (f : α → m β) (g : β → m γ),
-      x >>= f >>= g = x >>= fun x => f x >>= g)
-    (map_const : ∀ {α β} (x : α) (y : m β),
-      Functor.mapConst x y = Function.const β x <$> y := by intros; rfl)
-    (seqLeft_eq : ∀ {α β} (x : m α) (y : m β),
-      x <* y = (x >>= fun a => y >>= fun _ => pure a) := by intros; rfl)
-    (seqRight_eq : ∀ {α β} (x : m α) (y : m β), x *> y = (x >>= fun _ => y) := by intros; rfl)
-    (bind_pure_comp : ∀ {α β} (f : α → β) (x : m α),
-      x >>= (fun y => pure (f y)) = f <$> x := by intros; rfl)
-    (bind_map : ∀ {α β} (f : m (α → β)) (x : m α), f >>= (. <$> x) = f <*> x := by intros; rfl)
-    : LawfulMonad m :=
-  have map_pure {α β} (g : α → β) (x : α) : g <$> (pure x : m α) = pure (g x) := by
-    rw [← bind_pure_comp]; simp [pure_bind]
-  { id_map, bind_pure_comp, bind_map, pure_bind, bind_assoc, map_pure,
-    comp_map := by simp [← bind_pure_comp, bind_assoc, pure_bind]
-    pure_seq := by intros; rw [← bind_map]; simp [pure_bind]
-    seq_pure := by intros; rw [← bind_map]; simp [map_pure, bind_pure_comp]
-    seq_assoc := by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind]
-    map_const := funext fun x => funext (map_const x)
-    seqLeft_eq := by simp [seqLeft_eq, ← bind_map, ← bind_pure_comp, pure_bind, bind_assoc]
-    seqRight_eq := fun x y => by
-      rw [seqRight_eq, ← bind_map, ← bind_pure_comp, bind_assoc]; simp [pure_bind, id_map] }
-
-/-! # Id -/
-
-namespace Id
-
-@[simp] theorem map_eq (x : Id α) (f : α → β) : f <$> x = f x := rfl
-@[simp] theorem bind_eq (x : Id α) (f : α → id β) : x >>= f = f x := rfl
-@[simp] theorem pure_eq (a : α) : (pure a : Id α) = a := rfl
-
-instance : LawfulMonad Id := by
-  refine' { .. } <;> intros <;> rfl
-
-end Id
-
-/-! # ExceptT -/
-
-namespace ExceptT
-
-theorem ext [Monad m] {x y : ExceptT ε m α} (h : x.run = y.run) : x = y := by
-  simp [run] at h
-  assumption
-
-@[simp] theorem run_pure [Monad m] (x : α) : run (pure x : ExceptT ε m α) = pure (Except.ok x) := rfl
-
-@[simp] theorem run_lift  [Monad.{u, v} m] (x : m α) : run (ExceptT.lift x : ExceptT ε m α) = (Except.ok <$> x : m (Except ε α)) := rfl
-
-@[simp] theorem run_throw [Monad m] : run (throw e : ExceptT ε m β) = pure (Except.error e) := rfl
-
-@[simp] theorem run_bind_lift [Monad m] [LawfulMonad m] (x : m α) (f : α → ExceptT ε m β) : run (ExceptT.lift x >>= f : ExceptT ε m β) = x >>= fun a => run (f a) := by
-  simp[ExceptT.run, ExceptT.lift, bind, ExceptT.bind, ExceptT.mk, ExceptT.bindCont, map_eq_pure_bind]
-
-@[simp] theorem bind_throw [Monad m] [LawfulMonad m] (f : α → ExceptT ε m β) : (throw e >>= f) = throw e := by
-  simp [throw, throwThe, MonadExceptOf.throw, bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk]
-
-theorem run_bind [Monad m] (x : ExceptT ε m α)
-        : run (x >>= f : ExceptT ε m β)
-          =
-          run x >>= fun
-                     | Except.ok x => run (f x)
-                     | Except.error e => pure (Except.error e) :=
-  rfl
-
-@[simp] theorem lift_pure [Monad m] [LawfulMonad m] (a : α) : ExceptT.lift (pure a) = (pure a : ExceptT ε m α) := by
-  simp [ExceptT.lift, pure, ExceptT.pure]
-
-@[simp] theorem run_map [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α)
-    : (f <$> x).run = Except.map f <$> x.run := by
-  simp [Functor.map, ExceptT.map, map_eq_pure_bind]
-  apply bind_congr
-  intro a; cases a <;> simp [Except.map]
-
-protected theorem seq_eq {α β ε : Type u} [Monad m] (mf : ExceptT ε m (α → β)) (x : ExceptT ε m α) : mf <*> x = mf >>= fun f => f <$> x :=
-  rfl
-
-protected theorem bind_pure_comp [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α) : x >>= pure ∘ f = f <$> x := by
-  intros; rfl
-
-protected theorem seqLeft_eq {α β ε : Type u} {m : Type u → Type v} [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x <* y = const β <$> x <*> y := by
-  show (x >>= fun a => y >>= fun _ => pure a) = (const (α := α) β <$> x) >>= fun f => f <$> y
-  rw [← ExceptT.bind_pure_comp]
-  apply ext
-  simp [run_bind]
-  apply bind_congr
-  intro
-  | Except.error _ => simp
-  | Except.ok _ =>
-    simp [map_eq_pure_bind]; apply bind_congr; intro b;
-    cases b <;> simp [comp, Except.map, const]
-
-protected theorem seqRight_eq [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x *> y = const α id <$> x <*> y := by
-  show (x >>= fun _ => y) = (const α id <$> x) >>= fun f => f <$> y
-  rw [← ExceptT.bind_pure_comp]
-  apply ext
-  simp [run_bind]
-  apply bind_congr
-  intro a; cases a <;> simp
-
-instance [Monad m] [LawfulMonad m] : LawfulMonad (ExceptT ε m) where
-  id_map         := by intros; apply ext; simp
-  map_const      := by intros; rfl
-  seqLeft_eq     := ExceptT.seqLeft_eq
-  seqRight_eq    := ExceptT.seqRight_eq
-  pure_seq       := by intros; apply ext; simp [ExceptT.seq_eq, run_bind]
-  bind_pure_comp := ExceptT.bind_pure_comp
-  bind_map       := by intros; rfl
-  pure_bind      := by intros; apply ext; simp [run_bind]
-  bind_assoc     := by intros; apply ext; simp [run_bind]; apply bind_congr; intro a; cases a <;> simp
-
-end ExceptT
-
-/-! # Except -/
-
-instance : LawfulMonad (Except ε) := LawfulMonad.mk'
-  (id_map := fun x => by cases x <;> rfl)
-  (pure_bind := fun a f => rfl)
-  (bind_assoc := fun a f g => by cases a <;> rfl)
-
-instance : LawfulApplicative (Except ε) := inferInstance
-instance : LawfulFunctor (Except ε) := inferInstance
-
-/-! # ReaderT -/
-
-namespace ReaderT
-
-theorem ext {x y : ReaderT ρ m α} (h : ∀ ctx, x.run ctx = y.run ctx) : x = y := by
-  simp [run] at h
-  exact funext h
-
-@[simp] theorem run_pure [Monad m] (a : α) (ctx : ρ) : (pure a : ReaderT ρ m α).run ctx = pure a := rfl
-
-@[simp] theorem run_bind [Monad m] (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) (ctx : ρ)
-    : (x >>= f).run ctx = x.run ctx >>= λ a => (f a).run ctx := rfl
-
-@[simp] theorem run_mapConst [Monad m] (a : α) (x : ReaderT ρ m β) (ctx : ρ)
-    : (Functor.mapConst a x).run ctx = Functor.mapConst a (x.run ctx) := rfl
-
-@[simp] theorem run_map [Monad m] (f : α → β) (x : ReaderT ρ m α) (ctx : ρ)
-    : (f <$> x).run ctx = f <$> x.run ctx := rfl
-
-@[simp] theorem run_monadLift [MonadLiftT n m] (x : n α) (ctx : ρ)
-    : (monadLift x : ReaderT ρ m α).run ctx = (monadLift x : m α) := rfl
-
-@[simp] theorem run_monadMap [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : ReaderT ρ m α) (ctx : ρ)
-    : (monadMap @f x : ReaderT ρ m α).run ctx = monadMap @f (x.run ctx) := rfl
-
-@[simp] theorem run_read [Monad m] (ctx : ρ) : (ReaderT.read : ReaderT ρ m ρ).run ctx = pure ctx := rfl
-
-@[simp] theorem run_seq {α β : Type u} [Monad m] (f : ReaderT ρ m (α → β)) (x : ReaderT ρ m α) (ctx : ρ)
-    : (f <*> x).run ctx = (f.run ctx <*> x.run ctx) := rfl
-
-@[simp] theorem run_seqRight [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
-    : (x *> y).run ctx = (x.run ctx *> y.run ctx) := rfl
-
-@[simp] theorem run_seqLeft [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
-    : (x <* y).run ctx = (x.run ctx <* y.run ctx) := rfl
-
-instance [Monad m] [LawfulFunctor m] : LawfulFunctor (ReaderT ρ m) where
-  id_map    := by intros; apply ext; simp
-  map_const := by intros; funext a b; apply ext; intros; simp [map_const]
-  comp_map  := by intros; apply ext; intros; simp [comp_map]
-
-instance [Monad m] [LawfulApplicative m] : LawfulApplicative (ReaderT ρ m) where
-  seqLeft_eq  := by intros; apply ext; intros; simp [seqLeft_eq]
-  seqRight_eq := by intros; apply ext; intros; simp [seqRight_eq]
-  pure_seq    := by intros; apply ext; intros; simp [pure_seq]
-  map_pure    := by intros; apply ext; intros; simp [map_pure]
-  seq_pure    := by intros; apply ext; intros; simp [seq_pure]
-  seq_assoc   := by intros; apply ext; intros; simp [seq_assoc]
-
-instance [Monad m] [LawfulMonad m] : LawfulMonad (ReaderT ρ m) where
-  bind_pure_comp := by intros; apply ext; intros; simp [LawfulMonad.bind_pure_comp]
-  bind_map       := by intros; apply ext; intros; simp [bind_map]
-  pure_bind      := by intros; apply ext; intros; simp
-  bind_assoc     := by intros; apply ext; intros; simp
-
-end ReaderT
-
-/-! # StateRefT -/
-
-instance [Monad m] [LawfulMonad m] : LawfulMonad (StateRefT' ω σ m) :=
-  inferInstanceAs (LawfulMonad (ReaderT (ST.Ref ω σ) m))
-
-/-! # StateT -/
-
-namespace StateT
-
-theorem ext {x y : StateT σ m α} (h : ∀ s, x.run s = y.run s) : x = y :=
-  funext h
-
-@[simp] theorem run'_eq [Monad m] (x : StateT σ m α) (s : σ) : run' x s = (·.1) <$> run x s :=
-  rfl
-
-@[simp] theorem run_pure [Monad m] (a : α) (s : σ) : (pure a : StateT σ m α).run s = pure (a, s) := rfl
-
-@[simp] theorem run_bind [Monad m] (x : StateT σ m α) (f : α → StateT σ m β) (s : σ)
-    : (x >>= f).run s = x.run s >>= λ p => (f p.1).run p.2 := by
-  simp [bind, StateT.bind, run]
-
-@[simp] theorem run_map {α β σ : Type u} [Monad m] [LawfulMonad m] (f : α → β) (x : StateT σ m α) (s : σ) : (f <$> x).run s = (fun (p : α × σ) => (f p.1, p.2)) <$> x.run s := by
-  simp [Functor.map, StateT.map, run, map_eq_pure_bind]
-
-@[simp] theorem run_get [Monad m] (s : σ)    : (get : StateT σ m σ).run s = pure (s, s) := rfl
-
-@[simp] theorem run_set [Monad m] (s s' : σ) : (set s' : StateT σ m PUnit).run s = pure (⟨⟩, s') := rfl
-
-@[simp] theorem run_modify [Monad m] (f : σ → σ) (s : σ) : (modify f : StateT σ m PUnit).run s = pure (⟨⟩, f s) := rfl
-
-@[simp] theorem run_modifyGet [Monad m] (f : σ → α × σ) (s : σ) : (modifyGet f : StateT σ m α).run s = pure ((f s).1, (f s).2) := by
-  simp [modifyGet, MonadStateOf.modifyGet, StateT.modifyGet, run]
-
-@[simp] theorem run_lift {α σ : Type u} [Monad m] (x : m α) (s : σ) : (StateT.lift x : StateT σ m α).run s = x >>= fun a => pure (a, s) := rfl
-
-@[simp] theorem run_bind_lift {α σ : Type u} [Monad m] [LawfulMonad m] (x : m α) (f : α → StateT σ m β) (s : σ) : (StateT.lift x >>= f).run s = x >>= fun a => (f a).run s := by
-  simp [StateT.lift, StateT.run, bind, StateT.bind]
-
-@[simp] theorem run_monadLift {α σ : Type u} [Monad m] [MonadLiftT n m] (x : n α) (s : σ) : (monadLift x : StateT σ m α).run s = (monadLift x : m α) >>= fun a => pure (a, s) := rfl
-
-@[simp] theorem run_monadMap [Monad m] [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : StateT σ m α) (s : σ)
-    : (monadMap @f x : StateT σ m α).run s = monadMap @f (x.run s) := rfl
-
-@[simp] theorem run_seq {α β σ : Type u} [Monad m] [LawfulMonad m] (f : StateT σ m (α → β)) (x : StateT σ m α) (s : σ) : (f <*> x).run s = (f.run s >>= fun fs => (fun (p : α × σ) => (fs.1 p.1, p.2)) <$> x.run fs.2) := by
-  show (f >>= fun g => g <$> x).run s = _
-  simp
-
-@[simp] theorem run_seqRight [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x *> y).run s = (x.run s >>= fun p => y.run p.2) := by
-  show (x >>= fun _ => y).run s = _
-  simp
-
-@[simp] theorem run_seqLeft {α β σ : Type u} [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x <* y).run s = (x.run s >>= fun p => y.run p.2 >>= fun p' => pure (p.1, p'.2)) := by
-  show (x >>= fun a => y >>= fun _ => pure a).run s = _
-  simp
-
-theorem seqRight_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x *> y = const α id <$> x <*> y := by
-  apply ext; intro s
-  simp [map_eq_pure_bind, const]
-  apply bind_congr; intro p; cases p
-  simp [Prod.eta]
-
-theorem seqLeft_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x <* y = const β <$> x <*> y := by
-  apply ext; intro s
-  simp [map_eq_pure_bind]
-
-instance [Monad m] [LawfulMonad m] : LawfulMonad (StateT σ m) where
-  id_map         := by intros; apply ext; intros; simp[Prod.eta]
-  map_const      := by intros; rfl
-  seqLeft_eq     := seqLeft_eq
-  seqRight_eq    := seqRight_eq
-  pure_seq       := by intros; apply ext; intros; simp
-  bind_pure_comp := by intros; apply ext; intros; simp; apply LawfulMonad.bind_pure_comp
-  bind_map       := by intros; rfl
-  pure_bind      := by intros; apply ext; intros; simp
-  bind_assoc     := by intros; apply ext; intros; simp
-
-end StateT
-
-/-! # EStateM -/
-
-instance : LawfulMonad (EStateM ε σ) := .mk'
-  (id_map := fun x => funext <| fun s => by
-    dsimp only [EStateM.instMonadEStateM, EStateM.map]
-    match x s with
-    | .ok _ _ => rfl
-    | .error _ _ => rfl)
-  (pure_bind := fun _ _ => rfl)
-  (bind_assoc := fun x _ _ => funext <| fun s => by
-    dsimp only [EStateM.instMonadEStateM, EStateM.bind]
-    match x s with
-    | .ok _ _ => rfl
-    | .error _ _ => rfl)
-  (map_const := fun _ _ => rfl)
-
-/-! # Option -/
-
-instance : LawfulMonad Option := LawfulMonad.mk'
-  (id_map := fun x => by cases x <;> rfl)
-  (pure_bind := fun x f => rfl)
-  (bind_assoc := fun x f g => by cases x <;> rfl)
-  (bind_pure_comp := fun f x => by cases x <;> rfl)
-
-instance : LawfulApplicative Option := inferInstance
-instance : LawfulFunctor Option := inferInstance
+import Init.Control.Lawful.Basic
+import Init.Control.Lawful.Instances

src/Init/Control/Lawful/Basic.lean

@@ -0,0 +1,138 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Sebastian Ullrich, Leonardo de Moura, Mario Carneiro
+-/
+prelude
+import Init.SimpLemmas
+import Init.Meta
+
+open Function
+
+@[simp] theorem monadLift_self [Monad m] (x : m α) : monadLift x = x :=
+  rfl
+
+class LawfulFunctor (f : Type u → Type v) [Functor f] : Prop where
+  map_const          : (Functor.mapConst : α → f β → f α) = Functor.map ∘ const β
+  id_map   (x : f α) : id <$> x = x
+  comp_map (g : α → β) (h : β → γ) (x : f α) : (h ∘ g) <$> x = h <$> g <$> x
+
+export LawfulFunctor (map_const id_map comp_map)
+
+attribute [simp] id_map
+
+@[simp] theorem id_map' [Functor m] [LawfulFunctor m] (x : m α) : (fun a => a) <$> x = x :=
+  id_map x
+
+class LawfulApplicative (f : Type u → Type v) [Applicative f] extends LawfulFunctor f : Prop where
+  seqLeft_eq  (x : f α) (y : f β)     : x <* y = const β <$> x <*> y
+  seqRight_eq (x : f α) (y : f β)     : x *> y = const α id <$> x <*> y
+  pure_seq    (g : α → β) (x : f α)   : pure g <*> x = g <$> x
+  map_pure    (g : α → β) (x : α)     : g <$> (pure x : f α) = pure (g x)
+  seq_pure    {α β : Type u} (g : f (α → β)) (x : α) : g <*> pure x = (fun h => h x) <$> g
+  seq_assoc   {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)) : h <*> (g <*> x) = ((@comp α β γ) <$> h) <*> g <*> x
+  comp_map g h x := (by
+    repeat rw [← pure_seq]
+    simp [seq_assoc, map_pure, seq_pure])
+
+export LawfulApplicative (seqLeft_eq seqRight_eq pure_seq map_pure seq_pure seq_assoc)
+
+attribute [simp] map_pure seq_pure
+
+@[simp] theorem pure_id_seq [Applicative f] [LawfulApplicative f] (x : f α) : pure id <*> x = x := by
+  simp [pure_seq]
+
+class LawfulMonad (m : Type u → Type v) [Monad m] extends LawfulApplicative m : Prop where
+  bind_pure_comp (f : α → β) (x : m α) : x >>= (fun a => pure (f a)) = f <$> x
+  bind_map       {α β : Type u} (f : m (α → β)) (x : m α) : f >>= (. <$> x) = f <*> x
+  pure_bind      (x : α) (f : α → m β) : pure x >>= f = f x
+  bind_assoc     (x : m α) (f : α → m β) (g : β → m γ) : x >>= f >>= g = x >>= fun x => f x >>= g
+  map_pure g x    := (by rw [← bind_pure_comp, pure_bind])
+  seq_pure g x    := (by rw [← bind_map]; simp [map_pure, bind_pure_comp])
+  seq_assoc x g h := (by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind])
+
+export LawfulMonad (bind_pure_comp bind_map pure_bind bind_assoc)
+attribute [simp] pure_bind bind_assoc
+
+@[simp] theorem bind_pure [Monad m] [LawfulMonad m] (x : m α) : x >>= pure = x := by
+  show x >>= (fun a => pure (id a)) = x
+  rw [bind_pure_comp, id_map]
+
+theorem map_eq_pure_bind [Monad m] [LawfulMonad m] (f : α → β) (x : m α) : f <$> x = x >>= fun a => pure (f a) := by
+  rw [← bind_pure_comp]
+
+theorem seq_eq_bind_map {α β : Type u} [Monad m] [LawfulMonad m] (f : m (α → β)) (x : m α) : f <*> x = f >>= (. <$> x) := by
+  rw [← bind_map]
+
+theorem bind_congr [Bind m] {x : m α} {f g : α → m β} (h : ∀ a, f a = g a) : x >>= f = x >>= g := by
+  simp [funext h]
+
+@[simp] theorem bind_pure_unit [Monad m] [LawfulMonad m] {x : m PUnit} : (x >>= fun _ => pure ⟨⟩) = x := by
+  rw [bind_pure]
+
+theorem map_congr [Functor m] {x : m α} {f g : α → β} (h : ∀ a, f a = g a) : (f <$> x : m β) = g <$> x := by
+  simp [funext h]
+
+theorem seq_eq_bind {α β : Type u} [Monad m] [LawfulMonad m] (mf : m (α → β)) (x : m α) : mf <*> x = mf >>= fun f => f <$> x := by
+  rw [bind_map]
+
+theorem seqRight_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x *> y = x >>= fun _ => y := by
+  rw [seqRight_eq]
+  simp [map_eq_pure_bind, seq_eq_bind_map, const]
+
+theorem seqLeft_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x <* y = x >>= fun a => y >>= fun _ => pure a := by
+  rw [seqLeft_eq]; simp [map_eq_pure_bind, seq_eq_bind_map]
+
+/--
+An alternative constructor for `LawfulMonad` which has more
+defaultable fields in the common case.
+-/
+theorem LawfulMonad.mk' (m : Type u → Type v) [Monad m]
+    (id_map : ∀ {α} (x : m α), id <$> x = x)
+    (pure_bind : ∀ {α β} (x : α) (f : α → m β), pure x >>= f = f x)
+    (bind_assoc : ∀ {α β γ} (x : m α) (f : α → m β) (g : β → m γ),
+      x >>= f >>= g = x >>= fun x => f x >>= g)
+    (map_const : ∀ {α β} (x : α) (y : m β),
+      Functor.mapConst x y = Function.const β x <$> y := by intros; rfl)
+    (seqLeft_eq : ∀ {α β} (x : m α) (y : m β),
+      x <* y = (x >>= fun a => y >>= fun _ => pure a) := by intros; rfl)
+    (seqRight_eq : ∀ {α β} (x : m α) (y : m β), x *> y = (x >>= fun _ => y) := by intros; rfl)
+    (bind_pure_comp : ∀ {α β} (f : α → β) (x : m α),
+      x >>= (fun y => pure (f y)) = f <$> x := by intros; rfl)
+    (bind_map : ∀ {α β} (f : m (α → β)) (x : m α), f >>= (. <$> x) = f <*> x := by intros; rfl)
+    : LawfulMonad m :=
+  have map_pure {α β} (g : α → β) (x : α) : g <$> (pure x : m α) = pure (g x) := by
+    rw [← bind_pure_comp]; simp [pure_bind]
+  { id_map, bind_pure_comp, bind_map, pure_bind, bind_assoc, map_pure,
+    comp_map := by simp [← bind_pure_comp, bind_assoc, pure_bind]
+    pure_seq := by intros; rw [← bind_map]; simp [pure_bind]
+    seq_pure := by intros; rw [← bind_map]; simp [map_pure, bind_pure_comp]
+    seq_assoc := by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind]
+    map_const := funext fun x => funext (map_const x)
+    seqLeft_eq := by simp [seqLeft_eq, ← bind_map, ← bind_pure_comp, pure_bind, bind_assoc]
+    seqRight_eq := fun x y => by
+      rw [seqRight_eq, ← bind_map, ← bind_pure_comp, bind_assoc]; simp [pure_bind, id_map] }
+
+/-! # Id -/
+
+namespace Id
+
+@[simp] theorem map_eq (x : Id α) (f : α → β) : f <$> x = f x := rfl
+@[simp] theorem bind_eq (x : Id α) (f : α → id β) : x >>= f = f x := rfl
+@[simp] theorem pure_eq (a : α) : (pure a : Id α) = a := rfl
+
+instance : LawfulMonad Id := by
+  refine' { .. } <;> intros <;> rfl
+
+end Id
+
+/-! # Option -/
+
+instance : LawfulMonad Option := LawfulMonad.mk'
+  (id_map := fun x => by cases x <;> rfl)
+  (pure_bind := fun x f => rfl)
+  (bind_assoc := fun x f g => by cases x <;> rfl)
+  (bind_pure_comp := fun f x => by cases x <;> rfl)
+
+instance : LawfulApplicative Option := inferInstance
+instance : LawfulFunctor Option := inferInstance

src/Init/Control/Lawful/Instances.lean

@@ -0,0 +1,248 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Sebastian Ullrich, Leonardo de Moura, Mario Carneiro
+-/
+prelude
+import Init.Control.Lawful.Basic
+import Init.Control.Except
+import Init.Control.StateRef
+
+open Function
+
+/-! # ExceptT -/
+
+namespace ExceptT
+
+theorem ext [Monad m] {x y : ExceptT ε m α} (h : x.run = y.run) : x = y := by
+  simp [run] at h
+  assumption
+
+@[simp] theorem run_pure [Monad m] (x : α) : run (pure x : ExceptT ε m α) = pure (Except.ok x) := rfl
+
+@[simp] theorem run_lift  [Monad.{u, v} m] (x : m α) : run (ExceptT.lift x : ExceptT ε m α) = (Except.ok <$> x : m (Except ε α)) := rfl
+
+@[simp] theorem run_throw [Monad m] : run (throw e : ExceptT ε m β) = pure (Except.error e) := rfl
+
+@[simp] theorem run_bind_lift [Monad m] [LawfulMonad m] (x : m α) (f : α → ExceptT ε m β) : run (ExceptT.lift x >>= f : ExceptT ε m β) = x >>= fun a => run (f a) := by
+  simp[ExceptT.run, ExceptT.lift, bind, ExceptT.bind, ExceptT.mk, ExceptT.bindCont, map_eq_pure_bind]
+
+@[simp] theorem bind_throw [Monad m] [LawfulMonad m] (f : α → ExceptT ε m β) : (throw e >>= f) = throw e := by
+  simp [throw, throwThe, MonadExceptOf.throw, bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk]
+
+theorem run_bind [Monad m] (x : ExceptT ε m α)
+        : run (x >>= f : ExceptT ε m β)
+          =
+          run x >>= fun
+                     | Except.ok x => run (f x)
+                     | Except.error e => pure (Except.error e) :=
+  rfl
+
+@[simp] theorem lift_pure [Monad m] [LawfulMonad m] (a : α) : ExceptT.lift (pure a) = (pure a : ExceptT ε m α) := by
+  simp [ExceptT.lift, pure, ExceptT.pure]
+
+@[simp] theorem run_map [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α)
+    : (f <$> x).run = Except.map f <$> x.run := by
+  simp [Functor.map, ExceptT.map, map_eq_pure_bind]
+  apply bind_congr
+  intro a; cases a <;> simp [Except.map]
+
+protected theorem seq_eq {α β ε : Type u} [Monad m] (mf : ExceptT ε m (α → β)) (x : ExceptT ε m α) : mf <*> x = mf >>= fun f => f <$> x :=
+  rfl
+
+protected theorem bind_pure_comp [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α) : x >>= pure ∘ f = f <$> x := by
+  intros; rfl
+
+protected theorem seqLeft_eq {α β ε : Type u} {m : Type u → Type v} [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x <* y = const β <$> x <*> y := by
+  show (x >>= fun a => y >>= fun _ => pure a) = (const (α := α) β <$> x) >>= fun f => f <$> y
+  rw [← ExceptT.bind_pure_comp]
+  apply ext
+  simp [run_bind]
+  apply bind_congr
+  intro
+  | Except.error _ => simp
+  | Except.ok _ =>
+    simp [map_eq_pure_bind]; apply bind_congr; intro b;
+    cases b <;> simp [comp, Except.map, const]
+
+protected theorem seqRight_eq [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x *> y = const α id <$> x <*> y := by
+  show (x >>= fun _ => y) = (const α id <$> x) >>= fun f => f <$> y
+  rw [← ExceptT.bind_pure_comp]
+  apply ext
+  simp [run_bind]
+  apply bind_congr
+  intro a; cases a <;> simp
+
+instance [Monad m] [LawfulMonad m] : LawfulMonad (ExceptT ε m) where
+  id_map         := by intros; apply ext; simp
+  map_const      := by intros; rfl
+  seqLeft_eq     := ExceptT.seqLeft_eq
+  seqRight_eq    := ExceptT.seqRight_eq
+  pure_seq       := by intros; apply ext; simp [ExceptT.seq_eq, run_bind]
+  bind_pure_comp := ExceptT.bind_pure_comp
+  bind_map       := by intros; rfl
+  pure_bind      := by intros; apply ext; simp [run_bind]
+  bind_assoc     := by intros; apply ext; simp [run_bind]; apply bind_congr; intro a; cases a <;> simp
+
+end ExceptT
+
+/-! # Except -/
+
+instance : LawfulMonad (Except ε) := LawfulMonad.mk'
+  (id_map := fun x => by cases x <;> rfl)
+  (pure_bind := fun a f => rfl)
+  (bind_assoc := fun a f g => by cases a <;> rfl)
+
+instance : LawfulApplicative (Except ε) := inferInstance
+instance : LawfulFunctor (Except ε) := inferInstance
+
+/-! # ReaderT -/
+
+namespace ReaderT
+
+theorem ext {x y : ReaderT ρ m α} (h : ∀ ctx, x.run ctx = y.run ctx) : x = y := by
+  simp [run] at h
+  exact funext h
+
+@[simp] theorem run_pure [Monad m] (a : α) (ctx : ρ) : (pure a : ReaderT ρ m α).run ctx = pure a := rfl
+
+@[simp] theorem run_bind [Monad m] (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) (ctx : ρ)
+    : (x >>= f).run ctx = x.run ctx >>= λ a => (f a).run ctx := rfl
+
+@[simp] theorem run_mapConst [Monad m] (a : α) (x : ReaderT ρ m β) (ctx : ρ)
+    : (Functor.mapConst a x).run ctx = Functor.mapConst a (x.run ctx) := rfl
+
+@[simp] theorem run_map [Monad m] (f : α → β) (x : ReaderT ρ m α) (ctx : ρ)
+    : (f <$> x).run ctx = f <$> x.run ctx := rfl
+
+@[simp] theorem run_monadLift [MonadLiftT n m] (x : n α) (ctx : ρ)
+    : (monadLift x : ReaderT ρ m α).run ctx = (monadLift x : m α) := rfl
+
+@[simp] theorem run_monadMap [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : ReaderT ρ m α) (ctx : ρ)
+    : (monadMap @f x : ReaderT ρ m α).run ctx = monadMap @f (x.run ctx) := rfl
+
+@[simp] theorem run_read [Monad m] (ctx : ρ) : (ReaderT.read : ReaderT ρ m ρ).run ctx = pure ctx := rfl
+
+@[simp] theorem run_seq {α β : Type u} [Monad m] (f : ReaderT ρ m (α → β)) (x : ReaderT ρ m α) (ctx : ρ)
+    : (f <*> x).run ctx = (f.run ctx <*> x.run ctx) := rfl
+
+@[simp] theorem run_seqRight [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
+    : (x *> y).run ctx = (x.run ctx *> y.run ctx) := rfl
+
+@[simp] theorem run_seqLeft [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
+    : (x <* y).run ctx = (x.run ctx <* y.run ctx) := rfl
+
+instance [Monad m] [LawfulFunctor m] : LawfulFunctor (ReaderT ρ m) where
+  id_map    := by intros; apply ext; simp
+  map_const := by intros; funext a b; apply ext; intros; simp [map_const]
+  comp_map  := by intros; apply ext; intros; simp [comp_map]
+
+instance [Monad m] [LawfulApplicative m] : LawfulApplicative (ReaderT ρ m) where
+  seqLeft_eq  := by intros; apply ext; intros; simp [seqLeft_eq]
+  seqRight_eq := by intros; apply ext; intros; simp [seqRight_eq]
+  pure_seq    := by intros; apply ext; intros; simp [pure_seq]
+  map_pure    := by intros; apply ext; intros; simp [map_pure]
+  seq_pure    := by intros; apply ext; intros; simp [seq_pure]
+  seq_assoc   := by intros; apply ext; intros; simp [seq_assoc]
+
+instance [Monad m] [LawfulMonad m] : LawfulMonad (ReaderT ρ m) where
+  bind_pure_comp := by intros; apply ext; intros; simp [LawfulMonad.bind_pure_comp]
+  bind_map       := by intros; apply ext; intros; simp [bind_map]
+  pure_bind      := by intros; apply ext; intros; simp
+  bind_assoc     := by intros; apply ext; intros; simp
+
+end ReaderT
+
+/-! # StateRefT -/
+
+instance [Monad m] [LawfulMonad m] : LawfulMonad (StateRefT' ω σ m) :=
+  inferInstanceAs (LawfulMonad (ReaderT (ST.Ref ω σ) m))
+
+/-! # StateT -/
+
+namespace StateT
+
+theorem ext {x y : StateT σ m α} (h : ∀ s, x.run s = y.run s) : x = y :=
+  funext h
+
+@[simp] theorem run'_eq [Monad m] (x : StateT σ m α) (s : σ) : run' x s = (·.1) <$> run x s :=
+  rfl
+
+@[simp] theorem run_pure [Monad m] (a : α) (s : σ) : (pure a : StateT σ m α).run s = pure (a, s) := rfl
+
+@[simp] theorem run_bind [Monad m] (x : StateT σ m α) (f : α → StateT σ m β) (s : σ)
+    : (x >>= f).run s = x.run s >>= λ p => (f p.1).run p.2 := by
+  simp [bind, StateT.bind, run]
+
+@[simp] theorem run_map {α β σ : Type u} [Monad m] [LawfulMonad m] (f : α → β) (x : StateT σ m α) (s : σ) : (f <$> x).run s = (fun (p : α × σ) => (f p.1, p.2)) <$> x.run s := by
+  simp [Functor.map, StateT.map, run, map_eq_pure_bind]
+
+@[simp] theorem run_get [Monad m] (s : σ)    : (get : StateT σ m σ).run s = pure (s, s) := rfl
+
+@[simp] theorem run_set [Monad m] (s s' : σ) : (set s' : StateT σ m PUnit).run s = pure (⟨⟩, s') := rfl
+
+@[simp] theorem run_modify [Monad m] (f : σ → σ) (s : σ) : (modify f : StateT σ m PUnit).run s = pure (⟨⟩, f s) := rfl
+
+@[simp] theorem run_modifyGet [Monad m] (f : σ → α × σ) (s : σ) : (modifyGet f : StateT σ m α).run s = pure ((f s).1, (f s).2) := by
+  simp [modifyGet, MonadStateOf.modifyGet, StateT.modifyGet, run]
+
+@[simp] theorem run_lift {α σ : Type u} [Monad m] (x : m α) (s : σ) : (StateT.lift x : StateT σ m α).run s = x >>= fun a => pure (a, s) := rfl
+
+@[simp] theorem run_bind_lift {α σ : Type u} [Monad m] [LawfulMonad m] (x : m α) (f : α → StateT σ m β) (s : σ) : (StateT.lift x >>= f).run s = x >>= fun a => (f a).run s := by
+  simp [StateT.lift, StateT.run, bind, StateT.bind]
+
+@[simp] theorem run_monadLift {α σ : Type u} [Monad m] [MonadLiftT n m] (x : n α) (s : σ) : (monadLift x : StateT σ m α).run s = (monadLift x : m α) >>= fun a => pure (a, s) := rfl
+
+@[simp] theorem run_monadMap [Monad m] [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : StateT σ m α) (s : σ)
+    : (monadMap @f x : StateT σ m α).run s = monadMap @f (x.run s) := rfl
+
+@[simp] theorem run_seq {α β σ : Type u} [Monad m] [LawfulMonad m] (f : StateT σ m (α → β)) (x : StateT σ m α) (s : σ) : (f <*> x).run s = (f.run s >>= fun fs => (fun (p : α × σ) => (fs.1 p.1, p.2)) <$> x.run fs.2) := by
+  show (f >>= fun g => g <$> x).run s = _
+  simp
+
+@[simp] theorem run_seqRight [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x *> y).run s = (x.run s >>= fun p => y.run p.2) := by
+  show (x >>= fun _ => y).run s = _
+  simp
+
+@[simp] theorem run_seqLeft {α β σ : Type u} [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x <* y).run s = (x.run s >>= fun p => y.run p.2 >>= fun p' => pure (p.1, p'.2)) := by
+  show (x >>= fun a => y >>= fun _ => pure a).run s = _
+  simp
+
+theorem seqRight_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x *> y = const α id <$> x <*> y := by
+  apply ext; intro s
+  simp [map_eq_pure_bind, const]
+  apply bind_congr; intro p; cases p
+  simp [Prod.eta]
+
+theorem seqLeft_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x <* y = const β <$> x <*> y := by
+  apply ext; intro s
+  simp [map_eq_pure_bind]
+
+instance [Monad m] [LawfulMonad m] : LawfulMonad (StateT σ m) where
+  id_map         := by intros; apply ext; intros; simp[Prod.eta]
+  map_const      := by intros; rfl
+  seqLeft_eq     := seqLeft_eq
+  seqRight_eq    := seqRight_eq
+  pure_seq       := by intros; apply ext; intros; simp
+  bind_pure_comp := by intros; apply ext; intros; simp; apply LawfulMonad.bind_pure_comp
+  bind_map       := by intros; rfl
+  pure_bind      := by intros; apply ext; intros; simp
+  bind_assoc     := by intros; apply ext; intros; simp
+
+end StateT
+
+/-! # EStateM -/
+
+instance : LawfulMonad (EStateM ε σ) := .mk'
+  (id_map := fun x => funext <| fun s => by
+    dsimp only [EStateM.instMonadEStateM, EStateM.map]
+    match x s with
+    | .ok _ _ => rfl
+    | .error _ _ => rfl)
+  (pure_bind := fun _ _ => rfl)
+  (bind_assoc := fun x _ _ => funext <| fun s => by
+    dsimp only [EStateM.instMonadEStateM, EStateM.bind]
+    match x s with
+    | .ok _ _ => rfl
+    | .error _ _ => rfl)
+  (map_const := fun _ _ => rfl)

src/Init/Control/StateCps.lean

@@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Init.Control.Lawful
+import Init.Control.Lawful.Basic
 
 /-!
 The State monad transformer using CPS style.

src/Init/Conv.lean

@@ -156,7 +156,6 @@ match [a, b] with
 simplifies to `a`. -/
 syntax (name := simpMatch) "simp_match" : conv
 
-
 /-- Executes the given tactic block without converting `conv` goal into a regular goal. -/
 syntax (name := nestedTacticCore) "tactic'" " => " tacticSeq : conv
 

src/Init/Core.lean

@@ -737,13 +737,16 @@ theorem beq_false_of_ne [BEq α] [LawfulBEq α] {a b : α} (h : a ≠ b) : (a ==
 section
 variable {α β φ : Sort u} {a a' : α} {b b' : β} {c : φ}
 
-theorem HEq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : HEq a b) : motive b :=
+/-- Non-dependent recursor for `HEq` -/
+noncomputable def HEq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : HEq a b) : motive b :=
   h.rec m
 
-theorem HEq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} {β : Sort u2} {b : β} (h : HEq a b) (m : motive a) : motive b :=
+/-- `HEq.ndrec` variant -/
+noncomputable def HEq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} {β : Sort u2} {b : β} (h : HEq a b) (m : motive a) : motive b :=
   h.rec m
 
-theorem HEq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : HEq a b) (h₂ : p a) : p b :=
+/-- `HEq.ndrec` variant -/
+noncomputable def HEq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : HEq a b) (h₂ : p a) : p b :=
   eq_of_heq h₁ ▸ h₂
 
 theorem HEq.subst {p : (T : Sort u) → T → Prop} (h₁ : HEq a b) (h₂ : p α a) : p β b :=

src/Init/Data/AC.lean

@@ -106,7 +106,7 @@ def norm [info : ContextInformation α] (ctx : α) (e : Expr) : List Nat :=
   let xs := if info.isComm ctx then sort xs else xs
   if info.isIdem ctx then mergeIdem xs else xs
 
-theorem List.two_step_induction
+noncomputable def List.two_step_induction
   {motive : List Nat → Sort u}
   (l : List Nat)
   (empty : motive [])

src/Init/Data/Array/Basic.lean

@@ -809,7 +809,7 @@ where
     rfl
 
   go (i : Nat) (hi : i ≤ as.size) : toListLitAux as n hsz i hi (as.data.drop i) = as.data := by
-    cases i <;> simp [getLit_eq, List.get_drop_eq_drop, toListLitAux, List.drop, go]
+    induction i <;> simp [getLit_eq, List.get_drop_eq_drop, toListLitAux, List.drop, *]
 
 def isPrefixOfAux [BEq α] (as bs : Array α) (hle : as.size ≤ bs.size) (i : Nat) : Bool :=
   if h : i < as.size then

src/Init/Data/Array/Lemmas.lean

@@ -8,6 +8,7 @@ import Init.Data.Nat.MinMax
 import Init.Data.List.Lemmas
 import Init.Data.Fin.Basic
 import Init.Data.Array.Mem
+import Init.TacticsExtra
 
 /-!
 ## Bootstrapping theorems about arrays

src/Init/Data/Array/QSort.lean

@@ -10,7 +10,7 @@ namespace Array
 -- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget
 
 def qpartition (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × Array α :=
-  if h : as.size = 0 then (0, as) else have : Inhabited α := ⟨as[0]'(by revert h; cases as.size <;> simp [Nat.zero_lt_succ])⟩ -- TODO: remove
+  if h : as.size = 0 then (0, as) else have : Inhabited α := ⟨as[0]'(by revert h; cases as.size <;> simp)⟩ -- TODO: remove
   let mid := (lo + hi) / 2
   let as  := if lt (as.get! mid) (as.get! lo) then as.swap! lo mid else as
   let as  := if lt (as.get! hi)  (as.get! lo) then as.swap! lo hi  else as

src/Init/Data/BitVec/Basic.lean

@@ -7,6 +7,7 @@ prelude
 import Init.Data.Fin.Basic
 import Init.Data.Nat.Bitwise.Lemmas
 import Init.Data.Nat.Power2
+import Init.Data.Int.Bitwise
 
 /-!
 We define bitvectors. We choose the `Fin` representation over others for its relative efficiency
@@ -72,6 +73,9 @@ protected def toNat (a : BitVec n) : Nat := a.toFin.val
 /-- Return the bound in terms of toNat. -/
 theorem isLt (x : BitVec w) : x.toNat < 2^w := x.toFin.isLt
 
+@[deprecated isLt]
+theorem toNat_lt (x : BitVec n) : x.toNat < 2^n := x.isLt
+
 /-- Theorem for normalizing the bit vector literal representation. -/
 -- TODO: This needs more usage data to assess which direction the simp should go.
 @[simp, bv_toNat] theorem ofNat_eq_ofNat : @OfNat.ofNat (BitVec n) i _ = .ofNat n i := rfl

src/Init/Data/BitVec/Bitblast.lean

@@ -5,6 +5,7 @@ Authors: Harun Khan, Abdalrhman M Mohamed, Joe Hendrix
 -/
 prelude
 import Init.Data.BitVec.Folds
+import Init.Data.Nat.Mod
 
 /-!
 # Bitblasting of bitvectors
@@ -70,24 +71,8 @@ private theorem testBit_limit {x i : Nat} (x_lt_succ : x < 2^(i+1)) :
              _ ≤ x := testBit_implies_ge jp
 
 private theorem mod_two_pow_succ (x i : Nat) :
-  x % 2^(i+1) = 2^i*(x.testBit i).toNat + x % (2 ^ i):= by
-  apply Nat.eq_of_testBit_eq
-  intro j
-  simp only [Nat.mul_add_lt_is_or, testBit_or, testBit_mod_two_pow, testBit_shiftLeft,
-    Nat.testBit_bool_to_nat, Nat.sub_eq_zero_iff_le, Nat.mod_lt, Nat.two_pow_pos,
-    testBit_mul_pow_two]
-  rcases Nat.lt_trichotomy i j with i_lt_j | i_eq_j | j_lt_i
-  · have i_le_j : i ≤ j := Nat.le_of_lt i_lt_j
-    have not_j_le_i : ¬(j ≤ i) := Nat.not_le_of_lt i_lt_j
-    have not_j_lt_i : ¬(j < i) := Nat.not_lt_of_le i_le_j
-    have not_j_lt_i_succ : ¬(j < i + 1) :=
-          Nat.not_le_of_lt (Nat.succ_lt_succ i_lt_j)
-    simp [i_le_j, not_j_le_i, not_j_lt_i, not_j_lt_i_succ]
-  · simp [i_eq_j]
-  · have j_le_i : j ≤ i := Nat.le_of_lt j_lt_i
-    have j_le_i_succ : j < i + 1 := Nat.succ_le_succ j_le_i
-    have not_j_ge_i : ¬(j ≥ i) := Nat.not_le_of_lt j_lt_i
-    simp [j_lt_i, j_le_i, not_j_ge_i, j_le_i_succ]
+    x % 2^(i+1) = 2^i*(x.testBit i).toNat + x % (2 ^ i):= by
+  rw [Nat.mod_pow_succ, Nat.add_comm, Nat.toNat_testBit]
 
 private theorem mod_two_pow_add_mod_two_pow_add_bool_lt_two_pow_succ
      (x y i : Nat) (c : Bool) : x % 2^i + (y % 2^i + c.toNat) < 2^(i+1) := by

src/Init/Data/BitVec/Lemmas.lean

@@ -29,14 +29,12 @@ theorem eq_of_toNat_eq {n} : ∀ {i j : BitVec n}, i.toNat = j.toNat → i = j
 @[bv_toNat] theorem toNat_ne (x y : BitVec n) : x ≠ y ↔ x.toNat ≠ y.toNat := by
   rw [Ne, toNat_eq]
 
-theorem toNat_lt (x : BitVec n) : x.toNat < 2^n := x.toFin.2
-
 theorem testBit_toNat (x : BitVec w) : x.toNat.testBit i = x.getLsb i := rfl
 
 @[simp] theorem getLsb_ofFin (x : Fin (2^n)) (i : Nat) :
   getLsb (BitVec.ofFin x) i = x.val.testBit i := rfl
 
-@[simp] theorem getLsb_ge (x : BitVec w) (i : Nat) (ge : i ≥ w) : getLsb x i = false := by
+@[simp] theorem getLsb_ge (x : BitVec w) (i : Nat) (ge : w ≤ i) : getLsb x i = false := by
   let ⟨x, x_lt⟩ := x
   simp
   apply Nat.testBit_lt_two_pow
@@ -72,7 +70,7 @@ theorem eq_of_getMsb_eq {x y : BitVec w}
   else
     have w_pos := Nat.pos_of_ne_zero w_zero
     have r : i ≤ w - 1 := by
-      simp [Nat.le_sub_iff_add_le w_pos, Nat.add_succ]
+      simp [Nat.le_sub_iff_add_le w_pos]
       exact i_lt
     have q_lt : w - 1 - i < w := by
       simp only [Nat.sub_sub]
@@ -89,6 +87,9 @@ theorem eq_of_toFin_eq : ∀ {x y : BitVec w}, x.toFin = y.toFin → x = y
 @[simp] theorem toNat_ofBool (b : Bool) : (ofBool b).toNat = b.toNat := by
   cases b <;> rfl
 
+@[simp] theorem msb_ofBool (b : Bool) : (ofBool b).msb = b := by
+  cases b <;> simp [BitVec.msb]
+
 theorem ofNat_one (n : Nat) : BitVec.ofNat 1 n = BitVec.ofBool (n % 2 = 1) :=  by
   rcases (Nat.mod_two_eq_zero_or_one n) with h | h <;> simp [h, BitVec.ofNat, Fin.ofNat']
 
@@ -116,6 +117,8 @@ theorem getLsb_ofNat (n : Nat) (x : Nat) (i : Nat) :
 
 @[simp] theorem getLsb_zero : (0#w).getLsb i = false := by simp [getLsb]
 
+@[simp] theorem getMsb_zero : (0#w).getMsb i = false := by simp [getMsb]
+
 @[simp] theorem toNat_mod_cancel (x : BitVec n) : x.toNat % (2^n) = x.toNat :=
   Nat.mod_eq_of_lt x.isLt
 
@@ -241,6 +244,12 @@ theorem toInt_ofNat {n : Nat} (x : Nat) :
   else
     simp [n_le_i, toNat_ofNat]
 
+theorem zeroExtend'_eq {x : BitVec w} (h : w ≤ v) : x.zeroExtend' h = x.zeroExtend v := by
+  apply eq_of_toNat_eq
+  rw [toNat_zeroExtend, toNat_zeroExtend']
+  rw [Nat.mod_eq_of_lt]
+  exact Nat.lt_of_lt_of_le x.isLt (Nat.pow_le_pow_right (Nat.zero_lt_two) h)
+
 @[simp, bv_toNat] theorem toNat_truncate (x : BitVec n) : (truncate i x).toNat = x.toNat % 2^i :=
   toNat_zeroExtend i x
 
@@ -285,10 +294,25 @@ theorem nat_eq_toNat (x : BitVec w) (y : Nat)
     getLsb (zeroExtend m x) i = (decide (i < m) && getLsb x i) := by
   simp [getLsb, toNat_zeroExtend, Nat.testBit_mod_two_pow]
 
+@[simp] theorem getMsb_zeroExtend_add {x : BitVec w} (h : k ≤ i) :
+    (x.zeroExtend (w + k)).getMsb i = x.getMsb (i - k) := by
+  by_cases h : w = 0
+  · subst h; simp
+  simp only [getMsb, getLsb_zeroExtend]
+  by_cases h₁ : i < w + k <;> by_cases h₂ : i - k < w <;> by_cases h₃ : w + k - 1 - i < w + k
+    <;> simp [h₁, h₂, h₃]
+  · congr 1
+    omega
+  all_goals (first | apply getLsb_ge | apply Eq.symm; apply getLsb_ge)
+    <;> omega
+
 @[simp] theorem getLsb_truncate (m : Nat) (x : BitVec n) (i : Nat) :
     getLsb (truncate m x) i = (decide (i < m) && getLsb x i) :=
   getLsb_zeroExtend m x i
 
+theorem msb_truncate (x : BitVec w) : (x.truncate (k + 1)).msb = x.getLsb k := by
+  simp [BitVec.msb, getMsb]
+
 @[simp] theorem zeroExtend_zeroExtend_of_le (x : BitVec w) (h : k ≤ l) :
     (x.zeroExtend l).zeroExtend k = x.zeroExtend k := by
   ext i
@@ -301,11 +325,18 @@ theorem nat_eq_toNat (x : BitVec w) (y : Nat)
     (x.truncate l).truncate k = x.truncate k :=
   zeroExtend_zeroExtend_of_le x h
 
+@[simp] theorem truncate_cast {h : w = v} : (cast h x).truncate k = x.truncate k := by
+  apply eq_of_getLsb_eq
+  simp
+
 theorem msb_zeroExtend (x : BitVec w) : (x.zeroExtend v).msb = (decide (0 < v) && x.getLsb (v - 1)) := by
   rw [msb_eq_getLsb_last]
   simp only [getLsb_zeroExtend]
   cases getLsb x (v - 1) <;> simp; omega
 
+theorem msb_zeroExtend' (x : BitVec w) (h : w ≤ v) : (x.zeroExtend' h).msb = (decide (0 < v) && x.getLsb (v - 1)) := by
+  rw [zeroExtend'_eq, msb_zeroExtend]
+
 /-! ## extractLsb -/
 
 @[simp]
@@ -353,6 +384,18 @@ protected theorem extractLsb_ofNat (x n : Nat) (hi lo : Nat) :
   rw [← testBit_toNat, getLsb, getLsb]
   simp
 
+@[simp] theorem getMsb_or {x y : BitVec w} : (x ||| y).getMsb i = (x.getMsb i || y.getMsb i) := by
+  simp only [getMsb]
+  by_cases h : i < w <;> simp [h]
+
+@[simp] theorem msb_or {x y : BitVec w} : (x ||| y).msb = (x.msb || y.msb) := by
+  simp [BitVec.msb]
+
+@[simp] theorem truncate_or {x y : BitVec w} :
+    (x ||| y).truncate k = x.truncate k ||| y.truncate k := by
+  ext
+  simp
+
 /-! ### and -/
 
 @[simp] theorem toNat_and (x y : BitVec v) :
@@ -367,6 +410,18 @@ protected theorem extractLsb_ofNat (x n : Nat) (hi lo : Nat) :
   rw [← testBit_toNat, getLsb, getLsb]
   simp
 
+@[simp] theorem getMsb_and {x y : BitVec w} : (x &&& y).getMsb i = (x.getMsb i && y.getMsb i) := by
+  simp only [getMsb]
+  by_cases h : i < w <;> simp [h]
+
+@[simp] theorem msb_and {x y : BitVec w} : (x &&& y).msb = (x.msb && y.msb) := by
+  simp [BitVec.msb]
+
+@[simp] theorem truncate_and {x y : BitVec w} :
+    (x &&& y).truncate k = x.truncate k &&& y.truncate k := by
+  ext
+  simp
+
 /-! ### xor -/
 
 @[simp] theorem toNat_xor (x y : BitVec v) :
@@ -382,6 +437,11 @@ protected theorem extractLsb_ofNat (x n : Nat) (hi lo : Nat) :
   rw [← testBit_toNat, getLsb, getLsb]
   simp
 
+@[simp] theorem truncate_xor {x y : BitVec w} :
+    (x ^^^ y).truncate k = x.truncate k ^^^ y.truncate k := by
+  ext
+  simp
+
 /-! ### not -/
 
 theorem not_def {x : BitVec v} : ~~~x = allOnes v ^^^ x := rfl
@@ -396,12 +456,12 @@ theorem not_def {x : BitVec v} : ~~~x = allOnes v ^^^ x := rfl
   | y+1 =>
     rw [Nat.succ_eq_add_one] at h
     rw [← h]
-    rw [Nat.testBit_two_pow_sub_succ (toNat_lt _)]
+    rw [Nat.testBit_two_pow_sub_succ (isLt _)]
     · cases w : decide (i < v)
       · simp at w
         simp [w]
         rw [Nat.testBit_lt_two_pow]
-        calc BitVec.toNat x < 2 ^ v := toNat_lt _
+        calc BitVec.toNat x < 2 ^ v := isLt _
           _ ≤ 2 ^ i := Nat.pow_le_pow_of_le_right Nat.zero_lt_two w
       · simp
 
@@ -414,6 +474,12 @@ theorem not_def {x : BitVec v} : ~~~x = allOnes v ^^^ x := rfl
 @[simp] theorem getLsb_not {x : BitVec v} : (~~~x).getLsb i = (decide (i < v) && ! x.getLsb i) := by
   by_cases h' : i < v <;> simp_all [not_def]
 
+@[simp] theorem truncate_not {x : BitVec w} (h : k ≤ w) :
+    (~~~x).truncate k = ~~~(x.truncate k) := by
+  ext
+  simp [h]
+  omega
+
 /-! ### shiftLeft -/
 
 @[simp, bv_toNat] theorem toNat_shiftLeft {x : BitVec v} :
@@ -431,6 +497,19 @@ theorem not_def {x : BitVec v} : ~~~x = allOnes v ^^^ x := rfl
   cases h₁ : decide (i < m) <;> cases h₂ : decide (n ≤ i) <;> cases h₃ : decide (i < n)
   all_goals { simp_all <;> omega }
 
+@[simp] theorem getMsb_shiftLeft (x : BitVec w) (i) :
+    (x <<< i).getMsb k = x.getMsb (k + i) := by
+  simp only [getMsb, getLsb_shiftLeft]
+  by_cases h : w = 0
+  · subst h; simp
+  have t : w - 1 - k < w := by omega
+  simp only [t]
+  simp only [decide_True, Nat.sub_sub, Bool.true_and, Nat.add_assoc]
+  by_cases h₁ : k < w <;> by_cases h₂ : w - (1 + k) < i <;> by_cases h₃ : k + i < w
+    <;> simp [h₁, h₂, h₃]
+    <;> (first | apply getLsb_ge | apply Eq.symm; apply getLsb_ge)
+    <;> omega
+
 theorem shiftLeftZeroExtend_eq {x : BitVec w} :
     shiftLeftZeroExtend x n = zeroExtend (w+n) x <<< n := by
   apply eq_of_toNat_eq
@@ -439,7 +518,7 @@ theorem shiftLeftZeroExtend_eq {x : BitVec w} :
   · simp
     rw [Nat.mod_eq_of_lt]
     rw [Nat.shiftLeft_eq, Nat.pow_add]
-    exact Nat.mul_lt_mul_of_pos_right (BitVec.toNat_lt x) (Nat.two_pow_pos _)
+    exact Nat.mul_lt_mul_of_pos_right x.isLt (Nat.two_pow_pos _)
   · omega
 
 @[simp] theorem getLsb_shiftLeftZeroExtend (x : BitVec m) (n : Nat) :
@@ -450,6 +529,10 @@ theorem shiftLeftZeroExtend_eq {x : BitVec w} :
     <;> simp_all
     <;> (rw [getLsb_ge]; omega)
 
+@[simp] theorem msb_shiftLeftZeroExtend (x : BitVec w) (i : Nat) :
+    (shiftLeftZeroExtend x i).msb = x.msb := by
+  simp [shiftLeftZeroExtend_eq, BitVec.msb]
+
 /-! ### ushiftRight -/
 
 @[simp, bv_toNat] theorem toNat_ushiftRight (x : BitVec n) (i : Nat) :
@@ -475,6 +558,34 @@ theorem append_def (x : BitVec v) (y : BitVec w) :
   · simp [h]
   · simp [h]; simp_all
 
+theorem msb_append {x : BitVec w} {y : BitVec v} :
+    (x ++ y).msb = bif (w == 0) then (y.msb) else (x.msb) := by
+  rw [← append_eq, append]
+  simp [msb_zeroExtend']
+  by_cases h : w = 0
+  · subst h
+    simp [BitVec.msb, getMsb]
+  · rw [cond_eq_if]
+    have q : 0 < w + v := by omega
+    have t : y.getLsb (w + v - 1) = false := getLsb_ge _ _ (by omega)
+    simp [h, q, t, BitVec.msb, getMsb]
+
+@[simp] theorem truncate_append {x : BitVec w} {y : BitVec v} :
+    (x ++ y).truncate k = if h : k ≤ v then y.truncate k else (x.truncate (k - v) ++ y).cast (by omega) := by
+  apply eq_of_getLsb_eq
+  intro i
+  simp only [getLsb_zeroExtend, Fin.is_lt, decide_True, getLsb_append, Bool.true_and]
+  split
+  · have t : i < v := by omega
+    simp [t]
+  · by_cases t : i < v
+    · simp [t]
+    · have t' : i - v < k - v := by omega
+      simp [t, t']
+
+@[simp] theorem truncate_cons {x : BitVec w} : (cons a x).truncate w = x := by
+  simp [cons]
+
 /-! ### rev -/
 
 theorem getLsb_rev (x : BitVec w) (i : Fin w) :
@@ -497,6 +608,11 @@ theorem getMsb_rev (x : BitVec w) (i : Fin w) :
   let ⟨x, _⟩ := x
   simp [cons, toNat_append, toNat_ofBool]
 
+/-- Variant of `toNat_cons` using `+` instead of `|||`. -/
+theorem toNat_cons' {x : BitVec w} :
+    (cons a x).toNat = (a.toNat <<< w) + x.toNat := by
+  simp [cons, Nat.shiftLeft_eq, Nat.mul_comm _ (2^w), Nat.mul_add_lt_is_or, x.isLt]
+
 @[simp] theorem getLsb_cons (b : Bool) {n} (x : BitVec n) (i : Nat) :
     getLsb (cons b x) i = if i = n then b else getLsb x i := by
   simp only [getLsb, toNat_cons, Nat.testBit_or]
@@ -511,6 +627,9 @@ theorem getMsb_rev (x : BitVec w) (i : Fin w) :
     have p2 : i - n ≠ 0 := by omega
     simp [p1, p2, Nat.testBit_bool_to_nat]
 
+@[simp] theorem msb_cons : (cons a x).msb = a := by
+  simp [cons, msb_cast, msb_append]
+
 theorem truncate_succ (x : BitVec w) :
     truncate (i+1) x = cons (getLsb x i) (truncate i x) := by
   apply eq_of_getLsb_eq
@@ -522,6 +641,15 @@ theorem truncate_succ (x : BitVec w) :
     have j_lt : j.val < i := Nat.lt_of_le_of_ne (Nat.le_of_succ_le_succ j.isLt) j_eq
     simp [j_eq, j_lt]
 
+theorem eq_msb_cons_truncate (x : BitVec (w+1)) : x = (cons x.msb (x.truncate w)) := by
+  ext i
+  simp
+  split <;> rename_i h
+  · simp [BitVec.msb, getMsb, h]
+  · by_cases h' : i < w
+    · simp_all
+    · omega
+
 /-! ### concat -/
 
 @[simp] theorem toNat_concat (x : BitVec w) (b : Bool) :
@@ -546,6 +674,21 @@ theorem getLsb_concat (x : BitVec w) (b : Bool) (i : Nat) :
 @[simp] theorem getLsb_concat_succ : (concat x b).getLsb (i + 1) = x.getLsb i := by
   simp [getLsb_concat]
 
+@[simp] theorem not_concat (x : BitVec w) (b : Bool) : ~~~(concat x b) = concat (~~~x) !b := by
+  ext i; cases i using Fin.succRecOn <;> simp [*, Nat.succ_lt_succ]
+
+@[simp] theorem concat_or_concat (x y : BitVec w) (a b : Bool) :
+    (concat x a) ||| (concat y b) = concat (x ||| y) (a || b) := by
+  ext i; cases i using Fin.succRecOn <;> simp
+
+@[simp] theorem concat_and_concat (x y : BitVec w) (a b : Bool) :
+    (concat x a) &&& (concat y b) = concat (x &&& y) (a && b) := by
+  ext i; cases i using Fin.succRecOn <;> simp
+
+@[simp] theorem concat_xor_concat (x y : BitVec w) (a b : Bool) :
+    (concat x a) ^^^ (concat y b) = concat (x ^^^ y) (xor a b) := by
+  ext i; cases i using Fin.succRecOn <;> simp
+
 /-! ### add -/
 
 theorem add_def {n} (x y : BitVec n) : x + y = .ofNat n (x.toNat + y.toNat) := rfl
@@ -572,6 +715,10 @@ protected theorem add_comm (x y : BitVec n) : x + y = y + x := by
 
 @[simp] protected theorem zero_add (x : BitVec n) : 0#n + x = x := by simp [add_def]
 
+theorem truncate_add (x y : BitVec w) (h : i ≤ w) :
+    (x + y).truncate i = x.truncate i + y.truncate i := by
+  have dvd : 2^i ∣ 2^w := Nat.pow_dvd_pow _ h
+  simp [bv_toNat, h, Nat.mod_mod_of_dvd _ dvd]
 
 /-! ### sub/neg -/
 

src/Init/Data/Bool.lean

@@ -132,6 +132,9 @@ theorem and_or_distrib_right : ∀ (x y z : Bool), ((x || y) && z) = (x && z ||
 theorem or_and_distrib_left  : ∀ (x y z : Bool), (x || y && z) = ((x || y) && (x || z)) := by decide
 theorem or_and_distrib_right : ∀ (x y z : Bool), (x && y || z) = ((x || z) && (y || z)) := by decide
 
+theorem and_xor_distrib_left : ∀ (x y z : Bool), (x && xor y z) = xor (x && y) (x && z) := by decide
+theorem and_xor_distrib_right : ∀ (x y z : Bool), (xor x y && z) = xor (x && z) (y && z) := by decide
+
 /-- De Morgan's law for boolean and -/
 @[simp] theorem not_and : ∀ (x y : Bool), (!(x && y)) = (!x || !y) := by decide
 
@@ -428,12 +431,17 @@ theorem cond_eq_if : (bif b then x else y) = (if b then x else y) := cond_eq_ite
 @[simp] theorem cond_self (c : Bool) (t : α) : cond c t t = t := by cases c <;> rfl
 
 /-
-This is a simp rule in Mathlib, but results in non-confluence that is
-difficult to fix as decide distributes over propositions.
+This is a simp rule in Mathlib, but results in non-confluence that is difficult
+to fix as decide distributes over propositions. As an example, observe that
+`cond (decide (p ∧ q)) t f` could simplify to either:
 
-A possible fix would be to completely simplify away `cond`, but that
-is not taken since it could result in major rewriting of code that is
-otherwise purely about `Bool`.
+* `if p ∧ q then t else f` via `Bool.cond_decide` or
+* `cond (decide p && decide q) t f` via `Bool.decide_and`.
+
+A possible approach to improve normalization between `cond` and `ite` would be
+to completely simplify away `cond` by making `cond_eq_ite` a `simp` rule, but
+that has not been taken since it could surprise users to migrate pure `Bool`
+operations like `cond` to a mix of `Prop` and `Bool`.
 -/
 theorem cond_decide {α} (p : Prop) [Decidable p] (t e : α) :
     cond (decide p) t e = if p then t else e := by

src/Init/Data/Int.lean

@@ -11,3 +11,4 @@ import Init.Data.Int.DivModLemmas
 import Init.Data.Int.Gcd
 import Init.Data.Int.Lemmas
 import Init.Data.Int.Order
+import Init.Data.Int.Pow

src/Init/Data/Int/DivMod.lean

@@ -158,6 +158,14 @@ instance : Div Int where
 instance : Mod Int where
   mod := Int.emod
 
+@[simp, norm_cast] theorem ofNat_ediv (m n : Nat) : (↑(m / n) : Int) = ↑m / ↑n := rfl
+
+theorem ofNat_div (m n : Nat) : ↑(m / n) = div ↑m ↑n := rfl
+
+theorem ofNat_fdiv : ∀ m n : Nat, ↑(m / n) = fdiv ↑m ↑n
+  | 0, _ => by simp [fdiv]
+  | succ _, _ => rfl
+
 /-!
 # `bmod` ("balanced" mod)
 

src/Init/Data/Int/Gcd.lean

@@ -6,7 +6,12 @@ Authors: Mario Carneiro
 prelude
 import Init.Data.Int.Basic
 import Init.Data.Nat.Gcd
+import Init.Data.Nat.Lcm
+import Init.Data.Int.DivModLemmas
 
+/-!
+Definition and lemmas for gcd and lcm over Int
+-/
 namespace Int
 
 /-! ## gcd -/
@@ -14,4 +19,37 @@ namespace Int
 /-- Computes the greatest common divisor of two integers, as a `Nat`. -/
 def gcd (m n : Int) : Nat := m.natAbs.gcd n.natAbs
 
+theorem gcd_dvd_left {a b : Int} : (gcd a b : Int) ∣ a := by
+  have := Nat.gcd_dvd_left a.natAbs b.natAbs
+  rw [← Int.ofNat_dvd] at this
+  exact Int.dvd_trans this natAbs_dvd_self
+
+theorem gcd_dvd_right {a b : Int} : (gcd a b : Int) ∣ b := by
+  have := Nat.gcd_dvd_right a.natAbs b.natAbs
+  rw [← Int.ofNat_dvd] at this
+  exact Int.dvd_trans this natAbs_dvd_self
+
+@[simp] theorem one_gcd {a : Int} : gcd 1 a = 1 := by simp [gcd]
+@[simp] theorem gcd_one {a : Int} : gcd a 1 = 1 := by simp [gcd]
+
+@[simp] theorem neg_gcd {a b : Int} : gcd (-a) b = gcd a b := by simp [gcd]
+@[simp] theorem gcd_neg {a b : Int} : gcd a (-b) = gcd a b := by simp [gcd]
+
+/-! ## lcm -/
+
+/-- Computes the least common multiple of two integers, as a `Nat`. -/
+def lcm (m n : Int) : Nat := m.natAbs.lcm n.natAbs
+
+theorem lcm_ne_zero (hm : m ≠ 0) (hn : n ≠ 0) : lcm m n ≠ 0 := by
+  simp only [lcm]
+  apply Nat.lcm_ne_zero <;> simpa
+
+theorem dvd_lcm_left {a b : Int} : a ∣ lcm a b :=
+  Int.dvd_trans dvd_natAbs_self (Int.ofNat_dvd.mpr (Nat.dvd_lcm_left a.natAbs b.natAbs))
+
+theorem dvd_lcm_right {a b : Int} : b ∣ lcm a b :=
+  Int.dvd_trans dvd_natAbs_self (Int.ofNat_dvd.mpr (Nat.dvd_lcm_right a.natAbs b.natAbs))
+
+@[simp] theorem lcm_self {a : Int} : lcm a a = a.natAbs := Nat.lcm_self _
+
 end Int

src/Init/Data/Int/Lemmas.lean

@@ -153,7 +153,7 @@ theorem subNatNat_sub (h : n ≤ m) (k : Nat) : subNatNat (m - n) k = subNatNat
 theorem subNatNat_add (m n k : Nat) : subNatNat (m + n) k = m + subNatNat n k := by
   cases n.lt_or_ge k with
   | inl h' =>
-    simp [subNatNat_of_lt h', succ_pred_eq_of_pos (Nat.sub_pos_of_lt h')]
+    simp [subNatNat_of_lt h', sub_one_add_one_eq_of_pos (Nat.sub_pos_of_lt h')]
     conv => lhs; rw [← Nat.sub_add_cancel (Nat.le_of_lt h')]
     apply subNatNat_add_add
   | inr h' => simp [subNatNat_of_le h',
@@ -169,12 +169,11 @@ theorem subNatNat_add_negSucc (m n k : Nat) :
     rw [subNatNat_sub h', Nat.add_comm]
   | inl h' =>
     have h₂ : m < n + succ k := Nat.lt_of_lt_of_le h' (le_add_right _ _)
-    have h₃ : m ≤ n + k := le_of_succ_le_succ h₂
     rw [subNatNat_of_lt h', subNatNat_of_lt h₂]
-    simp [Nat.add_comm]
-    rw [← add_succ, succ_pred_eq_of_pos (Nat.sub_pos_of_lt h'), add_succ, succ_sub h₃,
-      Nat.pred_succ]
-    rw [Nat.add_comm n, Nat.add_sub_assoc (Nat.le_of_lt h')]
+    simp only [pred_eq_sub_one, negSucc_add_negSucc, succ_eq_add_one, negSucc.injEq]
+    rw [Nat.add_right_comm, sub_one_add_one_eq_of_pos (Nat.sub_pos_of_lt h'), Nat.sub_sub,
+      ← Nat.add_assoc, succ_sub_succ_eq_sub, Nat.add_comm n,Nat.add_sub_assoc (Nat.le_of_lt h'),
+      Nat.add_comm]
 
 protected theorem add_assoc : ∀ a b c : Int, a + b + c = a + (b + c)
   | (m:Nat), (n:Nat), c => aux1 ..
@@ -188,15 +187,15 @@ protected theorem add_assoc : ∀ a b c : Int, a + b + c = a + (b + c)
   | (m:Nat), -[n+1], -[k+1] => by
     rw [Int.add_comm, Int.add_comm m, Int.add_comm m, ← aux2, Int.add_comm -[k+1]]
   | -[m+1], -[n+1], -[k+1] => by
-    simp [add_succ, Nat.add_comm, Nat.add_left_comm, neg_ofNat_succ]
+    simp [Nat.add_comm, Nat.add_left_comm, Nat.add_assoc]
 where
   aux1 (m n : Nat) : ∀ c : Int, m + n + c = m + (n + c)
     | (k:Nat) => by simp [Nat.add_assoc]
     | -[k+1]  => by simp [subNatNat_add]
   aux2 (m n k : Nat) : -[m+1] + -[n+1] + k = -[m+1] + (-[n+1] + k) := by
-    simp [add_succ]
+    simp
     rw [Int.add_comm, subNatNat_add_negSucc]
-    simp [add_succ, succ_add, Nat.add_comm]
+    simp [Nat.add_comm, Nat.add_left_comm, Nat.add_assoc]
 
 protected theorem add_left_comm (a b c : Int) : a + (b + c) = b + (a + c) := by
   rw [← Int.add_assoc, Int.add_comm a, Int.add_assoc]
@@ -391,7 +390,7 @@ theorem ofNat_mul_subNatNat (m n k : Nat) :
     | inl h =>
       have h' : succ m * n < succ m * k := Nat.mul_lt_mul_of_pos_left h (Nat.succ_pos m)
       simp [subNatNat_of_lt h, subNatNat_of_lt h']
-      rw [succ_pred_eq_of_pos (Nat.sub_pos_of_lt h), ← neg_ofNat_succ, Nat.mul_sub_left_distrib,
+      rw [sub_one_add_one_eq_of_pos (Nat.sub_pos_of_lt h), ← neg_ofNat_succ, Nat.mul_sub_left_distrib,
         ← succ_pred_eq_of_pos (Nat.sub_pos_of_lt h')]; rfl
     | inr h =>
       have h' : succ m * k ≤ succ m * n := Nat.mul_le_mul_left _ h
@@ -406,7 +405,7 @@ theorem negSucc_mul_subNatNat (m n k : Nat) :
   | inl h =>
     have h' : succ m * n < succ m * k := Nat.mul_lt_mul_of_pos_left h (Nat.succ_pos m)
     rw [subNatNat_of_lt h, subNatNat_of_le (Nat.le_of_lt h')]
-    simp [succ_pred_eq_of_pos (Nat.sub_pos_of_lt h), Nat.mul_sub_left_distrib]
+    simp [sub_one_add_one_eq_of_pos (Nat.sub_pos_of_lt h), Nat.mul_sub_left_distrib]
   | inr h => cases Nat.lt_or_ge k n with
     | inl h' =>
       have h₁ : succ m * n > succ m * k := Nat.mul_lt_mul_of_pos_left h' (Nat.succ_pos m)
@@ -422,12 +421,12 @@ protected theorem mul_add : ∀ a b c : Int, a * (b + c) = a * b + a * c
     simp [negOfNat_eq_subNatNat_zero]; rw [← subNatNat_add]; rfl
   | (m:Nat), -[n+1],  (k:Nat) => by
     simp [negOfNat_eq_subNatNat_zero]; rw [Int.add_comm, ← subNatNat_add]; rfl
-  | (m:Nat), -[n+1],  -[k+1]  => by simp; rw [← Nat.left_distrib, succ_add]; rfl
+  | (m:Nat), -[n+1],  -[k+1]  => by simp [← Nat.left_distrib, Nat.add_left_comm, Nat.add_assoc]
   | -[m+1],  (n:Nat), (k:Nat) => by simp [Nat.mul_comm]; rw [← Nat.right_distrib, Nat.mul_comm]
   | -[m+1],  (n:Nat), -[k+1]  => by
     simp [negOfNat_eq_subNatNat_zero]; rw [Int.add_comm, ← subNatNat_add]; rfl
   | -[m+1],  -[n+1],  (k:Nat) => by simp [negOfNat_eq_subNatNat_zero]; rw [← subNatNat_add]; rfl
-  | -[m+1],  -[n+1],  -[k+1]  => by simp; rw [← Nat.left_distrib, succ_add]; rfl
+  | -[m+1],  -[n+1],  -[k+1]  => by simp [← Nat.left_distrib, Nat.add_left_comm, Nat.add_assoc]
 
 protected theorem add_mul (a b c : Int) : (a + b) * c = a * c + b * c := by
   simp [Int.mul_comm, Int.mul_add]
@@ -499,33 +498,6 @@ theorem eq_one_of_mul_eq_self_left {a b : Int} (Hpos : a ≠ 0) (H : b * a = a)
 theorem eq_one_of_mul_eq_self_right {a b : Int} (Hpos : b ≠ 0) (H : b * a = b) : a = 1 :=
   Int.eq_of_mul_eq_mul_left Hpos <| by rw [Int.mul_one, H]
 
-/-! # pow -/
-
-protected theorem pow_zero (b : Int) : b^0 = 1 := rfl
-
-protected theorem pow_succ (b : Int) (e : Nat) : b ^ (e+1) = (b ^ e) * b := rfl
-protected theorem pow_succ' (b : Int) (e : Nat) : b ^ (e+1) = b * (b ^ e) := by
-  rw [Int.mul_comm, Int.pow_succ]
-
-theorem pow_le_pow_of_le_left {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i
-  | 0      => Nat.le_refl _
-  | succ i => Nat.mul_le_mul (pow_le_pow_of_le_left h i) h
-
-theorem pow_le_pow_of_le_right {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j
-  | 0,      h =>
-    have : i = 0 := eq_zero_of_le_zero h
-    this.symm ▸ Nat.le_refl _
-  | succ j, h =>
-    match le_or_eq_of_le_succ h with
-    | Or.inl h => show n^i ≤ n^j * n from
-      have : n^i * 1 ≤ n^j * n := Nat.mul_le_mul (pow_le_pow_of_le_right hx h) hx
-      Nat.mul_one (n^i) ▸ this
-    | Or.inr h =>
-      h.symm ▸ Nat.le_refl _
-
-theorem pos_pow_of_pos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m :=
-  pow_le_pow_of_le_right h (Nat.zero_le _)
-
 /-! NatCast lemmas -/
 
 /-!
@@ -545,10 +517,4 @@ theorem natCast_one : ((1 : Nat) : Int) = (1 : Int) := rfl
 @[simp] theorem natCast_mul (a b : Nat) : ((a * b : Nat) : Int) = (a : Int) * (b : Int) := by
   simp
 
-theorem natCast_pow (b n : Nat) : ((b^n : Nat) : Int) = (b : Int) ^ n := by
-  match n with
-  | 0 => rfl
-  | n + 1 =>
-    simp only [Nat.pow_succ, Int.pow_succ, natCast_mul, natCast_pow _ n]
-
 end Int

src/Init/Data/Int/Order.lean

@@ -6,6 +6,7 @@ Authors: Jeremy Avigad, Deniz Aydin, Floris van Doorn, Mario Carneiro
 prelude
 import Init.Data.Int.Lemmas
 import Init.ByCases
+import Init.RCases
 
 /-!
 # Results about the order properties of the integers, and the integers as an ordered ring.
@@ -498,3 +499,524 @@ theorem toNat_add_nat {a : Int} (ha : 0 ≤ a) (n : Nat) : (a + n).toNat = a.toN
 @[simp] theorem toNat_neg_nat : ∀ n : Nat, (-(n : Int)).toNat = 0
   | 0 => rfl
   | _+1 => rfl
+
+/-! ### toNat' -/
+
+theorem mem_toNat' : ∀ (a : Int) (n : Nat), toNat' a = some n ↔ a = n
+  | (m : Nat), n => by simp [toNat', Int.ofNat_inj]
+  | -[m+1], n => by constructor <;> nofun
+
+/-! ## Order properties of the integers -/
+
+protected theorem lt_of_not_ge {a b : Int} : ¬a ≤ b → b < a := Int.not_le.mp
+protected theorem not_le_of_gt {a b : Int} : b < a → ¬a ≤ b := Int.not_le.mpr
+
+protected theorem le_of_not_le {a b : Int} : ¬ a ≤ b → b ≤ a := (Int.le_total a b).resolve_left
+
+@[simp] theorem negSucc_not_pos (n : Nat) : 0 < -[n+1] ↔ False := by
+  simp only [Int.not_lt, iff_false]; constructor
+
+theorem eq_negSucc_of_lt_zero : ∀ {a : Int}, a < 0 → ∃ n : Nat, a = -[n+1]
+  | ofNat _, h => absurd h (Int.not_lt.2 (ofNat_zero_le _))
+  | -[n+1],  _ => ⟨n, rfl⟩
+
+protected theorem lt_of_add_lt_add_left {a b c : Int} (h : a + b < a + c) : b < c := by
+  have : -a + (a + b) < -a + (a + c) := Int.add_lt_add_left h _
+  simp [Int.neg_add_cancel_left] at this
+  assumption
+
+protected theorem lt_of_add_lt_add_right {a b c : Int} (h : a + b < c + b) : a < c :=
+  Int.lt_of_add_lt_add_left (a := b) <| by rwa [Int.add_comm b a, Int.add_comm b c]
+
+protected theorem add_lt_add_iff_left (a : Int) : a + b < a + c ↔ b < c :=
+  ⟨Int.lt_of_add_lt_add_left, (Int.add_lt_add_left · _)⟩
+
+protected theorem add_lt_add_iff_right (c : Int) : a + c < b + c ↔ a < b :=
+  ⟨Int.lt_of_add_lt_add_right, (Int.add_lt_add_right · _)⟩
+
+protected theorem add_lt_add {a b c d : Int} (h₁ : a < b) (h₂ : c < d) : a + c < b + d :=
+  Int.lt_trans (Int.add_lt_add_right h₁ c) (Int.add_lt_add_left h₂ b)
+
+protected theorem add_lt_add_of_le_of_lt {a b c d : Int} (h₁ : a ≤ b) (h₂ : c < d) :
+    a + c < b + d :=
+  Int.lt_of_le_of_lt (Int.add_le_add_right h₁ c) (Int.add_lt_add_left h₂ b)
+
+protected theorem add_lt_add_of_lt_of_le {a b c d : Int} (h₁ : a < b) (h₂ : c ≤ d) :
+    a + c < b + d :=
+  Int.lt_of_lt_of_le (Int.add_lt_add_right h₁ c) (Int.add_le_add_left h₂ b)
+
+protected theorem lt_add_of_pos_right (a : Int) {b : Int} (h : 0 < b) : a < a + b := by
+  have : a + 0 < a + b := Int.add_lt_add_left h a
+  rwa [Int.add_zero] at this
+
+protected theorem lt_add_of_pos_left (a : Int) {b : Int} (h : 0 < b) : a < b + a := by
+  have : 0 + a < b + a := Int.add_lt_add_right h a
+  rwa [Int.zero_add] at this
+
+protected theorem add_nonneg {a b : Int} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a + b :=
+  Int.zero_add 0 ▸ Int.add_le_add ha hb
+
+protected theorem add_pos {a b : Int} (ha : 0 < a) (hb : 0 < b) : 0 < a + b :=
+  Int.zero_add 0 ▸ Int.add_lt_add ha hb
+
+protected theorem add_pos_of_pos_of_nonneg {a b : Int} (ha : 0 < a) (hb : 0 ≤ b) : 0 < a + b :=
+  Int.zero_add 0 ▸ Int.add_lt_add_of_lt_of_le ha hb
+
+protected theorem add_pos_of_nonneg_of_pos {a b : Int} (ha : 0 ≤ a) (hb : 0 < b) : 0 < a + b :=
+  Int.zero_add 0 ▸ Int.add_lt_add_of_le_of_lt ha hb
+
+protected theorem add_nonpos {a b : Int} (ha : a ≤ 0) (hb : b ≤ 0) : a + b ≤ 0 :=
+  Int.zero_add 0 ▸ Int.add_le_add ha hb
+
+protected theorem add_neg {a b : Int} (ha : a < 0) (hb : b < 0) : a + b < 0 :=
+  Int.zero_add 0 ▸ Int.add_lt_add ha hb
+
+protected theorem add_neg_of_neg_of_nonpos {a b : Int} (ha : a < 0) (hb : b ≤ 0) : a + b < 0 :=
+  Int.zero_add 0 ▸ Int.add_lt_add_of_lt_of_le ha hb
+
+protected theorem add_neg_of_nonpos_of_neg {a b : Int} (ha : a ≤ 0) (hb : b < 0) : a + b < 0 :=
+  Int.zero_add 0 ▸ Int.add_lt_add_of_le_of_lt ha hb
+
+protected theorem lt_add_of_le_of_pos {a b c : Int} (hbc : b ≤ c) (ha : 0 < a) : b < c + a :=
+  Int.add_zero b ▸ Int.add_lt_add_of_le_of_lt hbc ha
+
+theorem add_one_le_iff {a b : Int} : a + 1 ≤ b ↔ a < b := .rfl
+
+theorem lt_add_one_iff {a b : Int} : a < b + 1 ↔ a ≤ b := Int.add_le_add_iff_right _
+
+@[simp] theorem succ_ofNat_pos (n : Nat) : 0 < (n : Int) + 1 :=
+  lt_add_one_iff.2 (ofNat_zero_le _)
+
+theorem le_add_one {a b : Int} (h : a ≤ b) : a ≤ b + 1 :=
+  Int.le_of_lt (Int.lt_add_one_iff.2 h)
+
+protected theorem nonneg_of_neg_nonpos {a : Int} (h : -a ≤ 0) : 0 ≤ a :=
+  Int.le_of_neg_le_neg <| by rwa [Int.neg_zero]
+
+protected theorem nonpos_of_neg_nonneg {a : Int} (h : 0 ≤ -a) : a ≤ 0 :=
+  Int.le_of_neg_le_neg <| by rwa [Int.neg_zero]
+
+protected theorem lt_of_neg_lt_neg {a b : Int} (h : -b < -a) : a < b :=
+  Int.neg_neg a ▸ Int.neg_neg b ▸ Int.neg_lt_neg h
+
+protected theorem pos_of_neg_neg {a : Int} (h : -a < 0) : 0 < a :=
+  Int.lt_of_neg_lt_neg <| by rwa [Int.neg_zero]
+
+protected theorem neg_of_neg_pos {a : Int} (h : 0 < -a) : a < 0 :=
+  have : -0 < -a := by rwa [Int.neg_zero]
+  Int.lt_of_neg_lt_neg this
+
+protected theorem le_neg_of_le_neg {a b : Int} (h : a ≤ -b) : b ≤ -a := by
+  have h := Int.neg_le_neg h
+  rwa [Int.neg_neg] at h
+
+protected theorem neg_le_of_neg_le {a b : Int} (h : -a ≤ b) : -b ≤ a := by
+  have h := Int.neg_le_neg h
+  rwa [Int.neg_neg] at h
+
+protected theorem lt_neg_of_lt_neg {a b : Int} (h : a < -b) : b < -a := by
+  have h := Int.neg_lt_neg h
+  rwa [Int.neg_neg] at h
+
+protected theorem neg_lt_of_neg_lt {a b : Int} (h : -a < b) : -b < a := by
+  have h := Int.neg_lt_neg h
+  rwa [Int.neg_neg] at h
+
+protected theorem sub_nonpos_of_le {a b : Int} (h : a ≤ b) : a - b ≤ 0 := by
+  have h := Int.add_le_add_right h (-b)
+  rwa [Int.add_right_neg] at h
+
+protected theorem le_of_sub_nonpos {a b : Int} (h : a - b ≤ 0) : a ≤ b := by
+  have h := Int.add_le_add_right h b
+  rwa [Int.sub_add_cancel, Int.zero_add] at h
+
+protected theorem sub_neg_of_lt {a b : Int} (h : a < b) : a - b < 0 := by
+  have h := Int.add_lt_add_right h (-b)
+  rwa [Int.add_right_neg] at h
+
+protected theorem lt_of_sub_neg {a b : Int} (h : a - b < 0) : a < b := by
+  have h := Int.add_lt_add_right h b
+  rwa [Int.sub_add_cancel, Int.zero_add] at h
+
+protected theorem add_le_of_le_neg_add {a b c : Int} (h : b ≤ -a + c) : a + b ≤ c := by
+  have h := Int.add_le_add_left h a
+  rwa [Int.add_neg_cancel_left] at h
+
+protected theorem le_neg_add_of_add_le {a b c : Int} (h : a + b ≤ c) : b ≤ -a + c := by
+  have h := Int.add_le_add_left h (-a)
+  rwa [Int.neg_add_cancel_left] at h
+
+protected theorem add_le_of_le_sub_left {a b c : Int} (h : b ≤ c - a) : a + b ≤ c := by
+  have h := Int.add_le_add_left h a
+  rwa [← Int.add_sub_assoc, Int.add_comm a c, Int.add_sub_cancel] at h
+
+protected theorem le_sub_left_of_add_le {a b c : Int} (h : a + b ≤ c) : b ≤ c - a := by
+  have h := Int.add_le_add_right h (-a)
+  rwa [Int.add_comm a b, Int.add_neg_cancel_right] at h
+
+protected theorem add_le_of_le_sub_right {a b c : Int} (h : a ≤ c - b) : a + b ≤ c := by
+  have h := Int.add_le_add_right h b
+  rwa [Int.sub_add_cancel] at h
+
+protected theorem le_sub_right_of_add_le {a b c : Int} (h : a + b ≤ c) : a ≤ c - b := by
+  have h := Int.add_le_add_right h (-b)
+  rwa [Int.add_neg_cancel_right] at h
+
+protected theorem le_add_of_neg_add_le {a b c : Int} (h : -b + a ≤ c) : a ≤ b + c := by
+  have h := Int.add_le_add_left h b
+  rwa [Int.add_neg_cancel_left] at h
+
+protected theorem neg_add_le_of_le_add {a b c : Int} (h : a ≤ b + c) : -b + a ≤ c := by
+  have h := Int.add_le_add_left h (-b)
+  rwa [Int.neg_add_cancel_left] at h
+
+protected theorem le_add_of_sub_left_le {a b c : Int} (h : a - b ≤ c) : a ≤ b + c := by
+  have h := Int.add_le_add_right h b
+  rwa [Int.sub_add_cancel, Int.add_comm] at h
+
+protected theorem le_add_of_sub_right_le {a b c : Int} (h : a - c ≤ b) : a ≤ b + c := by
+  have h := Int.add_le_add_right h c
+  rwa [Int.sub_add_cancel] at h
+
+protected theorem sub_right_le_of_le_add {a b c : Int} (h : a ≤ b + c) : a - c ≤ b := by
+  have h := Int.add_le_add_right h (-c)
+  rwa [Int.add_neg_cancel_right] at h
+
+protected theorem le_add_of_neg_add_le_left {a b c : Int} (h : -b + a ≤ c) : a ≤ b + c := by
+  rw [Int.add_comm] at h
+  exact Int.le_add_of_sub_left_le h
+
+protected theorem neg_add_le_left_of_le_add {a b c : Int} (h : a ≤ b + c) : -b + a ≤ c := by
+  rw [Int.add_comm]
+  exact Int.sub_left_le_of_le_add h
+
+protected theorem le_add_of_neg_add_le_right {a b c : Int} (h : -c + a ≤ b) : a ≤ b + c := by
+  rw [Int.add_comm] at h
+  exact Int.le_add_of_sub_right_le h
+
+protected theorem neg_add_le_right_of_le_add {a b c : Int} (h : a ≤ b + c) : -c + a ≤ b := by
+  rw [Int.add_comm] at h
+  exact Int.neg_add_le_left_of_le_add h
+
+protected theorem le_add_of_neg_le_sub_left {a b c : Int} (h : -a ≤ b - c) : c ≤ a + b :=
+  Int.le_add_of_neg_add_le_left (Int.add_le_of_le_sub_right h)
+
+protected theorem neg_le_sub_left_of_le_add {a b c : Int} (h : c ≤ a + b) : -a ≤ b - c := by
+  have h := Int.le_neg_add_of_add_le (Int.sub_left_le_of_le_add h)
+  rwa [Int.add_comm] at h
+
+protected theorem le_add_of_neg_le_sub_right {a b c : Int} (h : -b ≤ a - c) : c ≤ a + b :=
+  Int.le_add_of_sub_right_le (Int.add_le_of_le_sub_left h)
+
+protected theorem neg_le_sub_right_of_le_add {a b c : Int} (h : c ≤ a + b) : -b ≤ a - c :=
+  Int.le_sub_left_of_add_le (Int.sub_right_le_of_le_add h)
+
+protected theorem sub_le_of_sub_le {a b c : Int} (h : a - b ≤ c) : a - c ≤ b :=
+  Int.sub_left_le_of_le_add (Int.le_add_of_sub_right_le h)
+
+protected theorem sub_le_sub_left {a b : Int} (h : a ≤ b) (c : Int) : c - b ≤ c - a :=
+  Int.add_le_add_left (Int.neg_le_neg h) c
+
+protected theorem sub_le_sub_right {a b : Int} (h : a ≤ b) (c : Int) : a - c ≤ b - c :=
+  Int.add_le_add_right h (-c)
+
+protected theorem sub_le_sub {a b c d : Int} (hab : a ≤ b) (hcd : c ≤ d) : a - d ≤ b - c :=
+  Int.add_le_add hab (Int.neg_le_neg hcd)
+
+protected theorem add_lt_of_lt_neg_add {a b c : Int} (h : b < -a + c) : a + b < c := by
+  have h := Int.add_lt_add_left h a
+  rwa [Int.add_neg_cancel_left] at h
+
+protected theorem lt_neg_add_of_add_lt {a b c : Int} (h : a + b < c) : b < -a + c := by
+  have h := Int.add_lt_add_left h (-a)
+  rwa [Int.neg_add_cancel_left] at h
+
+protected theorem add_lt_of_lt_sub_left {a b c : Int} (h : b < c - a) : a + b < c := by
+  have h := Int.add_lt_add_left h a
+  rwa [← Int.add_sub_assoc, Int.add_comm a c, Int.add_sub_cancel] at h
+
+protected theorem lt_sub_left_of_add_lt {a b c : Int} (h : a + b < c) : b < c - a := by
+  have h := Int.add_lt_add_right h (-a)
+  rwa [Int.add_comm a b, Int.add_neg_cancel_right] at h
+
+protected theorem add_lt_of_lt_sub_right {a b c : Int} (h : a < c - b) : a + b < c := by
+  have h := Int.add_lt_add_right h b
+  rwa [Int.sub_add_cancel] at h
+
+protected theorem lt_sub_right_of_add_lt {a b c : Int} (h : a + b < c) : a < c - b := by
+  have h := Int.add_lt_add_right h (-b)
+  rwa [Int.add_neg_cancel_right] at h
+
+protected theorem lt_add_of_neg_add_lt {a b c : Int} (h : -b + a < c) : a < b + c := by
+  have h := Int.add_lt_add_left h b
+  rwa [Int.add_neg_cancel_left] at h
+
+protected theorem neg_add_lt_of_lt_add {a b c : Int} (h : a < b + c) : -b + a < c := by
+  have h := Int.add_lt_add_left h (-b)
+  rwa [Int.neg_add_cancel_left] at h
+
+protected theorem lt_add_of_sub_left_lt {a b c : Int} (h : a - b < c) : a < b + c := by
+  have h := Int.add_lt_add_right h b
+  rwa [Int.sub_add_cancel, Int.add_comm] at h
+
+protected theorem sub_left_lt_of_lt_add {a b c : Int} (h : a < b + c) : a - b < c := by
+  have h := Int.add_lt_add_right h (-b)
+  rwa [Int.add_comm b c, Int.add_neg_cancel_right] at h
+
+protected theorem lt_add_of_sub_right_lt {a b c : Int} (h : a - c < b) : a < b + c := by
+  have h := Int.add_lt_add_right h c
+  rwa [Int.sub_add_cancel] at h
+
+protected theorem sub_right_lt_of_lt_add {a b c : Int} (h : a < b + c) : a - c < b := by
+  have h := Int.add_lt_add_right h (-c)
+  rwa [Int.add_neg_cancel_right] at h
+
+protected theorem lt_add_of_neg_add_lt_left {a b c : Int} (h : -b + a < c) : a < b + c := by
+  rw [Int.add_comm] at h
+  exact Int.lt_add_of_sub_left_lt h
+
+protected theorem neg_add_lt_left_of_lt_add {a b c : Int} (h : a < b + c) : -b + a < c := by
+  rw [Int.add_comm]
+  exact Int.sub_left_lt_of_lt_add h
+
+protected theorem lt_add_of_neg_add_lt_right {a b c : Int} (h : -c + a < b) : a < b + c := by
+  rw [Int.add_comm] at h
+  exact Int.lt_add_of_sub_right_lt h
+
+protected theorem neg_add_lt_right_of_lt_add {a b c : Int} (h : a < b + c) : -c + a < b := by
+  rw [Int.add_comm] at h
+  exact Int.neg_add_lt_left_of_lt_add h
+
+protected theorem lt_add_of_neg_lt_sub_left {a b c : Int} (h : -a < b - c) : c < a + b :=
+  Int.lt_add_of_neg_add_lt_left (Int.add_lt_of_lt_sub_right h)
+
+protected theorem neg_lt_sub_left_of_lt_add {a b c : Int} (h : c < a + b) : -a < b - c := by
+  have h := Int.lt_neg_add_of_add_lt (Int.sub_left_lt_of_lt_add h)
+  rwa [Int.add_comm] at h
+
+protected theorem lt_add_of_neg_lt_sub_right {a b c : Int} (h : -b < a - c) : c < a + b :=
+  Int.lt_add_of_sub_right_lt (Int.add_lt_of_lt_sub_left h)
+
+protected theorem neg_lt_sub_right_of_lt_add {a b c : Int} (h : c < a + b) : -b < a - c :=
+  Int.lt_sub_left_of_add_lt (Int.sub_right_lt_of_lt_add h)
+
+protected theorem sub_lt_of_sub_lt {a b c : Int} (h : a - b < c) : a - c < b :=
+  Int.sub_left_lt_of_lt_add (Int.lt_add_of_sub_right_lt h)
+
+protected theorem sub_lt_sub_left {a b : Int} (h : a < b) (c : Int) : c - b < c - a :=
+  Int.add_lt_add_left (Int.neg_lt_neg h) c
+
+protected theorem sub_lt_sub_right {a b : Int} (h : a < b) (c : Int) : a - c < b - c :=
+  Int.add_lt_add_right h (-c)
+
+protected theorem sub_lt_sub {a b c d : Int} (hab : a < b) (hcd : c < d) : a - d < b - c :=
+  Int.add_lt_add hab (Int.neg_lt_neg hcd)
+
+protected theorem sub_lt_sub_of_le_of_lt {a b c d : Int}
+  (hab : a ≤ b) (hcd : c < d) : a - d < b - c :=
+  Int.add_lt_add_of_le_of_lt hab (Int.neg_lt_neg hcd)
+
+protected theorem sub_lt_sub_of_lt_of_le {a b c d : Int}
+  (hab : a < b) (hcd : c ≤ d) : a - d < b - c :=
+  Int.add_lt_add_of_lt_of_le hab (Int.neg_le_neg hcd)
+
+protected theorem add_le_add_three {a b c d e f : Int}
+    (h₁ : a ≤ d) (h₂ : b ≤ e) (h₃ : c ≤ f) : a + b + c ≤ d + e + f :=
+  Int.add_le_add (Int.add_le_add h₁ h₂) h₃
+
+theorem exists_eq_neg_ofNat {a : Int} (H : a ≤ 0) : ∃ n : Nat, a = -(n : Int) :=
+  let ⟨n, h⟩ := eq_ofNat_of_zero_le (Int.neg_nonneg_of_nonpos H)
+  ⟨n, Int.eq_neg_of_eq_neg h.symm⟩
+
+theorem lt_of_add_one_le {a b : Int} (H : a + 1 ≤ b) : a < b := H
+
+theorem lt_add_one_of_le {a b : Int} (H : a ≤ b) : a < b + 1 := Int.add_le_add_right H 1
+
+theorem le_of_lt_add_one {a b : Int} (H : a < b + 1) : a ≤ b := Int.le_of_add_le_add_right H
+
+theorem sub_one_lt_of_le {a b : Int} (H : a ≤ b) : a - 1 < b :=
+  Int.sub_right_lt_of_lt_add <| lt_add_one_of_le H
+
+theorem le_of_sub_one_lt {a b : Int} (H : a - 1 < b) : a ≤ b :=
+  le_of_lt_add_one <| Int.lt_add_of_sub_right_lt H
+
+theorem le_sub_one_of_lt {a b : Int} (H : a < b) : a ≤ b - 1 := Int.le_sub_right_of_add_le H
+
+theorem lt_of_le_sub_one {a b : Int} (H : a ≤ b - 1) : a < b := Int.add_le_of_le_sub_right H
+
+/- ### Order properties and multiplication -/
+
+protected theorem mul_lt_mul {a b c d : Int}
+    (h₁ : a < c) (h₂ : b ≤ d) (h₃ : 0 < b) (h₄ : 0 ≤ c) : a * b < c * d :=
+  Int.lt_of_lt_of_le (Int.mul_lt_mul_of_pos_right h₁ h₃) (Int.mul_le_mul_of_nonneg_left h₂ h₄)
+
+protected theorem mul_lt_mul' {a b c d : Int}
+    (h₁ : a ≤ c) (h₂ : b < d) (h₃ : 0 ≤ b) (h₄ : 0 < c) : a * b < c * d :=
+  Int.lt_of_le_of_lt (Int.mul_le_mul_of_nonneg_right h₁ h₃) (Int.mul_lt_mul_of_pos_left h₂ h₄)
+
+protected theorem mul_neg_of_pos_of_neg {a b : Int} (ha : 0 < a) (hb : b < 0) : a * b < 0 := by
+  have h : a * b < a * 0 := Int.mul_lt_mul_of_pos_left hb ha
+  rwa [Int.mul_zero] at h
+
+protected theorem mul_neg_of_neg_of_pos {a b : Int} (ha : a < 0) (hb : 0 < b) : a * b < 0 := by
+  have h : a * b < 0 * b := Int.mul_lt_mul_of_pos_right ha hb
+  rwa [Int.zero_mul] at h
+
+protected theorem mul_nonneg_of_nonpos_of_nonpos {a b : Int}
+  (ha : a ≤ 0) (hb : b ≤ 0) : 0 ≤ a * b := by
+  have : 0 * b ≤ a * b := Int.mul_le_mul_of_nonpos_right ha hb
+  rwa [Int.zero_mul] at this
+
+protected theorem mul_lt_mul_of_neg_left {a b c : Int} (h : b < a) (hc : c < 0) : c * a < c * b :=
+  have : -c > 0 := Int.neg_pos_of_neg hc
+  have : -c * b < -c * a := Int.mul_lt_mul_of_pos_left h this
+  have : -(c * b) < -(c * a) := by
+    rwa [← Int.neg_mul_eq_neg_mul, ← Int.neg_mul_eq_neg_mul] at this
+  Int.lt_of_neg_lt_neg this
+
+protected theorem mul_lt_mul_of_neg_right {a b c : Int} (h : b < a) (hc : c < 0) : a * c < b * c :=
+  have : -c > 0 := Int.neg_pos_of_neg hc
+  have : b * -c < a * -c := Int.mul_lt_mul_of_pos_right h this
+  have : -(b * c) < -(a * c) := by
+    rwa [← Int.neg_mul_eq_mul_neg, ← Int.neg_mul_eq_mul_neg] at this
+  Int.lt_of_neg_lt_neg this
+
+protected theorem mul_pos_of_neg_of_neg {a b : Int} (ha : a < 0) (hb : b < 0) : 0 < a * b := by
+  have : 0 * b < a * b := Int.mul_lt_mul_of_neg_right ha hb
+  rwa [Int.zero_mul] at this
+
+protected theorem mul_self_le_mul_self {a b : Int} (h1 : 0 ≤ a) (h2 : a ≤ b) : a * a ≤ b * b :=
+  Int.mul_le_mul h2 h2 h1 (Int.le_trans h1 h2)
+
+protected theorem mul_self_lt_mul_self {a b : Int} (h1 : 0 ≤ a) (h2 : a < b) : a * a < b * b :=
+  Int.mul_lt_mul' (Int.le_of_lt h2) h2 h1 (Int.lt_of_le_of_lt h1 h2)
+
+/- ## sign -/
+
+@[simp] theorem sign_zero : sign 0 = 0 := rfl
+@[simp] theorem sign_one : sign 1 = 1 := rfl
+theorem sign_neg_one : sign (-1) = -1 := rfl
+
+@[simp] theorem sign_of_add_one (x : Nat) : Int.sign (x + 1) = 1 := rfl
+@[simp] theorem sign_negSucc (x : Nat) : Int.sign (Int.negSucc x) = -1 := rfl
+
+theorem natAbs_sign (z : Int) : z.sign.natAbs = if z = 0 then 0 else 1 :=
+  match z with | 0 | succ _ | -[_+1] => rfl
+
+theorem natAbs_sign_of_nonzero {z : Int} (hz : z ≠ 0) : z.sign.natAbs = 1 := by
+  rw [Int.natAbs_sign, if_neg hz]
+
+theorem sign_ofNat_of_nonzero {n : Nat} (hn : n ≠ 0) : Int.sign n = 1 :=
+  match n, Nat.exists_eq_succ_of_ne_zero hn with
+  | _, ⟨n, rfl⟩ => Int.sign_of_add_one n
+
+@[simp] theorem sign_neg (z : Int) : Int.sign (-z) = -Int.sign z := by
+  match z with | 0 | succ _ | -[_+1] => rfl
+
+theorem sign_mul_natAbs : ∀ a : Int, sign a * natAbs a = a
+  | 0      => rfl
+  | succ _ => Int.one_mul _
+  | -[_+1] => (Int.neg_eq_neg_one_mul _).symm
+
+@[simp] theorem sign_mul : ∀ a b, sign (a * b) = sign a * sign b
+  | a, 0 | 0, b => by simp [Int.mul_zero, Int.zero_mul]
+  | succ _, succ _ | succ _, -[_+1] | -[_+1], succ _ | -[_+1], -[_+1] => rfl
+
+theorem sign_eq_one_of_pos {a : Int} (h : 0 < a) : sign a = 1 :=
+  match a, eq_succ_of_zero_lt h with
+  | _, ⟨_, rfl⟩ => rfl
+
+theorem sign_eq_neg_one_of_neg {a : Int} (h : a < 0) : sign a = -1 :=
+  match a, eq_negSucc_of_lt_zero h with
+  | _, ⟨_, rfl⟩ => rfl
+
+theorem eq_zero_of_sign_eq_zero : ∀ {a : Int}, sign a = 0 → a = 0
+  | 0, _ => rfl
+
+theorem pos_of_sign_eq_one : ∀ {a : Int}, sign a = 1 → 0 < a
+  | (_ + 1 : Nat), _ => ofNat_lt.2 (Nat.succ_pos _)
+
+theorem neg_of_sign_eq_neg_one : ∀ {a : Int}, sign a = -1 → a < 0
+  | (_ + 1 : Nat), h => nomatch h
+  | 0, h => nomatch h
+  | -[_+1], _ => negSucc_lt_zero _
+
+theorem sign_eq_one_iff_pos (a : Int) : sign a = 1 ↔ 0 < a :=
+  ⟨pos_of_sign_eq_one, sign_eq_one_of_pos⟩
+
+theorem sign_eq_neg_one_iff_neg (a : Int) : sign a = -1 ↔ a < 0 :=
+  ⟨neg_of_sign_eq_neg_one, sign_eq_neg_one_of_neg⟩
+
+@[simp] theorem sign_eq_zero_iff_zero (a : Int) : sign a = 0 ↔ a = 0 :=
+  ⟨eq_zero_of_sign_eq_zero, fun h => by rw [h, sign_zero]⟩
+
+@[simp] theorem sign_sign : sign (sign x) = sign x := by
+  match x with
+  | 0 => rfl
+  | .ofNat (_ + 1) => rfl
+  | .negSucc _ => rfl
+
+@[simp] theorem sign_nonneg : 0 ≤ sign x ↔ 0 ≤ x := by
+  match x with
+  | 0 => rfl
+  | .ofNat (_ + 1) =>
+    simp (config := { decide := true }) only [sign, true_iff]
+    exact Int.le_add_one (ofNat_nonneg _)
+  | .negSucc _ => simp (config := { decide := true }) [sign]
+
+theorem mul_sign : ∀ i : Int, i * sign i = natAbs i
+  | succ _ => Int.mul_one _
+  | 0 => Int.mul_zero _
+  | -[_+1] => Int.mul_neg_one _
+
+/- ## natAbs -/
+
+theorem natAbs_ne_zero {a : Int} : a.natAbs ≠ 0 ↔ a ≠ 0 := not_congr Int.natAbs_eq_zero
+
+theorem natAbs_mul_self : ∀ {a : Int}, ↑(natAbs a * natAbs a) = a * a
+  | ofNat _ => rfl
+  | -[_+1]  => rfl
+
+theorem eq_nat_or_neg (a : Int) : ∃ n : Nat, a = n ∨ a = -↑n := ⟨_, natAbs_eq a⟩
+
+theorem natAbs_mul_natAbs_eq {a b : Int} {c : Nat}
+    (h : a * b = (c : Int)) : a.natAbs * b.natAbs = c := by rw [← natAbs_mul, h, natAbs]
+
+@[simp] theorem natAbs_mul_self' (a : Int) : (natAbs a * natAbs a : Int) = a * a := by
+  rw [← Int.ofNat_mul, natAbs_mul_self]
+
+theorem natAbs_eq_iff {a : Int} {n : Nat} : a.natAbs = n ↔ a = n ∨ a = -↑n := by
+  rw [← Int.natAbs_eq_natAbs_iff, Int.natAbs_ofNat]
+
+theorem natAbs_add_le (a b : Int) : natAbs (a + b) ≤ natAbs a + natAbs b := by
+  suffices ∀ a b : Nat, natAbs (subNatNat a b.succ) ≤ (a + b).succ by
+    match a, b with
+    | (a:Nat), (b:Nat) => rw [ofNat_add_ofNat, natAbs_ofNat]; apply Nat.le_refl
+    | (a:Nat), -[b+1]  => rw [natAbs_ofNat, natAbs_negSucc]; apply this
+    | -[a+1],  (b:Nat) =>
+      rw [natAbs_negSucc, natAbs_ofNat, Nat.succ_add, Nat.add_comm a b]; apply this
+    | -[a+1],  -[b+1]  => rw [natAbs_negSucc, succ_add]; apply Nat.le_refl
+  refine fun a b => subNatNat_elim a b.succ
+    (fun m n i => n = b.succ → natAbs i ≤ (m + b).succ) ?_
+    (fun i n (e : (n + i).succ = _) => ?_) rfl
+  · rintro i n rfl
+    rw [Nat.add_comm _ i, Nat.add_assoc]
+    exact Nat.le_add_right i (b.succ + b).succ
+  · apply succ_le_succ
+    rw [← succ.inj e, ← Nat.add_assoc, Nat.add_comm]
+    apply Nat.le_add_right
+
+theorem natAbs_sub_le (a b : Int) : natAbs (a - b) ≤ natAbs a + natAbs b := by
+  rw [← Int.natAbs_neg b]; apply natAbs_add_le
+
+theorem negSucc_eq' (m : Nat) : -[m+1] = -m - 1 := by simp only [negSucc_eq, Int.neg_add]; rfl
+
+theorem natAbs_lt_natAbs_of_nonneg_of_lt {a b : Int}
+    (w₁ : 0 ≤ a) (w₂ : a < b) : a.natAbs < b.natAbs :=
+  match a, b, eq_ofNat_of_zero_le w₁, eq_ofNat_of_zero_le (Int.le_trans w₁ (Int.le_of_lt w₂)) with
+  | _, _, ⟨_, rfl⟩, ⟨_, rfl⟩ => ofNat_lt.1 w₂
+
+theorem eq_natAbs_iff_mul_eq_zero : natAbs a = n ↔ (a - n) * (a + n) = 0 := by
+  rw [natAbs_eq_iff, Int.mul_eq_zero, ← Int.sub_neg, Int.sub_eq_zero, Int.sub_eq_zero]
+
+end Int

src/Init/Data/Int/Pow.lean

@@ -0,0 +1,44 @@
+/-
+Copyright (c) 2016 Jeremy Avigad. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Jeremy Avigad, Deniz Aydin, Floris van Doorn, Mario Carneiro
+-/
+prelude
+import Init.Data.Int.Lemmas
+
+namespace Int
+
+/-! # pow -/
+
+protected theorem pow_zero (b : Int) : b^0 = 1 := rfl
+
+protected theorem pow_succ (b : Int) (e : Nat) : b ^ (e+1) = (b ^ e) * b := rfl
+protected theorem pow_succ' (b : Int) (e : Nat) : b ^ (e+1) = b * (b ^ e) := by
+  rw [Int.mul_comm, Int.pow_succ]
+
+theorem pow_le_pow_of_le_left {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i
+  | 0      => Nat.le_refl _
+  | i + 1 => Nat.mul_le_mul (pow_le_pow_of_le_left h i) h
+
+theorem pow_le_pow_of_le_right {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j
+  | 0,      h =>
+    have : i = 0 := Nat.eq_zero_of_le_zero h
+    this.symm ▸ Nat.le_refl _
+  | j + 1, h =>
+    match Nat.le_or_eq_of_le_succ h with
+    | Or.inl h => show n^i ≤ n^j * n from
+      have : n^i * 1 ≤ n^j * n := Nat.mul_le_mul (pow_le_pow_of_le_right hx h) hx
+      Nat.mul_one (n^i) ▸ this
+    | Or.inr h =>
+      h.symm ▸ Nat.le_refl _
+
+theorem pos_pow_of_pos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m :=
+  pow_le_pow_of_le_right h (Nat.zero_le _)
+
+theorem natCast_pow (b n : Nat) : ((b^n : Nat) : Int) = (b : Int) ^ n := by
+  match n with
+  | 0 => rfl
+  | n + 1 =>
+    simp only [Nat.pow_succ, Int.pow_succ, natCast_mul, natCast_pow _ n]
+
+end Int

src/Init/Data/List/BasicAux.lean

@@ -5,9 +5,6 @@ Author: Leonardo de Moura
 -/
 prelude
 import Init.Data.Nat.Linear
-import Init.Data.Array.Basic
-import Init.Data.List.Basic
-import Init.Util
 
 universe u
 

src/Init/Data/List/Lemmas.lean

@@ -6,9 +6,8 @@ Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, M
 prelude
 import Init.Data.List.BasicAux
 import Init.Data.List.Control
-import Init.Data.Nat.Lemmas
 import Init.PropLemmas
-import Init.Control.Lawful
+import Init.Control.Lawful.Basic
 import Init.Hints
 
 namespace List

src/Init/Data/Nat.lean

@@ -17,3 +17,5 @@ import Init.Data.Nat.Linear
 import Init.Data.Nat.SOM
 import Init.Data.Nat.Lemmas
 import Init.Data.Nat.Mod
+import Init.Data.Nat.Lcm
+import Init.Data.Nat.Compare

src/Init/Data/Nat/Basic.lean

@@ -10,6 +10,29 @@ universe u
 
 namespace Nat
 
+/-- Compiled version of `Nat.rec` so that we can define `Nat.recAux` to be defeq to `Nat.rec`.
+This is working around the fact that the compiler does not currently support recursors. -/
+private def recCompiled {motive : Nat → Sort u} (zero : motive zero) (succ : (n : Nat) → motive n → motive (Nat.succ n)) : (t : Nat) → motive t
+  | .zero => zero
+  | .succ n => succ n (recCompiled zero succ n)
+
+@[csimp]
+private theorem rec_eq_recCompiled : @Nat.rec = @Nat.recCompiled :=
+  funext fun _ => funext fun _ => funext fun succ => funext fun t =>
+    Nat.recOn t rfl (fun n ih => congrArg (succ n) ih)
+
+/-- Recursor identical to `Nat.rec` but uses notations `0` for `Nat.zero` and `· + 1` for `Nat.succ`.
+Used as the default `Nat` eliminator by the `induction` tactic. -/
+@[elab_as_elim, induction_eliminator]
+protected abbrev recAux {motive : Nat → Sort u} (zero : motive 0) (succ : (n : Nat) → motive n → motive (n + 1)) (t : Nat) : motive t :=
+  Nat.rec zero succ t
+
+/-- Recursor identical to `Nat.casesOn` but uses notations `0` for `Nat.zero` and `· + 1` for `Nat.succ`.
+Used as the default `Nat` eliminator by the `cases` tactic. -/
+@[elab_as_elim, cases_eliminator]
+protected abbrev casesAuxOn {motive : Nat → Sort u} (t : Nat) (zero : motive 0) (succ : (n : Nat) → motive (n + 1)) : motive t :=
+  Nat.casesOn t zero succ
+
 /--
 `Nat.fold` evaluates `f` on the numbers up to `n` exclusive, in increasing order:
 * `Nat.fold f 3 init = init |> f 0 |> f 1 |> f 2`
@@ -125,9 +148,12 @@ theorem add_succ (n m : Nat) : n + succ m = succ (n + m) :=
 theorem add_one (n : Nat) : n + 1 = succ n :=
   rfl
 
-theorem succ_eq_add_one (n : Nat) : succ n = n + 1 :=
+@[simp] theorem succ_eq_add_one (n : Nat) : succ n = n + 1 :=
   rfl
 
+@[simp] theorem add_one_ne_zero (n : Nat) : n + 1 ≠ 0 := nofun
+@[simp] theorem zero_ne_add_one (n : Nat) : 0 ≠ n + 1 := nofun
+
 protected theorem add_comm : ∀ (n m : Nat), n + m = m + n
   | n, 0   => Eq.symm (Nat.zero_add n)
   | n, m+1 => by
@@ -209,6 +235,9 @@ protected theorem mul_assoc : ∀ (n m k : Nat), (n * m) * k = n * (m * k)
 protected theorem mul_left_comm (n m k : Nat) : n * (m * k) = m * (n * k) := by
   rw [← Nat.mul_assoc, Nat.mul_comm n m, Nat.mul_assoc]
 
+protected theorem mul_two (n) : n * 2 = n + n := by rw [Nat.mul_succ, Nat.mul_one]
+protected theorem two_mul (n) : 2 * n = n + n := by rw [Nat.succ_mul, Nat.one_mul]
+
 /-! # Inequalities -/
 
 attribute [simp] Nat.le_refl
@@ -224,7 +253,7 @@ theorem lt_succ_of_le {n m : Nat} : n ≤ m → n < succ m := succ_le_succ
   | zero      => exact rfl
   | succ m ih => apply congrArg pred ih
 
-theorem pred_le : ∀ (n : Nat), pred n ≤ n
+@[simp] theorem pred_le : ∀ (n : Nat), pred n ≤ n
   | zero   => Nat.le.refl
   | succ _ => le_succ _
 
@@ -257,7 +286,7 @@ theorem succ_sub_succ (n m : Nat) : succ n - succ m = n - m :=
 theorem sub_add_eq (a b c : Nat) : a - (b + c) = a - b - c := by
   induction c with
   | zero => simp
-  | succ c ih => simp [Nat.add_succ, Nat.sub_succ, ih]
+  | succ c ih => simp only [Nat.add_succ, Nat.sub_succ, ih]
 
 protected theorem lt_of_lt_of_le {n m k : Nat} : n < m → m ≤ k → n < k :=
   Nat.le_trans
@@ -298,7 +327,8 @@ theorem eq_zero_or_pos : ∀ (n : Nat), n = 0 ∨ n > 0
 protected theorem pos_of_ne_zero {n : Nat} : n ≠ 0 → 0 < n := (eq_zero_or_pos n).resolve_left
 
 theorem lt.base (n : Nat) : n < succ n := Nat.le_refl (succ n)
-theorem lt_succ_self (n : Nat) : n < succ n := lt.base n
+
+@[simp] theorem lt_succ_self (n : Nat) : n < succ n := lt.base n
 
 protected theorem le_total (m n : Nat) : m ≤ n ∨ n ≤ m :=
   match Nat.lt_or_ge m n with
@@ -337,6 +367,12 @@ theorem le_add_right : ∀ (n k : Nat), n ≤ n + k
 theorem le_add_left (n m : Nat): n ≤ m + n :=
   Nat.add_comm n m ▸ le_add_right n m
 
+protected theorem lt_add_left (c : Nat) (h : a < b) : a < c + b :=
+  Nat.lt_of_lt_of_le h (Nat.le_add_left ..)
+
+protected theorem lt_add_right (c : Nat) (h : a < b) : a < b + c :=
+  Nat.lt_of_lt_of_le h (Nat.le_add_right ..)
+
 theorem le.dest : ∀ {n m : Nat}, n ≤ m → Exists (fun k => n + k = m)
   | zero,   zero,   _ => ⟨0, rfl⟩
   | zero,   succ n, _ => ⟨succ n, Nat.add_comm 0 (succ n) ▸ rfl⟩
@@ -426,6 +462,9 @@ protected theorem add_lt_add_left {n m : Nat} (h : n < m) (k : Nat) : k + n < k
 protected theorem add_lt_add_right {n m : Nat} (h : n < m) (k : Nat) : n + k < m + k :=
   Nat.add_comm k m ▸ Nat.add_comm k n ▸ Nat.add_lt_add_left h k
 
+protected theorem lt_add_of_pos_right (h : 0 < k) : n < n + k :=
+  Nat.add_lt_add_left h n
+
 protected theorem zero_lt_one : 0 < (1:Nat) :=
   zero_lt_succ 0
 
@@ -451,6 +490,137 @@ protected theorem le_of_add_le_add_right {a b c : Nat} : a + b ≤ c + b → a
 protected theorem add_le_add_iff_right {n : Nat} : m + n ≤ k + n ↔ m ≤ k :=
   ⟨Nat.le_of_add_le_add_right, fun h => Nat.add_le_add_right h _⟩
 
+/-! ### le/lt -/
+
+protected theorem lt_asymm {a b : Nat} (h : a < b) : ¬ b < a := Nat.not_lt.2 (Nat.le_of_lt h)
+/-- Alias for `Nat.lt_asymm`. -/
+protected abbrev not_lt_of_gt := @Nat.lt_asymm
+/-- Alias for `Nat.lt_asymm`. -/
+protected abbrev not_lt_of_lt := @Nat.lt_asymm
+
+protected theorem lt_iff_le_not_le {m n : Nat} : m < n ↔ m ≤ n ∧ ¬ n ≤ m :=
+  ⟨fun h => ⟨Nat.le_of_lt h, Nat.not_le_of_gt h⟩, fun ⟨_, h⟩ => Nat.lt_of_not_ge h⟩
+/-- Alias for `Nat.lt_iff_le_not_le`. -/
+protected abbrev lt_iff_le_and_not_ge := @Nat.lt_iff_le_not_le
+
+protected theorem lt_iff_le_and_ne {m n : Nat} : m < n ↔ m ≤ n ∧ m ≠ n :=
+  ⟨fun h => ⟨Nat.le_of_lt h, Nat.ne_of_lt h⟩, fun h => Nat.lt_of_le_of_ne h.1 h.2⟩
+
+protected theorem ne_iff_lt_or_gt {a b : Nat} : a ≠ b ↔ a < b ∨ b < a :=
+  ⟨Nat.lt_or_gt_of_ne, fun | .inl h => Nat.ne_of_lt h | .inr h => Nat.ne_of_gt h⟩
+/-- Alias for `Nat.ne_iff_lt_or_gt`. -/
+protected abbrev lt_or_gt := @Nat.ne_iff_lt_or_gt
+
+/-- Alias for `Nat.le_total`. -/
+protected abbrev le_or_ge := @Nat.le_total
+/-- Alias for `Nat.le_total`. -/
+protected abbrev le_or_le := @Nat.le_total
+
+protected theorem eq_or_lt_of_not_lt {a b : Nat} (hnlt : ¬ a < b) : a = b ∨ b < a :=
+  (Nat.lt_trichotomy ..).resolve_left hnlt
+
+protected theorem lt_or_eq_of_le {n m : Nat} (h : n ≤ m) : n < m ∨ n = m :=
+  (Nat.lt_or_ge ..).imp_right (Nat.le_antisymm h)
+
+protected theorem le_iff_lt_or_eq {n m : Nat} : n ≤ m ↔ n < m ∨ n = m :=
+  ⟨Nat.lt_or_eq_of_le, fun | .inl h => Nat.le_of_lt h | .inr rfl => Nat.le_refl _⟩
+
+protected theorem lt_succ_iff : m < succ n ↔ m ≤ n := ⟨le_of_lt_succ, lt_succ_of_le⟩
+
+protected theorem lt_succ_iff_lt_or_eq : m < succ n ↔ m < n ∨ m = n :=
+  Nat.lt_succ_iff.trans Nat.le_iff_lt_or_eq
+
+protected theorem eq_of_lt_succ_of_not_lt (hmn : m < n + 1) (h : ¬ m < n) : m = n :=
+  (Nat.lt_succ_iff_lt_or_eq.1 hmn).resolve_left h
+
+protected theorem eq_of_le_of_lt_succ (h₁ : n ≤ m) (h₂ : m < n + 1) : m = n :=
+  Nat.le_antisymm (le_of_succ_le_succ h₂) h₁
+
+
+/-! ## zero/one/two -/
+
+theorem le_zero : i ≤ 0 ↔ i = 0 := ⟨Nat.eq_zero_of_le_zero, fun | rfl => Nat.le_refl _⟩
+
+/-- Alias for `Nat.zero_lt_one`. -/
+protected abbrev one_pos := @Nat.zero_lt_one
+
+protected theorem two_pos : 0 < 2 := Nat.zero_lt_succ _
+
+protected theorem ne_zero_iff_zero_lt : n ≠ 0 ↔ 0 < n := Nat.pos_iff_ne_zero.symm
+
+protected theorem zero_lt_two : 0 < 2 := Nat.zero_lt_succ _
+
+protected theorem one_lt_two : 1 < 2 := Nat.succ_lt_succ Nat.zero_lt_one
+
+protected theorem eq_zero_of_not_pos (h : ¬0 < n) : n = 0 :=
+  Nat.eq_zero_of_le_zero (Nat.not_lt.1 h)
+
+/-! ## succ/pred -/
+
+attribute [simp] zero_lt_succ
+
+theorem succ_ne_self (n) : succ n ≠ n := Nat.ne_of_gt (lt_succ_self n)
+
+theorem succ_le : succ n ≤ m ↔ n < m := .rfl
+
+theorem lt_succ : m < succ n ↔ m ≤ n := ⟨le_of_lt_succ, lt_succ_of_le⟩
+
+theorem lt_succ_of_lt (h : a < b) : a < succ b := le_succ_of_le h
+
+theorem succ_pred_eq_of_ne_zero : ∀ {n}, n ≠ 0 → succ (pred n) = n
+  | _+1, _ => rfl
+
+theorem eq_zero_or_eq_succ_pred : ∀ n, n = 0 ∨ n = succ (pred n)
+  | 0 => .inl rfl
+  | _+1 => .inr rfl
+
+theorem succ_inj' : succ a = succ b ↔ a = b := ⟨succ.inj, congrArg _⟩
+
+theorem succ_le_succ_iff : succ a ≤ succ b ↔ a ≤ b := ⟨le_of_succ_le_succ, succ_le_succ⟩
+
+theorem succ_lt_succ_iff : succ a < succ b ↔ a < b := ⟨lt_of_succ_lt_succ, succ_lt_succ⟩
+
+theorem pred_inj : ∀ {a b}, 0 < a → 0 < b → pred a = pred b → a = b
+  | _+1, _+1, _, _ => congrArg _
+
+theorem pred_ne_self : ∀ {a}, a ≠ 0 → pred a ≠ a
+  | _+1, _ => (succ_ne_self _).symm
+
+theorem pred_lt_self : ∀ {a}, 0 < a → pred a < a
+  | _+1, _ => lt_succ_self _
+
+theorem pred_lt_pred : ∀ {n m}, n ≠ 0 → n < m → pred n < pred m
+  | _+1, _+1, _, h => lt_of_succ_lt_succ h
+
+theorem pred_le_iff_le_succ : ∀ {n m}, pred n ≤ m ↔ n ≤ succ m
+  | 0, _ => ⟨fun _ => Nat.zero_le _, fun _ => Nat.zero_le _⟩
+  | _+1, _ => Nat.succ_le_succ_iff.symm
+
+theorem le_succ_of_pred_le : pred n ≤ m → n ≤ succ m := pred_le_iff_le_succ.1
+
+theorem pred_le_of_le_succ : n ≤ succ m → pred n ≤ m := pred_le_iff_le_succ.2
+
+theorem lt_pred_iff_succ_lt : ∀ {n m}, n < pred m ↔ succ n < m
+  | _, 0 => ⟨nofun, nofun⟩
+  | _, _+1 => Nat.succ_lt_succ_iff.symm
+
+theorem succ_lt_of_lt_pred : n < pred m → succ n < m := lt_pred_iff_succ_lt.1
+
+theorem lt_pred_of_succ_lt : succ n < m → n < pred m := lt_pred_iff_succ_lt.2
+
+theorem le_pred_iff_lt : ∀ {n m}, 0 < m → (n ≤ pred m ↔ n < m)
+  | 0, _+1, _ => ⟨fun _ => Nat.zero_lt_succ _, fun _ => Nat.zero_le _⟩
+  | _+1, _+1, _ => Nat.lt_pred_iff_succ_lt
+
+theorem le_pred_of_lt (h : n < m) : n ≤ pred m := (le_pred_iff_lt (Nat.zero_lt_of_lt h)).2 h
+
+theorem le_sub_one_of_lt : a < b → a ≤ b - 1 := Nat.le_pred_of_lt
+
+theorem lt_of_le_pred (h : 0 < m) : n ≤ pred m → n < m := (le_pred_iff_lt h).1
+
+theorem exists_eq_succ_of_ne_zero : ∀ {n}, n ≠ 0 → Exists fun k => n = succ k
+  | _+1, _ => ⟨_, rfl⟩
+
 /-! # Basic theorems for comparing numerals -/
 
 theorem ctor_eq_zero : Nat.zero = 0 :=
@@ -462,7 +632,7 @@ protected theorem one_ne_zero : 1 ≠ (0 : Nat) :=
 protected theorem zero_ne_one : 0 ≠ (1 : Nat) :=
   fun h => Nat.noConfusion h
 
-theorem succ_ne_zero (n : Nat) : succ n ≠ 0 :=
+@[simp] theorem succ_ne_zero (n : Nat) : succ n ≠ 0 :=
   fun h => Nat.noConfusion h
 
 /-! # mul + order -/
@@ -573,6 +743,11 @@ theorem succ_pred {a : Nat} (h : a ≠ 0) : a.pred.succ = a := by
 theorem succ_pred_eq_of_pos : ∀ {n}, 0 < n → succ (pred n) = n
   | _+1, _ => rfl
 
+theorem sub_one_add_one_eq_of_pos : ∀ {n}, 0 < n → (n - 1) + 1 = n
+  | _+1, _ => rfl
+
+@[simp] theorem pred_eq_sub_one : pred n = n - 1 := rfl
+
 /-! # sub theorems -/
 
 theorem add_sub_self_left (a b : Nat) : (a + b) - a = b := by
@@ -595,7 +770,7 @@ theorem zero_lt_sub_of_lt (h : i < a) : 0 < a - i := by
   | zero => contradiction
   | succ a ih =>
     match Nat.eq_or_lt_of_le h with
-    | Or.inl h => injection h with h; subst h; rw [←Nat.add_one, Nat.add_sub_self_left]; decide
+    | Or.inl h => injection h with h; subst h; rw [Nat.add_sub_self_left]; decide
     | Or.inr h =>
       have : 0 < a - i := ih (Nat.lt_of_succ_lt_succ h)
       exact Nat.lt_of_lt_of_le this (Nat.sub_le_succ_sub _ _)
@@ -609,7 +784,7 @@ theorem sub_succ_lt_self (a i : Nat) (h : i < a) : a - (i + 1) < a - i := by
 
 theorem sub_ne_zero_of_lt : {a b : Nat} → a < b → b - a ≠ 0
   | 0, 0, h      => absurd h (Nat.lt_irrefl 0)
-  | 0, succ b, _ => by simp
+  | 0, succ b, _ => by simp only [Nat.sub_zero, ne_eq, not_false_eq_true]
   | succ a, 0, h => absurd h (Nat.not_lt_zero a.succ)
   | succ a, succ b, h => by rw [Nat.succ_sub_succ]; exact sub_ne_zero_of_lt (Nat.lt_of_succ_lt_succ h)
 
@@ -627,7 +802,7 @@ theorem add_sub_of_le {a b : Nat} (h : a ≤ b) : a + (b - a) = b := by
 protected theorem add_sub_add_right (n k m : Nat) : (n + k) - (m + k) = n - m := by
   induction k with
   | zero => simp
-  | succ k ih => simp [add_succ, add_succ, succ_sub_succ, ih]
+  | succ k ih => simp [← Nat.add_assoc, ih]
 
 protected theorem add_sub_add_left (k n m : Nat) : (k + n) - (k + m) = n - m := by
   rw [Nat.add_comm k n, Nat.add_comm k m, Nat.add_sub_add_right]
@@ -740,7 +915,7 @@ protected theorem sub_pos_of_lt (h : m < n) : 0 < n - m :=
 protected theorem sub_sub (n m k : Nat) : n - m - k = n - (m + k) := by
   induction k with
   | zero => simp
-  | succ k ih => rw [Nat.add_succ, Nat.sub_succ, Nat.sub_succ, ih]
+  | succ k ih => rw [Nat.add_succ, Nat.sub_succ, Nat.add_succ, Nat.sub_succ, ih]
 
 protected theorem sub_le_sub_left (h : n ≤ m) (k : Nat) : k - m ≤ k - n :=
   match m, le.dest h with

src/Init/Data/Nat/Bitwise/Basic.lean

@@ -51,6 +51,26 @@ instance : Xor Nat := ⟨Nat.xor⟩
 instance : ShiftLeft Nat := ⟨Nat.shiftLeft⟩
 instance : ShiftRight Nat := ⟨Nat.shiftRight⟩
 
+theorem shiftLeft_eq (a b : Nat) : a <<< b = a * 2 ^ b :=
+  match b with
+  | 0 => (Nat.mul_one _).symm
+  | b+1 => (shiftLeft_eq _ b).trans <| by
+    simp [Nat.pow_succ, Nat.mul_assoc, Nat.mul_left_comm, Nat.mul_comm]
+
+@[simp] theorem shiftRight_zero : n >>> 0 = n := rfl
+
+theorem shiftRight_succ (m n) : m >>> (n + 1) = (m >>> n) / 2 := rfl
+
+theorem shiftRight_add (m n : Nat) : ∀ k, m >>> (n + k) = (m >>> n) >>> k
+  | 0 => rfl
+  | k + 1 => by simp [← Nat.add_assoc, shiftRight_add _ _ k, shiftRight_succ]
+
+theorem shiftRight_eq_div_pow (m : Nat) : ∀ n, m >>> n = m / 2 ^ n
+  | 0 => (Nat.div_one _).symm
+  | k + 1 => by
+    rw [shiftRight_add, shiftRight_eq_div_pow m k]
+    simp [Nat.div_div_eq_div_mul, ← Nat.pow_succ, shiftRight_succ]
+
 /-!
 ### testBit
 We define an operation for testing individual bits in the binary representation

src/Init/Data/Nat/Bitwise/Lemmas.lean

@@ -6,6 +6,7 @@ Authors: Joe Hendrix
 
 prelude
 import Init.Data.Bool
+import Init.Data.Int.Pow
 import Init.Data.Nat.Bitwise.Basic
 import Init.Data.Nat.Lemmas
 import Init.TacticsExtra
@@ -86,6 +87,11 @@ theorem testBit_to_div_mod {x : Nat} : testBit x i = decide (x / 2^i % 2 = 1) :=
   | succ i hyp =>
     simp [hyp, Nat.div_div_eq_div_mul, Nat.pow_succ']
 
+theorem toNat_testBit (x i : Nat) :
+    (x.testBit i).toNat = x / 2 ^ i % 2 := by
+  rw [Nat.testBit_to_div_mod]
+  rcases Nat.mod_two_eq_zero_or_one (x / 2^i) <;> simp_all
+
 theorem ne_zero_implies_bit_true {x : Nat} (xnz : x ≠ 0) : ∃ i, testBit x i := by
   induction x using div2Induction with
   | ind x hyp =>
@@ -328,7 +334,7 @@ private theorem eq_0_of_lt_one (x : Nat) : x < 1 ↔ x = 0 :=
       match x with
       | 0 => Eq.refl 0
       | _+1 => False.elim (not_lt_zero _ (Nat.lt_of_succ_lt_succ p)))
-    (fun p => by simp [p, Nat.zero_lt_succ])
+    (fun p => by simp [p])
 
 private theorem eq_0_of_lt (x : Nat) : x < 2^ 0 ↔ x = 0 := eq_0_of_lt_one x
 

src/Init/Data/Nat/Compare.lean

@@ -0,0 +1,57 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
+-/
+prelude
+import Init.Classical
+import Init.Data.Ord
+
+/-! # Basic lemmas about comparing natural numbers
+
+This file introduce some basic lemmas about compare as applied to natural
+numbers.
+-/
+namespace Nat
+
+theorem compare_def_lt (a b : Nat) :
+    compare a b = if a < b then .lt else if b < a then .gt else .eq := by
+  simp only [compare, compareOfLessAndEq]
+  split
+  · rfl
+  · next h =>
+    match Nat.lt_or_eq_of_le (Nat.not_lt.1 h) with
+    | .inl h => simp [h, Nat.ne_of_gt h]
+    | .inr rfl => simp
+
+theorem compare_def_le (a b : Nat) :
+    compare a b = if a ≤ b then if b ≤ a then .eq else .lt else .gt := by
+  rw [compare_def_lt]
+  split
+  · next hlt => simp [Nat.le_of_lt hlt, Nat.not_le.2 hlt]
+  · next hge =>
+    split
+    · next hgt => simp [Nat.le_of_lt hgt, Nat.not_le.2 hgt]
+    · next hle => simp [Nat.not_lt.1 hge, Nat.not_lt.1 hle]
+
+protected theorem compare_swap (a b : Nat) : (compare a b).swap = compare b a := by
+  simp only [compare_def_le]; (repeat' split) <;> try rfl
+  next h1 h2 => cases h1 (Nat.le_of_not_le h2)
+
+protected theorem compare_eq_eq {a b : Nat} : compare a b = .eq ↔ a = b := by
+  rw [compare_def_lt]; (repeat' split) <;> simp [Nat.ne_of_lt, Nat.ne_of_gt, *]
+  next hlt hgt => exact Nat.le_antisymm (Nat.not_lt.1 hgt) (Nat.not_lt.1 hlt)
+
+protected theorem compare_eq_lt {a b : Nat} : compare a b = .lt ↔ a < b := by
+  rw [compare_def_lt]; (repeat' split) <;> simp [*]
+
+protected theorem compare_eq_gt {a b : Nat} : compare a b = .gt ↔ b < a := by
+  rw [compare_def_lt]; (repeat' split) <;> simp [Nat.le_of_lt, *]
+
+protected theorem compare_ne_gt {a b : Nat} : compare a b ≠ .gt ↔ a ≤ b := by
+  rw [compare_def_le]; (repeat' split) <;> simp [*]
+
+protected theorem compare_ne_lt {a b : Nat} : compare a b ≠ .lt ↔ b ≤ a := by
+  rw [compare_def_le]; (repeat' split) <;> simp [Nat.le_of_not_le, *]
+
+end Nat

src/Init/Data/Nat/Div.lean

@@ -10,6 +10,13 @@ import Init.Data.Nat.Basic
 
 namespace Nat
 
+/--
+Divisibility of natural numbers. `a ∣ b` (typed as `\|`) says that
+there is some `c` such that `b = a * c`.
+-/
+instance : Dvd Nat where
+  dvd a b := Exists (fun c => b = a * c)
+
 theorem div_rec_lemma {x y : Nat} : 0 < y ∧ y ≤ x → x - y < x :=
   fun ⟨ypos, ylex⟩ => sub_lt (Nat.lt_of_lt_of_le ypos ylex) ypos
 
@@ -28,7 +35,7 @@ theorem div_eq (x y : Nat) : x / y = if 0 < y ∧ y ≤ x then (x - y) / y + 1 e
   rw [Nat.div]
   rfl
 
-theorem div.inductionOn.{u}
+def div.inductionOn.{u}
       {motive : Nat → Nat → Sort u}
       (x y : Nat)
       (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
@@ -95,7 +102,7 @@ protected theorem modCore_eq_mod (x y : Nat) : Nat.modCore x y = x % y := by
 theorem mod_eq (x y : Nat) : x % y = if 0 < y ∧ y ≤ x then (x - y) % y else x := by
   rw [←Nat.modCore_eq_mod, ←Nat.modCore_eq_mod, Nat.modCore]
 
-theorem mod.inductionOn.{u}
+def mod.inductionOn.{u}
       {motive : Nat → Nat → Sort u}
       (x y  : Nat)
       (ind  : ∀ x y, 0 < y ∧ y ≤ x → motive (x - y) y → motive x y)
@@ -198,13 +205,33 @@ theorem le_div_iff_mul_le (k0 : 0 < k) : x ≤ y / k ↔ x * k ≤ y := by
   induction y, k using mod.inductionOn generalizing x with
     (rw [div_eq]; simp [h]; cases x with | zero => simp [zero_le] | succ x => ?_)
   | base y k h =>
-    simp [not_succ_le_zero x, succ_mul, Nat.add_comm]
-    refine Nat.lt_of_lt_of_le ?_ (Nat.le_add_right ..)
+    simp only [add_one, succ_mul, false_iff, Nat.not_le]
+    refine Nat.lt_of_lt_of_le ?_ (Nat.le_add_left ..)
     exact Nat.not_le.1 fun h' => h ⟨k0, h'⟩
   | ind y k h IH =>
-    rw [← add_one, Nat.add_le_add_iff_right, IH k0, succ_mul,
+    rw [Nat.add_le_add_iff_right, IH k0, succ_mul,
         ← Nat.add_sub_cancel (x*k) k, Nat.sub_le_sub_iff_right h.2, Nat.add_sub_cancel]
 
+protected theorem div_div_eq_div_mul (m n k : Nat) : m / n / k = m / (n * k) := by
+  cases eq_zero_or_pos k with
+  | inl k0 => rw [k0, Nat.mul_zero, Nat.div_zero, Nat.div_zero] | inr kpos => ?_
+  cases eq_zero_or_pos n with
+  | inl n0 => rw [n0, Nat.zero_mul, Nat.div_zero, Nat.zero_div] | inr npos => ?_
+
+  apply Nat.le_antisymm
+
+  apply (le_div_iff_mul_le (Nat.mul_pos npos kpos)).2
+  rw [Nat.mul_comm n k, ← Nat.mul_assoc]
+  apply (le_div_iff_mul_le npos).1
+  apply (le_div_iff_mul_le kpos).1
+  (apply Nat.le_refl)
+
+  apply (le_div_iff_mul_le kpos).2
+  apply (le_div_iff_mul_le npos).2
+  rw [Nat.mul_assoc, Nat.mul_comm n k]
+  apply (le_div_iff_mul_le (Nat.mul_pos kpos npos)).1
+  apply Nat.le_refl
+
 theorem div_mul_le_self : ∀ (m n : Nat), m / n * n ≤ m
   | m, 0   => by simp
   | m, n+1 => (le_div_iff_mul_le (Nat.succ_pos _)).1 (Nat.le_refl _)
@@ -266,7 +293,7 @@ theorem sub_mul_div (x n p : Nat) (h₁ : n*p ≤ x) : (x - n*p) / n = x / n - p
         rw [mul_succ] at h₁
         exact h₁
       rw [sub_succ, ← IH h₂, div_eq_sub_div h₀ h₃]
-      simp [add_one, Nat.pred_succ, mul_succ, Nat.sub_sub]
+      simp [Nat.pred_succ, mul_succ, Nat.sub_sub]
 
 theorem mul_sub_div (x n p : Nat) (h₁ : x < n*p) : (n * p - succ x) / n = p - succ (x / n) := by
   have npos : 0 < n := (eq_zero_or_pos _).resolve_left fun n0 => by
@@ -307,4 +334,50 @@ theorem div_eq_of_lt (h₀ : a < b) : a / b = 0 := by
   intro h₁
   apply Nat.not_le_of_gt h₀ h₁.right
 
+protected theorem mul_div_cancel (m : Nat) {n : Nat} (H : 0 < n) : m * n / n = m := by
+  let t := add_mul_div_right 0 m H
+  rwa [Nat.zero_add, Nat.zero_div, Nat.zero_add] at t
+
+protected theorem mul_div_cancel_left (m : Nat) {n : Nat} (H : 0 < n) : n * m / n = m := by
+  rw [Nat.mul_comm, Nat.mul_div_cancel _ H]
+
+protected theorem div_le_of_le_mul {m n : Nat} : ∀ {k}, m ≤ k * n → m / k ≤ n
+  | 0, _ => by simp [Nat.div_zero, n.zero_le]
+  | succ k, h => by
+    suffices succ k * (m / succ k) ≤ succ k * n from
+      Nat.le_of_mul_le_mul_left this (zero_lt_succ _)
+    have h1 : succ k * (m / succ k) ≤ m % succ k + succ k * (m / succ k) := Nat.le_add_left _ _
+    have h2 : m % succ k + succ k * (m / succ k) = m := by rw [mod_add_div]
+    have h3 : m ≤ succ k * n := h
+    rw [← h2] at h3
+    exact Nat.le_trans h1 h3
+
+@[simp] theorem mul_div_right (n : Nat) {m : Nat} (H : 0 < m) : m * n / m = n := by
+  induction n <;> simp_all [mul_succ]
+
+@[simp] theorem mul_div_left (m : Nat) {n : Nat} (H : 0 < n) : m * n / n = m := by
+  rw [Nat.mul_comm, mul_div_right _ H]
+
+protected theorem div_self (H : 0 < n) : n / n = 1 := by
+  let t := add_div_right 0 H
+  rwa [Nat.zero_add, Nat.zero_div] at t
+
+protected theorem div_eq_of_eq_mul_left (H1 : 0 < n) (H2 : m = k * n) : m / n = k :=
+by rw [H2, Nat.mul_div_cancel _ H1]
+
+protected theorem div_eq_of_eq_mul_right (H1 : 0 < n) (H2 : m = n * k) : m / n = k :=
+by rw [H2, Nat.mul_div_cancel_left _ H1]
+
+protected theorem mul_div_mul_left {m : Nat} (n k : Nat) (H : 0 < m) :
+    m * n / (m * k) = n / k := by rw [← Nat.div_div_eq_div_mul, Nat.mul_div_cancel_left _ H]
+
+protected theorem mul_div_mul_right {m : Nat} (n k : Nat) (H : 0 < m) :
+    n * m / (k * m) = n / k := by rw [Nat.mul_comm, Nat.mul_comm k, Nat.mul_div_mul_left _ _ H]
+
+theorem mul_div_le (m n : Nat) : n * (m / n) ≤ m := by
+  match n, Nat.eq_zero_or_pos n with
+  | _, Or.inl rfl => rw [Nat.zero_mul]; exact m.zero_le
+  | n, Or.inr h => rw [Nat.mul_comm, ← Nat.le_div_iff_mul_le h]; exact Nat.le_refl _
+
+
 end Nat

src/Init/Data/Nat/Dvd.lean

@@ -5,16 +5,10 @@ Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
 -/
 prelude
 import Init.Data.Nat.Div
+import Init.Meta
 
 namespace Nat
 
-/--
-Divisibility of natural numbers. `a ∣ b` (typed as `\|`) says that
-there is some `c` such that `b = a * c`.
--/
-instance : Dvd Nat where
-  dvd a b := Exists (fun c => b = a * c)
-
 protected theorem dvd_refl (a : Nat) : a ∣ a := ⟨1, by simp⟩
 
 protected theorem dvd_zero (a : Nat) : a ∣ 0 := ⟨0, by simp⟩
@@ -97,4 +91,42 @@ protected theorem mul_div_cancel' {n m : Nat} (H : n ∣ m) : n * (m / n) = m :=
 protected theorem div_mul_cancel {n m : Nat} (H : n ∣ m) : m / n * n = m := by
   rw [Nat.mul_comm, Nat.mul_div_cancel' H]
 
+@[simp] theorem mod_mod_of_dvd (a : Nat) (h : c ∣ b) : a % b % c = a % c := by
+  rw (config := {occs := .pos [2]}) [← mod_add_div a b]
+  have ⟨x, h⟩ := h
+  subst h
+  rw [Nat.mul_assoc, add_mul_mod_self_left]
+
+protected theorem dvd_of_mul_dvd_mul_left
+    (kpos : 0 < k) (H : k * m ∣ k * n) : m ∣ n := by
+  let ⟨l, H⟩ := H
+  rw [Nat.mul_assoc] at H
+  exact ⟨_, Nat.eq_of_mul_eq_mul_left kpos H⟩
+
+protected theorem dvd_of_mul_dvd_mul_right (kpos : 0 < k) (H : m * k ∣ n * k) : m ∣ n := by
+  rw [Nat.mul_comm m k, Nat.mul_comm n k] at H; exact Nat.dvd_of_mul_dvd_mul_left kpos H
+
+theorem dvd_sub {k m n : Nat} (H : n ≤ m) (h₁ : k ∣ m) (h₂ : k ∣ n) : k ∣ m - n :=
+  (Nat.dvd_add_iff_left h₂).2 <| by rwa [Nat.sub_add_cancel H]
+
+protected theorem mul_dvd_mul {a b c d : Nat} : a ∣ b → c ∣ d → a * c ∣ b * d
+  | ⟨e, he⟩, ⟨f, hf⟩ =>
+    ⟨e * f, by simp [he, hf, Nat.mul_assoc, Nat.mul_left_comm, Nat.mul_comm]⟩
+
+protected theorem mul_dvd_mul_left (a : Nat) (h : b ∣ c) : a * b ∣ a * c :=
+  Nat.mul_dvd_mul (Nat.dvd_refl a) h
+
+protected theorem mul_dvd_mul_right (h: a ∣ b) (c : Nat) : a * c ∣ b * c :=
+  Nat.mul_dvd_mul h (Nat.dvd_refl c)
+
+@[simp] theorem dvd_one {n : Nat} : n ∣ 1 ↔ n = 1 :=
+  ⟨eq_one_of_dvd_one, fun h => h.symm ▸ Nat.dvd_refl _⟩
+
+protected theorem mul_div_assoc (m : Nat) (H : k ∣ n) : m * n / k = m * (n / k) := by
+  match Nat.eq_zero_or_pos k with
+  | .inl h0 => rw [h0, Nat.div_zero, Nat.div_zero, Nat.mul_zero]
+  | .inr hpos =>
+    have h1 : m * n / k = m * (n / k * k) / k := by rw [Nat.div_mul_cancel H]
+    rw [h1, ← Nat.mul_assoc, Nat.mul_div_cancel _ hpos]
+
 end Nat

src/Init/Data/Nat/Gcd.lean

@@ -1,10 +1,12 @@
 /-
 Copyright (c) 2021 Microsoft Corporation. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Leonardo de Moura
+Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro
 -/
 prelude
 import Init.Data.Nat.Dvd
+import Init.NotationExtra
+import Init.RCases
 
 namespace Nat
 
@@ -14,8 +16,8 @@ def gcd (m n : @& Nat) : Nat :=
     n
   else
     gcd (n % m) m
-termination_by m
-decreasing_by simp_wf; apply mod_lt _ (zero_lt_of_ne_zero _); assumption
+  termination_by m
+  decreasing_by simp_wf; apply mod_lt _ (zero_lt_of_ne_zero _); assumption
 
 @[simp] theorem gcd_zero_left (y : Nat) : gcd 0 y = y :=
   rfl
@@ -69,4 +71,166 @@ theorem dvd_gcd : k ∣ m → k ∣ n → k ∣ gcd m n := by
   | H0 n => rw [gcd_zero_left]; exact kn
   | H1 n m _ IH => rw [gcd_rec]; exact IH ((dvd_mod_iff km).2 kn) km
 
+theorem dvd_gcd_iff : k ∣ gcd m n ↔ k ∣ m ∧ k ∣ n :=
+  ⟨fun h => let ⟨h₁, h₂⟩ := gcd_dvd m n; ⟨Nat.dvd_trans h h₁, Nat.dvd_trans h h₂⟩,
+   fun ⟨h₁, h₂⟩ => dvd_gcd h₁ h₂⟩
+
+theorem gcd_comm (m n : Nat) : gcd m n = gcd n m :=
+  Nat.dvd_antisymm
+    (dvd_gcd (gcd_dvd_right m n) (gcd_dvd_left m n))
+    (dvd_gcd (gcd_dvd_right n m) (gcd_dvd_left n m))
+
+theorem gcd_eq_left_iff_dvd : m ∣ n ↔ gcd m n = m :=
+  ⟨fun h => by rw [gcd_rec, mod_eq_zero_of_dvd h, gcd_zero_left],
+   fun h => h ▸ gcd_dvd_right m n⟩
+
+theorem gcd_eq_right_iff_dvd : m ∣ n ↔ gcd n m = m := by
+  rw [gcd_comm]; exact gcd_eq_left_iff_dvd
+
+theorem gcd_assoc (m n k : Nat) : gcd (gcd m n) k = gcd m (gcd n k) :=
+  Nat.dvd_antisymm
+    (dvd_gcd
+      (Nat.dvd_trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_left m n))
+      (dvd_gcd (Nat.dvd_trans (gcd_dvd_left (gcd m n) k) (gcd_dvd_right m n))
+        (gcd_dvd_right (gcd m n) k)))
+    (dvd_gcd
+      (dvd_gcd (gcd_dvd_left m (gcd n k))
+        (Nat.dvd_trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_left n k)))
+      (Nat.dvd_trans (gcd_dvd_right m (gcd n k)) (gcd_dvd_right n k)))
+
+@[simp] theorem gcd_one_right (n : Nat) : gcd n 1 = 1 := (gcd_comm n 1).trans (gcd_one_left n)
+
+theorem gcd_mul_left (m n k : Nat) : gcd (m * n) (m * k) = m * gcd n k := by
+  induction n, k using gcd.induction with
+  | H0 k => simp
+  | H1 n k _ IH => rwa [← mul_mod_mul_left, ← gcd_rec, ← gcd_rec] at IH
+
+theorem gcd_mul_right (m n k : Nat) : gcd (m * n) (k * n) = gcd m k * n := by
+  rw [Nat.mul_comm m n, Nat.mul_comm k n, Nat.mul_comm (gcd m k) n, gcd_mul_left]
+
+theorem gcd_pos_of_pos_left {m : Nat} (n : Nat) (mpos : 0 < m) : 0 < gcd m n :=
+  pos_of_dvd_of_pos (gcd_dvd_left m n) mpos
+
+theorem gcd_pos_of_pos_right (m : Nat) {n : Nat} (npos : 0 < n) : 0 < gcd m n :=
+  pos_of_dvd_of_pos (gcd_dvd_right m n) npos
+
+theorem div_gcd_pos_of_pos_left (b : Nat) (h : 0 < a) : 0 < a / a.gcd b :=
+  (Nat.le_div_iff_mul_le <| Nat.gcd_pos_of_pos_left _ h).2 (Nat.one_mul _ ▸ Nat.gcd_le_left _ h)
+
+theorem div_gcd_pos_of_pos_right (a : Nat) (h : 0 < b) : 0 < b / a.gcd b :=
+  (Nat.le_div_iff_mul_le <| Nat.gcd_pos_of_pos_right _ h).2 (Nat.one_mul _ ▸ Nat.gcd_le_right _ h)
+
+theorem eq_zero_of_gcd_eq_zero_left {m n : Nat} (H : gcd m n = 0) : m = 0 :=
+  match eq_zero_or_pos m with
+  | .inl H0 => H0
+  | .inr H1 => absurd (Eq.symm H) (ne_of_lt (gcd_pos_of_pos_left _ H1))
+
+theorem eq_zero_of_gcd_eq_zero_right {m n : Nat} (H : gcd m n = 0) : n = 0 := by
+  rw [gcd_comm] at H
+  exact eq_zero_of_gcd_eq_zero_left H
+
+theorem gcd_ne_zero_left : m ≠ 0 → gcd m n ≠ 0 := mt eq_zero_of_gcd_eq_zero_left
+
+theorem gcd_ne_zero_right : n ≠ 0 → gcd m n ≠ 0 := mt eq_zero_of_gcd_eq_zero_right
+
+theorem gcd_div {m n k : Nat} (H1 : k ∣ m) (H2 : k ∣ n) :
+    gcd (m / k) (n / k) = gcd m n / k :=
+  match eq_zero_or_pos k with
+  | .inl H0 => by simp [H0]
+  | .inr H3 => by
+    apply Nat.eq_of_mul_eq_mul_right H3
+    rw [Nat.div_mul_cancel (dvd_gcd H1 H2), ← gcd_mul_right,
+        Nat.div_mul_cancel H1, Nat.div_mul_cancel H2]
+
+theorem gcd_dvd_gcd_of_dvd_left {m k : Nat} (n : Nat) (H : m ∣ k) : gcd m n ∣ gcd k n :=
+  dvd_gcd (Nat.dvd_trans (gcd_dvd_left m n) H) (gcd_dvd_right m n)
+
+theorem gcd_dvd_gcd_of_dvd_right {m k : Nat} (n : Nat) (H : m ∣ k) : gcd n m ∣ gcd n k :=
+  dvd_gcd (gcd_dvd_left n m) (Nat.dvd_trans (gcd_dvd_right n m) H)
+
+theorem gcd_dvd_gcd_mul_left (m n k : Nat) : gcd m n ∣ gcd (k * m) n :=
+  gcd_dvd_gcd_of_dvd_left _ (Nat.dvd_mul_left _ _)
+
+theorem gcd_dvd_gcd_mul_right (m n k : Nat) : gcd m n ∣ gcd (m * k) n :=
+  gcd_dvd_gcd_of_dvd_left _ (Nat.dvd_mul_right _ _)
+
+theorem gcd_dvd_gcd_mul_left_right (m n k : Nat) : gcd m n ∣ gcd m (k * n) :=
+  gcd_dvd_gcd_of_dvd_right _ (Nat.dvd_mul_left _ _)
+
+theorem gcd_dvd_gcd_mul_right_right (m n k : Nat) : gcd m n ∣ gcd m (n * k) :=
+  gcd_dvd_gcd_of_dvd_right _ (Nat.dvd_mul_right _ _)
+
+theorem gcd_eq_left {m n : Nat} (H : m ∣ n) : gcd m n = m :=
+  Nat.dvd_antisymm (gcd_dvd_left _ _) (dvd_gcd (Nat.dvd_refl _) H)
+
+theorem gcd_eq_right {m n : Nat} (H : n ∣ m) : gcd m n = n := by
+  rw [gcd_comm, gcd_eq_left H]
+
+@[simp] theorem gcd_mul_left_left (m n : Nat) : gcd (m * n) n = n :=
+  Nat.dvd_antisymm (gcd_dvd_right _ _) (dvd_gcd (Nat.dvd_mul_left _ _) (Nat.dvd_refl _))
+
+@[simp] theorem gcd_mul_left_right (m n : Nat) : gcd n (m * n) = n := by
+  rw [gcd_comm, gcd_mul_left_left]
+
+@[simp] theorem gcd_mul_right_left (m n : Nat) : gcd (n * m) n = n := by
+  rw [Nat.mul_comm, gcd_mul_left_left]
+
+@[simp] theorem gcd_mul_right_right (m n : Nat) : gcd n (n * m) = n := by
+  rw [gcd_comm, gcd_mul_right_left]
+
+@[simp] theorem gcd_gcd_self_right_left (m n : Nat) : gcd m (gcd m n) = gcd m n :=
+  Nat.dvd_antisymm (gcd_dvd_right _ _) (dvd_gcd (gcd_dvd_left _ _) (Nat.dvd_refl _))
+
+@[simp] theorem gcd_gcd_self_right_right (m n : Nat) : gcd m (gcd n m) = gcd n m := by
+  rw [gcd_comm n m, gcd_gcd_self_right_left]
+
+@[simp] theorem gcd_gcd_self_left_right (m n : Nat) : gcd (gcd n m) m = gcd n m := by
+  rw [gcd_comm, gcd_gcd_self_right_right]
+
+@[simp] theorem gcd_gcd_self_left_left (m n : Nat) : gcd (gcd m n) m = gcd m n := by
+  rw [gcd_comm m n, gcd_gcd_self_left_right]
+
+theorem gcd_add_mul_self (m n k : Nat) : gcd m (n + k * m) = gcd m n := by
+  simp [gcd_rec m (n + k * m), gcd_rec m n]
+
+theorem gcd_eq_zero_iff {i j : Nat} : gcd i j = 0 ↔ i = 0 ∧ j = 0 :=
+  ⟨fun h => ⟨eq_zero_of_gcd_eq_zero_left h, eq_zero_of_gcd_eq_zero_right h⟩,
+   fun h => by simp [h]⟩
+
+/-- Characterization of the value of `Nat.gcd`. -/
+theorem gcd_eq_iff (a b : Nat) :
+    gcd a b = g ↔ g ∣ a ∧ g ∣ b ∧ (∀ c, c ∣ a → c ∣ b → c ∣ g) := by
+  constructor
+  · rintro rfl
+    exact ⟨gcd_dvd_left _ _, gcd_dvd_right _ _, fun _ => Nat.dvd_gcd⟩
+  · rintro ⟨ha, hb, hc⟩
+    apply Nat.dvd_antisymm
+    · apply hc
+      · exact gcd_dvd_left a b
+      · exact gcd_dvd_right a b
+    · exact Nat.dvd_gcd ha hb
+
+/-- Represent a divisor of `m * n` as a product of a divisor of `m` and a divisor of `n`. -/
+def prod_dvd_and_dvd_of_dvd_prod {k m n : Nat} (H : k ∣ m * n) :
+    {d : {m' // m' ∣ m} × {n' // n' ∣ n} // k = d.1.val * d.2.val} :=
+  if h0 : gcd k m = 0 then
+    ⟨⟨⟨0, eq_zero_of_gcd_eq_zero_right h0 ▸ Nat.dvd_refl 0⟩,
+      ⟨n, Nat.dvd_refl n⟩⟩,
+      eq_zero_of_gcd_eq_zero_left h0 ▸ (Nat.zero_mul n).symm⟩
+  else by
+    have hd : gcd k m * (k / gcd k m) = k := Nat.mul_div_cancel' (gcd_dvd_left k m)
+    refine ⟨⟨⟨gcd k m, gcd_dvd_right k m⟩, ⟨k / gcd k m, ?_⟩⟩, hd.symm⟩
+    apply Nat.dvd_of_mul_dvd_mul_left (Nat.pos_of_ne_zero h0)
+    rw [hd, ← gcd_mul_right]
+    exact Nat.dvd_gcd (Nat.dvd_mul_right _ _) H
+
+theorem gcd_mul_dvd_mul_gcd (k m n : Nat) : gcd k (m * n) ∣ gcd k m * gcd k n := by
+  let ⟨⟨⟨m', hm'⟩, ⟨n', hn'⟩⟩, (h : gcd k (m * n) = m' * n')⟩ :=
+    prod_dvd_and_dvd_of_dvd_prod <| gcd_dvd_right k (m * n)
+  rw [h]
+  have h' : m' * n' ∣ k := h ▸ gcd_dvd_left ..
+  exact Nat.mul_dvd_mul
+    (dvd_gcd (Nat.dvd_trans (Nat.dvd_mul_right m' n') h') hm')
+    (dvd_gcd (Nat.dvd_trans (Nat.dvd_mul_left n' m') h') hn')
+
 end Nat

src/Init/Data/Nat/Lcm.lean

@@ -0,0 +1,66 @@
+/-
+Copyright (c) 2014 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro
+-/
+prelude
+import Init.Data.Nat.Gcd
+import Init.Data.Nat.Lemmas
+
+namespace Nat
+
+/-- The least common multiple of `m` and `n`, defined using `gcd`. -/
+def lcm (m n : Nat) : Nat := m * n / gcd m n
+
+theorem lcm_comm (m n : Nat) : lcm m n = lcm n m := by
+  rw [lcm, lcm, Nat.mul_comm n m, gcd_comm n m]
+
+@[simp] theorem lcm_zero_left (m : Nat) : lcm 0 m = 0 := by simp [lcm]
+
+@[simp] theorem lcm_zero_right (m : Nat) : lcm m 0 = 0 := by simp [lcm]
+
+@[simp] theorem lcm_one_left (m : Nat) : lcm 1 m = m := by simp [lcm]
+
+@[simp] theorem lcm_one_right (m : Nat) : lcm m 1 = m := by simp [lcm]
+
+@[simp] theorem lcm_self (m : Nat) : lcm m m = m := by
+  match eq_zero_or_pos m with
+  | .inl h => rw [h, lcm_zero_left]
+  | .inr h => simp [lcm, Nat.mul_div_cancel _ h]
+
+theorem dvd_lcm_left (m n : Nat) : m ∣ lcm m n :=
+  ⟨n / gcd m n, by rw [← Nat.mul_div_assoc m (Nat.gcd_dvd_right m n)]; rfl⟩
+
+theorem dvd_lcm_right (m n : Nat) : n ∣ lcm m n := lcm_comm n m ▸ dvd_lcm_left n m
+
+theorem gcd_mul_lcm (m n : Nat) : gcd m n * lcm m n = m * n := by
+  rw [lcm, Nat.mul_div_cancel' (Nat.dvd_trans (gcd_dvd_left m n) (Nat.dvd_mul_right m n))]
+
+theorem lcm_dvd {m n k : Nat} (H1 : m ∣ k) (H2 : n ∣ k) : lcm m n ∣ k := by
+  match eq_zero_or_pos k with
+  | .inl h => rw [h]; exact Nat.dvd_zero _
+  | .inr kpos =>
+    apply Nat.dvd_of_mul_dvd_mul_left (gcd_pos_of_pos_left n (pos_of_dvd_of_pos H1 kpos))
+    rw [gcd_mul_lcm, ← gcd_mul_right, Nat.mul_comm n k]
+    exact dvd_gcd (Nat.mul_dvd_mul_left _ H2) (Nat.mul_dvd_mul_right H1 _)
+
+theorem lcm_assoc (m n k : Nat) : lcm (lcm m n) k = lcm m (lcm n k) :=
+Nat.dvd_antisymm
+  (lcm_dvd
+    (lcm_dvd (dvd_lcm_left m (lcm n k))
+      (Nat.dvd_trans (dvd_lcm_left n k) (dvd_lcm_right m (lcm n k))))
+    (Nat.dvd_trans (dvd_lcm_right n k) (dvd_lcm_right m (lcm n k))))
+  (lcm_dvd
+    (Nat.dvd_trans (dvd_lcm_left m n) (dvd_lcm_left (lcm m n) k))
+    (lcm_dvd (Nat.dvd_trans (dvd_lcm_right m n) (dvd_lcm_left (lcm m n) k))
+      (dvd_lcm_right (lcm m n) k)))
+
+theorem lcm_ne_zero (hm : m ≠ 0) (hn : n ≠ 0) : lcm m n ≠ 0 := by
+  intro h
+  have h1 := gcd_mul_lcm m n
+  rw [h, Nat.mul_zero] at h1
+  match mul_eq_zero.1 h1.symm with
+  | .inl hm1 => exact hm hm1
+  | .inr hn1 => exact hn hn1
+
+end Nat

src/Init/Data/Nat/Lemmas.lean

@@ -4,10 +4,10 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
 -/
 prelude
-import Init.Data.Nat.Dvd
 import Init.Data.Nat.MinMax
 import Init.Data.Nat.Log2
 import Init.Data.Nat.Power2
+import Init.Omega
 
 /-! # Basic lemmas about natural numbers
 
@@ -19,131 +19,6 @@ and later these lemmas should be organised into other files more systematically.
 -/
 
 namespace Nat
-
-/-! ### le/lt -/
-
-protected theorem lt_asymm {a b : Nat} (h : a < b) : ¬ b < a := Nat.not_lt.2 (Nat.le_of_lt h)
-protected abbrev not_lt_of_gt := @Nat.lt_asymm
-protected abbrev not_lt_of_lt := @Nat.lt_asymm
-
-protected theorem lt_iff_le_not_le {m n : Nat} : m < n ↔ m ≤ n ∧ ¬ n ≤ m :=
-  ⟨fun h => ⟨Nat.le_of_lt h, Nat.not_le_of_gt h⟩, fun ⟨_, h⟩ => Nat.lt_of_not_ge h⟩
-protected abbrev lt_iff_le_and_not_ge := @Nat.lt_iff_le_not_le
-
-protected theorem lt_iff_le_and_ne {m n : Nat} : m < n ↔ m ≤ n ∧ m ≠ n :=
-  ⟨fun h => ⟨Nat.le_of_lt h, Nat.ne_of_lt h⟩, fun h => Nat.lt_of_le_of_ne h.1 h.2⟩
-
-protected theorem ne_iff_lt_or_gt {a b : Nat} : a ≠ b ↔ a < b ∨ b < a :=
-  ⟨Nat.lt_or_gt_of_ne, fun | .inl h => Nat.ne_of_lt h | .inr h => Nat.ne_of_gt h⟩
-protected abbrev lt_or_gt := @Nat.ne_iff_lt_or_gt
-
-protected abbrev le_or_ge := @Nat.le_total
-protected abbrev le_or_le := @Nat.le_total
-
-protected theorem eq_or_lt_of_not_lt {a b : Nat} (hnlt : ¬ a < b) : a = b ∨ b < a :=
-  (Nat.lt_trichotomy ..).resolve_left hnlt
-
-protected theorem lt_or_eq_of_le {n m : Nat} (h : n ≤ m) : n < m ∨ n = m :=
-  (Nat.lt_or_ge ..).imp_right (Nat.le_antisymm h)
-
-protected theorem le_iff_lt_or_eq {n m : Nat} : n ≤ m ↔ n < m ∨ n = m :=
-  ⟨Nat.lt_or_eq_of_le, fun | .inl h => Nat.le_of_lt h | .inr rfl => Nat.le_refl _⟩
-
-protected theorem lt_succ_iff : m < succ n ↔ m ≤ n := ⟨le_of_lt_succ, lt_succ_of_le⟩
-
-protected theorem lt_succ_iff_lt_or_eq : m < succ n ↔ m < n ∨ m = n :=
-  Nat.lt_succ_iff.trans Nat.le_iff_lt_or_eq
-
-protected theorem eq_of_lt_succ_of_not_lt (hmn : m < n + 1) (h : ¬ m < n) : m = n :=
-  (Nat.lt_succ_iff_lt_or_eq.1 hmn).resolve_left h
-
-protected theorem eq_of_le_of_lt_succ (h₁ : n ≤ m) (h₂ : m < n + 1) : m = n :=
-  Nat.le_antisymm (le_of_succ_le_succ h₂) h₁
-
-
-/-! ## zero/one/two -/
-
-theorem le_zero : i ≤ 0 ↔ i = 0 := ⟨Nat.eq_zero_of_le_zero, fun | rfl => Nat.le_refl _⟩
-
-protected abbrev one_pos := @Nat.zero_lt_one
-
-protected theorem two_pos : 0 < 2 := Nat.zero_lt_succ _
-
-theorem add_one_ne_zero (n) : n + 1 ≠ 0 := succ_ne_zero _
-
-protected theorem ne_zero_iff_zero_lt : n ≠ 0 ↔ 0 < n := Nat.pos_iff_ne_zero.symm
-
-protected theorem zero_lt_two : 0 < 2 := Nat.zero_lt_succ _
-
-protected theorem one_lt_two : 1 < 2 := Nat.succ_lt_succ Nat.zero_lt_one
-
-protected theorem eq_zero_of_not_pos (h : ¬0 < n) : n = 0 :=
-  Nat.eq_zero_of_le_zero (Nat.not_lt.1 h)
-
-/-! ## succ/pred -/
-
-attribute [simp] succ_ne_zero zero_lt_succ lt_succ_self Nat.pred_zero Nat.pred_succ Nat.pred_le
-
-theorem succ_ne_self (n) : succ n ≠ n := Nat.ne_of_gt (lt_succ_self n)
-
-theorem succ_le : succ n ≤ m ↔ n < m := .rfl
-
-theorem lt_succ : m < succ n ↔ m ≤ n := ⟨le_of_lt_succ, lt_succ_of_le⟩
-
-theorem lt_succ_of_lt (h : a < b) : a < succ b := le_succ_of_le h
-
-theorem succ_pred_eq_of_ne_zero : ∀ {n}, n ≠ 0 → succ (pred n) = n
-  | _+1, _ => rfl
-
-theorem eq_zero_or_eq_succ_pred : ∀ n, n = 0 ∨ n = succ (pred n)
-  | 0 => .inl rfl
-  | _+1 => .inr rfl
-
-theorem succ_inj' : succ a = succ b ↔ a = b := ⟨succ.inj, congrArg _⟩
-
-theorem succ_le_succ_iff : succ a ≤ succ b ↔ a ≤ b := ⟨le_of_succ_le_succ, succ_le_succ⟩
-
-theorem succ_lt_succ_iff : succ a < succ b ↔ a < b := ⟨lt_of_succ_lt_succ, succ_lt_succ⟩
-
-theorem pred_inj : ∀ {a b}, 0 < a → 0 < b → pred a = pred b → a = b
-  | _+1, _+1, _, _ => congrArg _
-
-theorem pred_ne_self : ∀ {a}, a ≠ 0 → pred a ≠ a
-  | _+1, _ => (succ_ne_self _).symm
-
-theorem pred_lt_self : ∀ {a}, 0 < a → pred a < a
-  | _+1, _ => lt_succ_self _
-
-theorem pred_lt_pred : ∀ {n m}, n ≠ 0 → n < m → pred n < pred m
-  | _+1, _+1, _, h => lt_of_succ_lt_succ h
-
-theorem pred_le_iff_le_succ : ∀ {n m}, pred n ≤ m ↔ n ≤ succ m
-  | 0, _ => ⟨fun _ => Nat.zero_le _, fun _ => Nat.zero_le _⟩
-  | _+1, _ => Nat.succ_le_succ_iff.symm
-
-theorem le_succ_of_pred_le : pred n ≤ m → n ≤ succ m := pred_le_iff_le_succ.1
-
-theorem pred_le_of_le_succ : n ≤ succ m → pred n ≤ m := pred_le_iff_le_succ.2
-
-theorem lt_pred_iff_succ_lt : ∀ {n m}, n < pred m ↔ succ n < m
-  | _, 0 => ⟨nofun, nofun⟩
-  | _, _+1 => Nat.succ_lt_succ_iff.symm
-
-theorem succ_lt_of_lt_pred : n < pred m → succ n < m := lt_pred_iff_succ_lt.1
-
-theorem lt_pred_of_succ_lt : succ n < m → n < pred m := lt_pred_iff_succ_lt.2
-
-theorem le_pred_iff_lt : ∀ {n m}, 0 < m → (n ≤ pred m ↔ n < m)
-  | 0, _+1, _ => ⟨fun _ => Nat.zero_lt_succ _, fun _ => Nat.zero_le _⟩
-  | _+1, _+1, _ => Nat.lt_pred_iff_succ_lt
-
-theorem lt_of_le_pred (h : 0 < m) : n ≤ pred m → n < m := (le_pred_iff_lt h).1
-
-theorem le_pred_of_lt (h : n < m) : n ≤ pred m := (le_pred_iff_lt (Nat.zero_lt_of_lt h)).2 h
-
-theorem exists_eq_succ_of_ne_zero : ∀ {n}, n ≠ 0 → ∃ k, n = succ k
-  | _+1, _ => ⟨_, rfl⟩
-
 /-! ## add -/
 
 protected theorem add_add_add_comm (a b c d : Nat) : (a + b) + (c + d) = (a + c) + (b + d) := by
@@ -191,15 +66,6 @@ protected theorem add_lt_add_of_lt_of_le {a b c d : Nat} (hlt : a < b) (hle : c
     a + c < b + d :=
   Nat.lt_of_le_of_lt (Nat.add_le_add_left hle _) (Nat.add_lt_add_right hlt _)
 
-protected theorem lt_add_left (c : Nat) (h : a < b) : a < c + b :=
-  Nat.lt_of_lt_of_le h (Nat.le_add_left ..)
-
-protected theorem lt_add_right (c : Nat) (h : a < b) : a < b + c :=
-  Nat.lt_of_lt_of_le h (Nat.le_add_right ..)
-
-protected theorem lt_add_of_pos_right (h : 0 < k) : n < n + k :=
-  Nat.add_lt_add_left h n
-
 protected theorem lt_add_of_pos_left : 0 < k → n < k + n := by
   rw [Nat.add_comm]; exact Nat.lt_add_of_pos_right
 
@@ -309,8 +175,6 @@ theorem add_lt_of_lt_sub' {a b c : Nat} : b < c - a → a + b < c := by
 protected theorem sub_add_lt_sub (h₁ : m + k ≤ n) (h₂ : 0 < k) : n - (m + k) < n - m := by
   rw [← Nat.sub_sub]; exact Nat.sub_lt_of_pos_le h₂ (Nat.le_sub_of_add_le' h₁)
 
-theorem le_sub_one_of_lt : a < b → a ≤ b - 1 := Nat.le_pred_of_lt
-
 theorem sub_one_lt_of_le (h₀ : 0 < a) (h₁ : a ≤ b) : a - 1 < b :=
   Nat.lt_of_lt_of_le (Nat.pred_lt' h₀) h₁
 
@@ -470,6 +334,32 @@ protected theorem sub_max_sub_right : ∀ (a b c : Nat), max (a - c) (b - c) = m
   | _, _, 0 => rfl
   | _, _, _+1 => Eq.trans (Nat.pred_max_pred ..) <| congrArg _ (Nat.sub_max_sub_right ..)
 
+protected theorem sub_min_sub_left (a b c : Nat) : min (a - b) (a - c) = a - max b c := by
+  omega
+
+protected theorem sub_max_sub_left (a b c : Nat) : max (a - b) (a - c) = a - min b c := by
+  omega
+
+protected theorem mul_max_mul_right (a b c : Nat) : max (a * c) (b * c) = max a b * c := by
+  induction a generalizing b with
+  | zero => simp
+  | succ i ind =>
+    cases b <;> simp [succ_eq_add_one, Nat.succ_mul, Nat.add_max_add_right, ind]
+
+protected theorem mul_min_mul_right (a b c : Nat) : min (a * c) (b * c) = min a b * c := by
+  induction a generalizing b with
+  | zero => simp
+  | succ i ind =>
+    cases b <;> simp [succ_eq_add_one, Nat.succ_mul, Nat.add_min_add_right, ind]
+
+protected theorem mul_max_mul_left (a b c : Nat) : max (a * b) (a * c) = a * max b c := by
+  repeat rw [Nat.mul_comm a]
+  exact Nat.mul_max_mul_right ..
+
+protected theorem mul_min_mul_left (a b c : Nat) : min (a * b) (a * c) = a * min b c := by
+  repeat rw [Nat.mul_comm a]
+  exact Nat.mul_min_mul_right ..
+
 -- protected theorem sub_min_sub_left (a b c : Nat) : min (a - b) (a - c) = a - max b c := by
 --   induction b, c using Nat.recDiagAux with
 --   | zero_left => rw [Nat.sub_zero, Nat.zero_max]; exact Nat.min_eq_right (Nat.sub_le ..)
@@ -518,10 +408,6 @@ protected theorem mul_right_comm (n m k : Nat) : n * m * k = n * k * m := by
 protected theorem mul_mul_mul_comm (a b c d : Nat) : (a * b) * (c * d) = (a * c) * (b * d) := by
   rw [Nat.mul_assoc, Nat.mul_assoc, Nat.mul_left_comm b]
 
-protected theorem mul_two (n) : n * 2 = n + n := by rw [Nat.mul_succ, Nat.mul_one]
-
-protected theorem two_mul (n) : 2 * n = n + n := by rw [Nat.succ_mul, Nat.one_mul]
-
 theorem mul_eq_zero : ∀ {m n}, n * m = 0 ↔ n = 0 ∨ m = 0
   | 0, _ => ⟨fun _ => .inr rfl, fun _ => rfl⟩
   | _, 0 => ⟨fun _ => .inl rfl, fun _ => Nat.zero_mul ..⟩
@@ -619,68 +505,6 @@ protected theorem pos_of_mul_pos_right {a b : Nat} (h : 0 < a * b) : 0 < a := by
 
 /-! ### div/mod -/
 
-protected theorem div_le_of_le_mul {m n : Nat} : ∀ {k}, m ≤ k * n → m / k ≤ n
-  | 0, _ => by simp [Nat.div_zero, n.zero_le]
-  | succ k, h => by
-    suffices succ k * (m / succ k) ≤ succ k * n from
-      Nat.le_of_mul_le_mul_left this (zero_lt_succ _)
-    have h1 : succ k * (m / succ k) ≤ m % succ k + succ k * (m / succ k) := Nat.le_add_left _ _
-    have h2 : m % succ k + succ k * (m / succ k) = m := by rw [mod_add_div]
-    have h3 : m ≤ succ k * n := h
-    rw [← h2] at h3
-    exact Nat.le_trans h1 h3
-
-@[simp] theorem mul_div_right (n : Nat) {m : Nat} (H : 0 < m) : m * n / m = n := by
-  induction n <;> simp_all [mul_succ]
-
-@[simp] theorem mul_div_left (m : Nat) {n : Nat} (H : 0 < n) : m * n / n = m := by
-  rw [Nat.mul_comm, mul_div_right _ H]
-
-protected theorem div_self (H : 0 < n) : n / n = 1 := by
-  let t := add_div_right 0 H
-  rwa [Nat.zero_add, Nat.zero_div] at t
-
-protected theorem mul_div_cancel (m : Nat) {n : Nat} (H : 0 < n) : m * n / n = m := by
-  let t := add_mul_div_right 0 m H
-  rwa [Nat.zero_add, Nat.zero_div, Nat.zero_add] at t
-
-protected theorem mul_div_cancel_left (m : Nat) {n : Nat} (H : 0 < n) : n * m / n = m :=
-by rw [Nat.mul_comm, Nat.mul_div_cancel _ H]
-
-protected theorem div_eq_of_eq_mul_left (H1 : 0 < n) (H2 : m = k * n) : m / n = k :=
-by rw [H2, Nat.mul_div_cancel _ H1]
-
-protected theorem div_eq_of_eq_mul_right (H1 : 0 < n) (H2 : m = n * k) : m / n = k :=
-by rw [H2, Nat.mul_div_cancel_left _ H1]
-
-protected theorem div_div_eq_div_mul (m n k : Nat) : m / n / k = m / (n * k) := by
-  cases eq_zero_or_pos k with
-  | inl k0 => rw [k0, Nat.mul_zero, Nat.div_zero, Nat.div_zero] | inr kpos => ?_
-  cases eq_zero_or_pos n with
-  | inl n0 => rw [n0, Nat.zero_mul, Nat.div_zero, Nat.zero_div] | inr npos => ?_
-  apply Nat.le_antisymm
-  · apply (le_div_iff_mul_le (Nat.mul_pos npos kpos)).2
-    rw [Nat.mul_comm n k, ← Nat.mul_assoc]
-    apply (le_div_iff_mul_le npos).1
-    apply (le_div_iff_mul_le kpos).1
-    (apply Nat.le_refl)
-  · apply (le_div_iff_mul_le kpos).2
-    apply (le_div_iff_mul_le npos).2
-    rw [Nat.mul_assoc, Nat.mul_comm n k]
-    apply (le_div_iff_mul_le (Nat.mul_pos kpos npos)).1
-    apply Nat.le_refl
-
-protected theorem mul_div_mul_left {m : Nat} (n k : Nat) (H : 0 < m) :
-    m * n / (m * k) = n / k := by rw [← Nat.div_div_eq_div_mul, Nat.mul_div_cancel_left _ H]
-
-protected theorem mul_div_mul_right {m : Nat} (n k : Nat) (H : 0 < m) :
-    n * m / (k * m) = n / k := by rw [Nat.mul_comm, Nat.mul_comm k, Nat.mul_div_mul_left _ _ H]
-
-theorem mul_div_le (m n : Nat) : n * (m / n) ≤ m := by
-  match n, Nat.eq_zero_or_pos n with
-  | _, Or.inl rfl => rw [Nat.zero_mul]; exact m.zero_le
-  | n, Or.inr h => rw [Nat.mul_comm, ← Nat.le_div_iff_mul_le h]; exact Nat.le_refl _
-
 theorem mod_two_eq_zero_or_one (n : Nat) : n % 2 = 0 ∨ n % 2 = 1 :=
   match n % 2, @Nat.mod_lt n 2 (by decide) with
   | 0, _ => .inl rfl
@@ -692,12 +516,6 @@ theorem le_of_mod_lt {a b : Nat} (h : a % b < a) : b ≤ a :=
 theorem mul_mod_mul_right (z x y : Nat) : (x * z) % (y * z) = (x % y) * z := by
   rw [Nat.mul_comm x z, Nat.mul_comm y z, Nat.mul_comm (x % y) z]; apply mul_mod_mul_left
 
-@[simp] theorem mod_mod_of_dvd (a : Nat) (h : c ∣ b) : a % b % c = a % c := by
-  rw (config := {occs := .pos [2]}) [← mod_add_div a b]
-  have ⟨x, h⟩ := h
-  subst h
-  rw [Nat.mul_assoc, add_mul_mod_self_left]
-
 theorem sub_mul_mod {x k n : Nat} (h₁ : n*k ≤ x) : (x - n*k) % n = x % n := by
   match k with
   | 0 => rw [Nat.mul_zero, Nat.sub_zero]
@@ -738,12 +556,6 @@ theorem pow_succ' {m n : Nat} : m ^ n.succ = m * m ^ n := by
 
 @[simp] theorem pow_eq {m n : Nat} : m.pow n = m ^ n := rfl
 
-theorem shiftLeft_eq (a b : Nat) : a <<< b = a * 2 ^ b :=
-  match b with
-  | 0 => (Nat.mul_one _).symm
-  | b+1 => (shiftLeft_eq _ b).trans <| by
-    simp [Nat.pow_succ, Nat.mul_assoc, Nat.mul_left_comm, Nat.mul_comm]
-
 theorem one_shiftLeft (n : Nat) : 1 <<< n = 2 ^ n := by rw [shiftLeft_eq, Nat.one_mul]
 
 attribute [simp] Nat.pow_zero
@@ -883,37 +695,17 @@ theorem lt_log2_self : n < 2 ^ (n.log2 + 1) :=
 
 /-! ### dvd -/
 
-theorem dvd_sub {k m n : Nat} (H : n ≤ m) (h₁ : k ∣ m) (h₂ : k ∣ n) : k ∣ m - n :=
-  (Nat.dvd_add_iff_left h₂).2 <| by rwa [Nat.sub_add_cancel H]
+protected theorem eq_mul_of_div_eq_right {a b c : Nat} (H1 : b ∣ a) (H2 : a / b = c) :
+    a = b * c := by
+  rw [← H2, Nat.mul_div_cancel' H1]
 
-protected theorem mul_dvd_mul {a b c d : Nat} : a ∣ b → c ∣ d → a * c ∣ b * d
-  | ⟨e, he⟩, ⟨f, hf⟩ =>
-    ⟨e * f, by simp [he, hf, Nat.mul_assoc, Nat.mul_left_comm, Nat.mul_comm]⟩
+protected theorem div_eq_iff_eq_mul_right {a b c : Nat} (H : 0 < b) (H' : b ∣ a) :
+    a / b = c ↔ a = b * c :=
+  ⟨Nat.eq_mul_of_div_eq_right H', Nat.div_eq_of_eq_mul_right H⟩
 
-protected theorem mul_dvd_mul_left (a : Nat) (h : b ∣ c) : a * b ∣ a * c :=
-  Nat.mul_dvd_mul (Nat.dvd_refl a) h
-
-protected theorem mul_dvd_mul_right (h: a ∣ b) (c : Nat) : a * c ∣ b * c :=
-  Nat.mul_dvd_mul h (Nat.dvd_refl c)
-
-@[simp] theorem dvd_one {n : Nat} : n ∣ 1 ↔ n = 1 :=
-  ⟨eq_one_of_dvd_one, fun h => h.symm ▸ Nat.dvd_refl _⟩
-
-protected theorem mul_div_assoc (m : Nat) (H : k ∣ n) : m * n / k = m * (n / k) := by
-  match Nat.eq_zero_or_pos k with
-  | .inl h0 => rw [h0, Nat.div_zero, Nat.div_zero, Nat.mul_zero]
-  | .inr hpos =>
-    have h1 : m * n / k = m * (n / k * k) / k := by rw [Nat.div_mul_cancel H]
-    rw [h1, ← Nat.mul_assoc, Nat.mul_div_cancel _ hpos]
-
-protected theorem dvd_of_mul_dvd_mul_left
-    (kpos : 0 < k) (H : k * m ∣ k * n) : m ∣ n := by
-  let ⟨l, H⟩ := H
-  rw [Nat.mul_assoc] at H
-  exact ⟨_, Nat.eq_of_mul_eq_mul_left kpos H⟩
-
-protected theorem dvd_of_mul_dvd_mul_right (kpos : 0 < k) (H : m * k ∣ n * k) : m ∣ n := by
-  rw [Nat.mul_comm m k, Nat.mul_comm n k] at H; exact Nat.dvd_of_mul_dvd_mul_left kpos H
+protected theorem div_eq_iff_eq_mul_left {a b c : Nat} (H : 0 < b) (H' : b ∣ a) :
+    a / b = c ↔ a = c * b := by
+  rw [Nat.mul_comm]; exact Nat.div_eq_iff_eq_mul_right H H'
 
 theorem pow_dvd_pow_iff_pow_le_pow {k l : Nat} :
     ∀ {x : Nat}, 0 < x → (x ^ k ∣ x ^ l ↔ x ^ k ≤ x ^ l)
@@ -937,18 +729,6 @@ theorem pow_dvd_pow_iff_le_right {x k l : Nat} (w : 1 < x) : x ^ k ∣ x ^ l ↔
 theorem pow_dvd_pow_iff_le_right' {b k l : Nat} : (b + 2) ^ k ∣ (b + 2) ^ l ↔ k ≤ l :=
   pow_dvd_pow_iff_le_right (Nat.lt_of_sub_eq_succ rfl)
 
-protected theorem eq_mul_of_div_eq_right {a b c : Nat} (H1 : b ∣ a) (H2 : a / b = c) :
-    a = b * c := by
-  rw [← H2, Nat.mul_div_cancel' H1]
-
-protected theorem div_eq_iff_eq_mul_right {a b c : Nat} (H : 0 < b) (H' : b ∣ a) :
-    a / b = c ↔ a = b * c :=
-  ⟨Nat.eq_mul_of_div_eq_right H', Nat.div_eq_of_eq_mul_right H⟩
-
-protected theorem div_eq_iff_eq_mul_left {a b c : Nat} (H : 0 < b) (H' : b ∣ a) :
-    a / b = c ↔ a = c * b := by
-  rw [Nat.mul_comm]; exact Nat.div_eq_iff_eq_mul_right H H'
-
 protected theorem pow_dvd_pow {m n : Nat} (a : Nat) (h : m ≤ n) : a ^ m ∣ a ^ n := by
   cases Nat.exists_eq_add_of_le h
   case intro k p =>
@@ -983,10 +763,6 @@ theorem shiftLeft_succ : ∀(m n), m <<< (n + 1) = 2 * (m <<< n)
   rw [shiftLeft_succ_inside _ (k+1)]
   rw [shiftLeft_succ _ k, shiftLeft_succ_inside]
 
-@[simp] theorem shiftRight_zero : n >>> 0 = n := rfl
-
-theorem shiftRight_succ (m n) : m >>> (n + 1) = (m >>> n) / 2 := rfl
-
 /-- Shiftright on successor with division moved inside. -/
 theorem shiftRight_succ_inside : ∀m n, m >>> (n+1) = (m/2) >>> n
 | m, 0 => rfl
@@ -1002,19 +778,9 @@ theorem shiftRight_succ_inside : ∀m n, m >>> (n+1) = (m/2) >>> n
   | 0 => by simp [shiftRight]
   | n + 1 => by simp [shiftRight, zero_shiftRight n, shiftRight_succ]
 
-theorem shiftRight_add (m n : Nat) : ∀ k, m >>> (n + k) = (m >>> n) >>> k
-  | 0 => rfl
-  | k + 1 => by simp [add_succ, shiftRight_add, shiftRight_succ]
-
 theorem shiftLeft_shiftLeft (m n : Nat) : ∀ k, (m <<< n) <<< k = m <<< (n + k)
   | 0 => rfl
-  | k + 1 => by simp [add_succ, shiftLeft_shiftLeft _ _ k, shiftLeft_succ]
-
-theorem shiftRight_eq_div_pow (m : Nat) : ∀ n, m >>> n = m / 2 ^ n
-  | 0 => (Nat.div_one _).symm
-  | k + 1 => by
-    rw [shiftRight_add, shiftRight_eq_div_pow m k]
-    simp [Nat.div_div_eq_div_mul, ← Nat.pow_succ, shiftRight_succ]
+  | k + 1 => by simp [← Nat.add_assoc, shiftLeft_shiftLeft _ _ k, shiftLeft_succ]
 
 theorem mul_add_div {m : Nat} (m_pos : m > 0) (x y : Nat) : (m * x + y) / m = x + y / m := by
   match x with

src/Init/Data/Nat/Linear.lean

@@ -4,10 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Init.Coe
 import Init.ByCases
-import Init.Data.Nat.Basic
-import Init.Data.List.Basic
 import Init.Data.Prod
 
 namespace Nat.Linear
@@ -583,7 +580,7 @@ attribute [-simp] Nat.right_distrib Nat.left_distrib
 
 theorem PolyCnstr.denote_mul (ctx : Context) (k : Nat) (c : PolyCnstr) : (c.mul (k+1)).denote ctx = c.denote ctx := by
   cases c; rename_i eq lhs rhs
-  have : k ≠ 0 → k + 1 ≠ 1 := by intro h; match k with | 0 => contradiction | k+1 => simp; apply Nat.succ_ne_zero
+  have : k ≠ 0 → k + 1 ≠ 1 := by intro h; match k with | 0 => contradiction | k+1 => simp
   have : ¬ (k == 0) → (k + 1 == 1) = false := fun h => beq_false_of_ne (this (ne_of_beq_false (Bool.of_not_eq_true h)))
   have : ¬ ((k + 1 == 0) = true)  := fun h => absurd (eq_of_beq h) (Nat.succ_ne_zero k)
   have : (1 == (0 : Nat)) = false := rfl

src/Init/Data/Nat/Log2.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Gabriel Ebner
 -/
 prelude
-import Init.NotationExtra
 import Init.Data.Nat.Linear
 
 namespace Nat

src/Init/Data/Ord.lean

@@ -5,7 +5,6 @@ Authors: Dany Fabian, Sebastian Ullrich
 -/
 
 prelude
-import Init.Data.Int
 import Init.Data.String
 
 inductive Ordering where

src/Init/Data/Random.lean

@@ -5,7 +5,6 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.System.IO
-import Init.Data.Int
 universe u
 
 /-!

src/Init/NotationExtra.lean

@@ -9,6 +9,7 @@ prelude
 import Init.Meta
 import Init.Data.Array.Subarray
 import Init.Data.ToString
+import Init.Conv
 namespace Lean
 
 macro "Macro.trace[" id:ident "]" s:interpolatedStr(term) : term =>
@@ -123,7 +124,7 @@ calc abc
   _ = xyz := pwxyz
 ```
 
-`calc` has term mode and tactic mode variants. This is the term mode variant.
+`calc` works as a term, as a tactic or as a `conv` tactic.
 
 See [Theorem Proving in Lean 4][tpil4] for more information.
 
@@ -131,45 +132,13 @@ See [Theorem Proving in Lean 4][tpil4] for more information.
 -/
 syntax (name := calc) "calc" calcSteps : term
 
-/-- Step-wise reasoning over transitive relations.
-```
-calc
-  a = b := pab
-  b = c := pbc
-  ...
-  y = z := pyz
-```
-proves `a = z` from the given step-wise proofs. `=` can be replaced with any
-relation implementing the typeclass `Trans`. Instead of repeating the right-
-hand sides, subsequent left-hand sides can be replaced with `_`.
-```
-calc
-  a = b := pab
-  _ = c := pbc
-  ...
-  _ = z := pyz
-```
-It is also possible to write the *first* relation as `<lhs>\n  _ = <rhs> :=
-<proof>`. This is useful for aligning relation symbols:
-```
-calc abc
-  _ = bce := pabce
-  _ = cef := pbcef
-  ...
-  _ = xyz := pwxyz
-```
-
-`calc` has term mode and tactic mode variants. This is the tactic mode variant,
-which supports an additional feature: it works even if the goal is `a = z'`
-for some other `z'`; in this case it will not close the goal but will instead
-leave a subgoal proving `z = z'`.
-
-See [Theorem Proving in Lean 4][tpil4] for more information.
-
-[tpil4]: https://lean-lang.org/theorem_proving_in_lean4/quantifiers_and_equality.html#calculational-proofs
--/
+@[inherit_doc «calc»]
 syntax (name := calcTactic) "calc" calcSteps : tactic
 
+@[inherit_doc «calc»]
+macro tk:"calc" steps:calcSteps : conv =>
+  `(conv| tactic => calc%$tk $steps)
+
 @[app_unexpander Unit.unit] def unexpandUnit : Lean.PrettyPrinter.Unexpander
   | `($(_)) => `(())
 

src/Init/Omega/Int.lean

@@ -4,9 +4,8 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Scott Morrison
 -/
 prelude
+import Init.Data.Int.DivMod
 import Init.Data.Int.Order
-import Init.Data.Int.DivModLemmas
-import Init.Data.Nat.Lemmas
 
 /-!
 # Lemmas about `Nat`, `Int`, and `Fin` needed internally by `omega`.
@@ -49,7 +48,7 @@ theorem ofNat_shiftLeft_eq {x y : Nat} : (x <<< y : Int) = (x : Int) * (2 ^ y :
   simp [Nat.shiftLeft_eq]
 
 theorem ofNat_shiftRight_eq_div_pow {x y : Nat} : (x >>> y : Int) = (x : Int) / (2 ^ y : Nat) := by
-  simp [Nat.shiftRight_eq_div_pow]
+  simp only [Nat.shiftRight_eq_div_pow, Int.ofNat_ediv]
 
 -- FIXME these are insane:
 theorem lt_of_not_ge {x y : Int} (h : ¬ (x ≤ y)) : y < x := Int.not_le.mp h

src/Init/Omega/IntList.lean

@@ -5,6 +5,8 @@ Authors: Scott Morrison
 -/
 prelude
 import Init.Data.List.Lemmas
+import Init.Data.Int.DivModLemmas
+import Init.Data.Nat.Gcd
 
 namespace Lean.Omega
 

src/Init/Prelude.lean

@@ -1485,6 +1485,7 @@ instance [ShiftRight α] : HShiftRight α α α where
   hShiftRight a b := ShiftRight.shiftRight a b
 
 open HAdd (hAdd)
+open HSub (hSub)
 open HMul (hMul)
 open HPow (hPow)
 open HAppend (hAppend)
@@ -2035,7 +2036,7 @@ instance : Inhabited UInt64 where
   default := UInt64.ofNatCore 0 (by decide)
 
 /--
-The size of type `UInt16`, that is, `2^System.Platform.numBits`, which may
+The size of type `USize`, that is, `2^System.Platform.numBits`, which may
 be either `2^32` or `2^64` depending on the platform's architecture.
 
 Remark: we define `USize.size` using `(2^numBits - 1) + 1` to ensure the
@@ -2053,7 +2054,7 @@ instance : OfNat (Fin (n+1)) i where
   ofNat := Fin.ofNat i
 ```
 -/
-abbrev USize.size : Nat := Nat.succ (Nat.sub (hPow 2 System.Platform.numBits) 1)
+abbrev USize.size : Nat := hAdd (hSub (hPow 2 System.Platform.numBits) 1) 1
 
 theorem usize_size_eq : Or (Eq USize.size 4294967296) (Eq USize.size 18446744073709551616) :=
   show Or (Eq (Nat.succ (Nat.sub (hPow 2 System.Platform.numBits) 1)) 4294967296) (Eq (Nat.succ (Nat.sub (hPow 2 System.Platform.numBits) 1)) 18446744073709551616) from

src/Init/PropLemmas.lean

@@ -23,6 +23,9 @@ set_option linter.missingDocs true -- keep it documented
 @[simp] theorem eq_true_eq_id : Eq True = id := by
   funext _; simp only [true_iff, id.def, eq_iff_iff]
 
+theorem proof_irrel_heq {p q : Prop} (hp : p) (hq : q) : HEq hp hq := by
+  cases propext (iff_of_true hp hq); rfl
+
 /-! ## not -/
 
 theorem not_not_em (a : Prop) : ¬¬(a ∨ ¬a) := fun h => h (.inr (h ∘ .inl))

src/Init/Simproc.lean

@@ -31,22 +31,43 @@ Simplification procedures can be also scoped or local.
 -/
 syntax (docComment)? attrKind "simproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
 
+/--
+Similar to `simproc`, but resulting expression must be definitionally equal to the input one.
+-/
+syntax (docComment)? attrKind "dsimproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
+
 /--
 A user-defined simplification procedure declaration. To activate this procedure in `simp` tactic,
 we must provide it as an argument, or use the command `attribute` to set its `[simproc]` attribute.
 -/
 syntax (docComment)? "simproc_decl " ident " (" term ")" " := " term : command
 
+/--
+A user-defined defeq simplification procedure declaration. To activate this procedure in `simp` tactic,
+we must provide it as an argument, or use the command `attribute` to set its `[simproc]` attribute.
+-/
+syntax (docComment)? "dsimproc_decl " ident " (" term ")" " := " term : command
+
 /--
 A builtin simplification procedure.
 -/
 syntax (docComment)? attrKind "builtin_simproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
 
+/--
+A builtin defeq simplification procedure.
+-/
+syntax (docComment)? attrKind "builtin_dsimproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
+
 /--
 A builtin simplification procedure declaration.
 -/
 syntax (docComment)? "builtin_simproc_decl " ident " (" term ")" " := " term : command
 
+/--
+A builtin defeq simplification procedure declaration.
+-/
+syntax (docComment)? "builtin_dsimproc_decl " ident " (" term ")" " := " term : command
+
 /--
 Auxiliary command for associating a pattern with a simplification procedure.
 -/
@@ -86,33 +107,60 @@ macro_rules
     `($[$doc?:docComment]? def $n:ident : $(mkIdent simprocType) := $body
       simproc_pattern% $pattern => $n)
 
+macro_rules
+  | `($[$doc?:docComment]? dsimproc_decl $n:ident ($pattern:term) := $body) => do
+    let simprocType := `Lean.Meta.Simp.DSimproc
+    `($[$doc?:docComment]? def $n:ident : $(mkIdent simprocType) := $body
+      simproc_pattern% $pattern => $n)
+
 macro_rules
   | `($[$doc?:docComment]? builtin_simproc_decl $n:ident ($pattern:term) := $body) => do
     let simprocType := `Lean.Meta.Simp.Simproc
     `($[$doc?:docComment]? def $n:ident : $(mkIdent simprocType) := $body
       builtin_simproc_pattern% $pattern => $n)
 
+macro_rules
+  | `($[$doc?:docComment]? builtin_dsimproc_decl $n:ident ($pattern:term) := $body) => do
+    let simprocType := `Lean.Meta.Simp.DSimproc
+    `($[$doc?:docComment]? def $n:ident : $(mkIdent simprocType) := $body
+      builtin_simproc_pattern% $pattern => $n)
+
+private def mkAttributeCmds
+    (kind : TSyntax `Lean.Parser.Term.attrKind)
+    (pre? : Option (TSyntax [`Lean.Parser.Tactic.simpPre, `Lean.Parser.Tactic.simpPost]))
+    (ids? : Option (Syntax.TSepArray `ident ","))
+    (n : Ident) : MacroM (Array Syntax) := do
+  let mut cmds := #[]
+  let pushDefault (cmds : Array (TSyntax `command)) : MacroM (Array (TSyntax `command)) := do
+    return cmds.push (← `(attribute [$kind simproc $[$pre?]?] $n))
+  if let some ids := ids? then
+    for id in ids.getElems do
+      let idName := id.getId
+      let (attrName, attrKey) :=
+        if idName == `simp then
+          (`simprocAttr, "simproc")
+        else if idName == `seval then
+          (`sevalprocAttr, "sevalproc")
+        else
+          let idName := idName.appendAfter "_proc"
+          (`Parser.Attr ++ idName, idName.toString)
+      let attrStx : TSyntax `attr := ⟨mkNode attrName #[mkAtom attrKey, mkOptionalNode pre?]⟩
+      cmds := cmds.push (← `(attribute [$kind $attrStx] $n))
+  else
+    cmds ← pushDefault cmds
+  return cmds
+
 macro_rules
   | `($[$doc?:docComment]? $kind:attrKind simproc $[$pre?]? $[ [ $ids?:ident,* ] ]? $n:ident ($pattern:term) := $body) => do
-     let mut cmds := #[(← `($[$doc?:docComment]? simproc_decl $n ($pattern) := $body))]
-     let pushDefault (cmds : Array (TSyntax `command)) : MacroM (Array (TSyntax `command)) := do
-       return cmds.push (← `(attribute [$kind simproc $[$pre?]?] $n))
-     if let some ids := ids? then
-       for id in ids.getElems do
-         let idName := id.getId
-         let (attrName, attrKey) :=
-           if idName == `simp then
-             (`simprocAttr, "simproc")
-           else if idName == `seval then
-             (`sevalprocAttr, "sevalproc")
-           else
-             let idName := idName.appendAfter "_proc"
-             (`Parser.Attr ++ idName, idName.toString)
-         let attrStx : TSyntax `attr := ⟨mkNode attrName #[mkAtom attrKey, mkOptionalNode pre?]⟩
-         cmds := cmds.push (← `(attribute [$kind $attrStx] $n))
-     else
-       cmds ← pushDefault cmds
-     return mkNullNode cmds
+     return mkNullNode <|
+       #[(← `($[$doc?:docComment]? simproc_decl $n ($pattern) := $body))]
+       ++ (← mkAttributeCmds kind pre? ids? n)
+
+macro_rules
+  | `($[$doc?:docComment]? $kind:attrKind dsimproc $[$pre?]? $[ [ $ids?:ident,* ] ]? $n:ident ($pattern:term) := $body) => do
+     return mkNullNode <|
+       #[(← `($[$doc?:docComment]? dsimproc_decl $n ($pattern) := $body))]
+       ++ (← mkAttributeCmds kind pre? ids? n)
 
 macro_rules
   | `($[$doc?:docComment]? $kind:attrKind builtin_simproc $[$pre?]? $n:ident ($pattern:term) := $body) => do
@@ -126,4 +174,16 @@ macro_rules
       attribute [$kind builtin_simproc $[$pre?]?] $n
       attribute [$kind builtin_sevalproc $[$pre?]?] $n)
 
+macro_rules
+  | `($[$doc?:docComment]? $kind:attrKind builtin_dsimproc $[$pre?]? $n:ident ($pattern:term) := $body) => do
+    `($[$doc?:docComment]? builtin_dsimproc_decl $n ($pattern) := $body
+      attribute [$kind builtin_simproc $[$pre?]?] $n)
+  | `($[$doc?:docComment]? $kind:attrKind builtin_dsimproc $[$pre?]? [seval] $n:ident ($pattern:term) := $body) => do
+    `($[$doc?:docComment]? builtin_dsimproc_decl $n ($pattern) := $body
+      attribute [$kind builtin_sevalproc $[$pre?]?] $n)
+  | `($[$doc?:docComment]? $kind:attrKind builtin_dsimproc $[$pre?]? [simp, seval] $n:ident ($pattern:term) := $body) => do
+    `($[$doc?:docComment]? builtin_dsimproc_decl $n ($pattern) := $body
+      attribute [$kind builtin_simproc $[$pre?]?] $n
+      attribute [$kind builtin_sevalproc $[$pre?]?] $n)
+
 end Lean.Parser

src/Init/System/IO.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Luke Nelson, Jared Roesch, Leonardo de Moura, Sebastian Ullrich, Mac Malone
 -/
 prelude
-import Init.Control.EState
 import Init.Control.Reader
 import Init.Data.String
 import Init.Data.ByteArray

src/Init/WF.lean

@@ -45,7 +45,7 @@ def apply {α : Sort u} {r : α → α → Prop} (wf : WellFounded r) (a : α) :
 section
 variable {α : Sort u} {r : α → α → Prop} (hwf : WellFounded r)
 
-theorem recursion {C : α → Sort v} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a := by
+noncomputable def recursion {C : α → Sort v} (a : α) (h : ∀ x, (∀ y, r y x → C y) → C x) : C a := by
   induction (apply hwf a) with
   | intro x₁ _ ih => exact h x₁ ih
 
@@ -166,13 +166,13 @@ def lt_wfRel : WellFoundedRelation Nat where
       | Or.inl e => subst e; assumption
       | Or.inr e => exact Acc.inv ih e
 
-protected theorem strongInductionOn
+protected noncomputable def strongInductionOn
     {motive : Nat → Sort u}
     (n : Nat)
     (ind : ∀ n, (∀ m, m < n → motive m) → motive n) : motive n :=
   Nat.lt_wfRel.wf.fix ind n
 
-protected theorem caseStrongInductionOn
+protected noncomputable def caseStrongInductionOn
     {motive : Nat → Sort u}
     (a : Nat)
     (zero : motive 0)

src/Lean/CoreM.lean

@@ -289,6 +289,9 @@ def Exception.isMaxHeartbeat (ex : Exception) : Bool :=
 def mkArrow (d b : Expr) : CoreM Expr :=
   return Lean.mkForall (← mkFreshUserName `x) BinderInfo.default d b
 
+/-- Iterated `mkArrow`, creates the expression `a₁ → a₂ → … → aₙ → b`. Also see `arrowDomainsN`. -/
+def mkArrowN (ds : Array Expr) (e : Expr) : CoreM Expr := ds.foldrM mkArrow e
+
 def addDecl (decl : Declaration) : CoreM Unit := do
   profileitM Exception "type checking" (← getOptions) do
     withTraceNode `Kernel (fun _ => return m!"typechecking declaration") do

src/Lean/Data/HashMap.lean

@@ -116,6 +116,22 @@ def expand [Hashable α] (size : Nat) (buckets : HashMapBucket α β) : HashMapI
       else
         (expand size' buckets', false)
 
+@[inline] def insertIfNew [beq : BEq α] [Hashable α] (m : HashMapImp α β) (a : α) (b : β) : HashMapImp α β × Option β :=
+  match m with
+  | ⟨size, buckets⟩ =>
+    let ⟨i, h⟩ := mkIdx (hash a) buckets.property
+    let bkt    := buckets.val[i]
+    if let some b := bkt.find? a then
+      (m, some b)
+    else
+      let size'    := size + 1
+      let buckets' := buckets.update i (AssocList.cons a b bkt) h
+      if numBucketsForCapacity size' ≤ buckets.val.size then
+        ({ size := size', buckets := buckets' }, none)
+      else
+        (expand size' buckets', none)
+
+
 def erase [BEq α] [Hashable α] (m : HashMapImp α β) (a : α) : HashMapImp α β :=
   match m with
   | ⟨ size, buckets ⟩ =>
@@ -125,9 +141,10 @@ def erase [BEq α] [Hashable α] (m : HashMapImp α β) (a : α) : HashMapImp α
     else m
 
 inductive WellFormed [BEq α] [Hashable α] : HashMapImp α β → Prop where
-  | mkWff     : ∀ n,                    WellFormed (mkHashMapImp n)
-  | insertWff : ∀ m a b, WellFormed m → WellFormed (insert m a b |>.1)
-  | eraseWff  : ∀ m a,   WellFormed m → WellFormed (erase m a)
+  | mkWff          : ∀ n,                    WellFormed (mkHashMapImp n)
+  | insertWff      : ∀ m a b, WellFormed m → WellFormed (insert m a b |>.1)
+  | insertIfNewWff : ∀ m a b, WellFormed m → WellFormed (insertIfNew m a b |>.1)
+  | eraseWff       : ∀ m a,   WellFormed m → WellFormed (erase m a)
 
 end HashMapImp
 
@@ -156,13 +173,22 @@ def insert (m : HashMap α β) (a : α) (b : β) : HashMap α β :=
     match h:m.insert a b with
     | (m', _) => ⟨ m', by have aux := WellFormed.insertWff m a b hw; rw [h] at aux; assumption ⟩
 
-/-- Similar to `insert`, but also returns a Boolean flad indicating whether an existing entry has been replaced with `a -> b`. -/
+/-- Similar to `insert`, but also returns a Boolean flag indicating whether an existing entry has been replaced with `a -> b`. -/
 def insert' (m : HashMap α β) (a : α) (b : β) : HashMap α β × Bool :=
   match m with
   | ⟨ m, hw ⟩ =>
     match h:m.insert a b with
     | (m', replaced) => (⟨ m', by have aux := WellFormed.insertWff m a b hw; rw [h] at aux; assumption ⟩, replaced)
 
+/--
+Similar to `insert`, but returns `some old` if the map already had an entry `α → old`.
+If the result is `some old`, the the resulting map is equal to `m`. -/
+def insertIfNew (m : HashMap α β) (a : α) (b : β) : HashMap α β × Option β :=
+  match m with
+  | ⟨ m, hw ⟩ =>
+    match h:m.insertIfNew a b with
+    | (m', old) => (⟨ m', by have aux := WellFormed.insertIfNewWff m a b hw; rw [h] at aux; assumption ⟩, old)
+
 @[inline] def erase (m : HashMap α β) (a : α) : HashMap α β :=
   match m with
   | ⟨ m, hw ⟩ => ⟨ m.erase a, WellFormed.eraseWff m a hw ⟩

src/Lean/Elab/GuardMsgs.lean

@@ -73,9 +73,28 @@ structure GuardMsgFailure where
   res : String
 deriving TypeName
 
+/--
+Makes trailing whitespace visible and protectes them against trimming by the editor, by appending
+the symbol ⏎ to such a line (and also to any line that ends with such a symbol, to avoid
+ambiguities in the case the message already had that symbol).
+-/
+def revealTrailingWhitespace (s : String) : String :=
+  s.replace "⏎\n" "⏎⏎\n" |>.replace "\t\n" "\t⏎\n" |>.replace " \n" " ⏎\n"
+
+/- The inverse of `revealTrailingWhitespace` -/
+def removeTrailingWhitespaceMarker (s : String) : String :=
+  s.replace "⏎\n" "\n"
+
+/--
+Strings are compared up to newlines, to allow users to break long lines.
+-/
+def equalUpToNewlines (exp res : String) : Bool :=
+  exp.replace "\n" " " == res.replace "\n" " "
+
 @[builtin_command_elab Lean.guardMsgsCmd] def elabGuardMsgs : CommandElab
   | `(command| $[$dc?:docComment]? #guard_msgs%$tk $(spec?)? in $cmd) => do
-    let expected : String := (← dc?.mapM (getDocStringText ·)).getD "" |>.trim
+    let expected : String := (← dc?.mapM (getDocStringText ·)).getD ""
+        |>.trim |> removeTrailingWhitespaceMarker
     let specFn ← parseGuardMsgsSpec spec?
     let initMsgs ← modifyGet fun st => (st.messages, { st with messages := {} })
     elabCommandTopLevel cmd
@@ -88,8 +107,7 @@ deriving TypeName
       | .drop        => pure ()
       | .passthrough => toPassthrough := toPassthrough.add msg
     let res := "---\n".intercalate (← toCheck.toList.mapM (messageToStringWithoutPos ·)) |>.trim
-    -- We do some whitespace normalization here to allow users to break long lines.
-    if expected.replace "\n" " " == res.replace "\n" " " then
+    if equalUpToNewlines expected res then
       -- Passed. Only put toPassthrough messages back on the message log
       modify fun st => { st with messages := initMsgs ++ toPassthrough }
     else
@@ -119,6 +137,7 @@ def guardMsgsCodeAction : CommandCodeAction := fun _ _ _ node => do
     lazy? := some do
       let some start := stx.getPos? true | return eager
       let some tail := stx.setArg 0 mkNullNode |>.getPos? true | return eager
+      let res := revealTrailingWhitespace res
       let newText := if res.isEmpty then
         ""
       else if res.length ≤ 100-7 && !res.contains '\n' then -- TODO: configurable line length?

src/Lean/Elab/MutualDef.lean

@@ -68,8 +68,6 @@ private def check (prevHeaders : Array DefViewElabHeader) (newHeader : DefViewEl
     throwError "'partial' theorems are not allowed, 'partial' is a code generation directive"
   if newHeader.kind.isTheorem && newHeader.modifiers.isNoncomputable then
     throwError "'theorem' subsumes 'noncomputable', code is not generated for theorems"
-  if newHeader.modifiers.isNoncomputable && newHeader.modifiers.isUnsafe then
-    throwError "'noncomputable unsafe' is not allowed"
   if newHeader.modifiers.isNoncomputable && newHeader.modifiers.isPartial then
     throwError "'noncomputable partial' is not allowed"
   if newHeader.modifiers.isPartial && newHeader.modifiers.isUnsafe then
@@ -646,6 +644,9 @@ def pushMain (preDefs : Array PreDefinition) (sectionVars : Array Expr) (mainHea
     let termination := termination.rememberExtraParams header.numParams mainVals[i]!
     let value ← mkLambdaFVars sectionVars mainVals[i]!
     let type ← mkForallFVars sectionVars header.type
+    if header.kind.isTheorem then
+      unless (← isProp type) do
+        throwErrorAt header.ref "type of theorem '{header.declName}' is not a proposition{indentExpr type}"
     return preDefs.push {
       ref         := getDeclarationSelectionRef header.ref
       kind        := header.kind
@@ -659,10 +660,14 @@ def pushLetRecs (preDefs : Array PreDefinition) (letRecClosures : List LetRecClo
   letRecClosures.foldlM (init := preDefs) fun preDefs c => do
     let type  := Closure.mkForall c.localDecls c.toLift.type
     let value := Closure.mkLambda c.localDecls c.toLift.val
-    -- Convert any proof let recs inside a `def` to `theorem` kind
     let kind ← if kind.isDefOrAbbrevOrOpaque then
+      -- Convert any proof let recs inside a `def` to `theorem` kind
       withLCtx c.toLift.lctx c.toLift.localInstances do
         return if (← inferType c.toLift.type).isProp then .theorem else kind
+    else if kind.isTheorem then
+      -- Convert any non-proof let recs inside a `theorem` to `def` kind
+      withLCtx c.toLift.lctx c.toLift.localInstances do
+        return if (← inferType c.toLift.type).isProp then .theorem else .def
     else
       pure kind
     return preDefs.push {

src/Lean/Elab/PreDefinition/Eqns.lean

@@ -380,7 +380,7 @@ def mkUnfoldEq (declName : Name) (info : EqnInfoCore) : MetaM Name := withLCtx {
       mkUnfoldProof declName goal.mvarId!
       let type ← mkForallFVars xs type
       let value ← mkLambdaFVars xs (← instantiateMVars goal)
-      let name := baseName ++ `_unfold
+      let name := baseName ++ `def
       addDecl <| Declaration.thmDecl {
         name, type, value
         levelParams := info.levelParams

src/Lean/Elab/PreDefinition/Structural/Eqns.lean

@@ -68,7 +68,7 @@ def mkEqns (info : EqnInfo) : MetaM (Array Name) :=
   for i in [: eqnTypes.size] do
     let type := eqnTypes[i]!
     trace[Elab.definition.structural.eqns] "{eqnTypes[i]!}"
-    let name := baseName ++ (`_eq).appendIndexAfter (i+1)
+    let name := baseName ++ (`eq).appendIndexAfter (i+1)
     thmNames := thmNames.push name
     let value ← mkProof info.declName type
     let (type, value) ← removeUnusedEqnHypotheses type value

src/Lean/Elab/PreDefinition/WF/Eqns.lean

@@ -117,7 +117,7 @@ def mkEqns (declName : Name) (info : EqnInfo) : MetaM (Array Name) :=
   for i in [: eqnTypes.size] do
     let type := eqnTypes[i]!
     trace[Elab.definition.wf.eqns] "{eqnTypes[i]!}"
-    let name := baseName ++ (`_eq).appendIndexAfter (i+1)
+    let name := baseName ++ (`eq).appendIndexAfter (i+1)
     thmNames := thmNames.push name
     let value ← mkProof declName type
     let (type, value) ← removeUnusedEqnHypotheses type value

src/Lean/Elab/PreDefinition/WF/GuessLex.lean

@@ -302,7 +302,11 @@ def GuessLexRel.toNatRel : GuessLexRel → Expr
   | le => mkAppN (mkConst ``LE.le [levelZero]) #[mkConst ``Nat, mkConst ``instLENat]
   | no_idea => unreachable!
 
-/-- Given an expression `e`, produce `sizeOf e` with a suitable instance. -/
+/--
+Given an expression `e`, produce `sizeOf e` with a suitable instance.
+NB: We must use the instance of the type of the function parameter!
+The concrete argument at hand may have a different (still def-eq) typ.
+-/
 def mkSizeOf (e : Expr) : MetaM Expr := do
   let ty ← inferType e
   let lvl ← getLevel ty
@@ -315,8 +319,8 @@ def mkSizeOf (e : Expr) : MetaM Expr := do
 For a given recursive call, and a choice of parameter and argument index,
 try to prove equality, < or ≤.
 -/
-def evalRecCall (decrTactic? : Option DecreasingBy) (rcc : RecCallWithContext) (paramIdx argIdx : Nat) :
-    MetaM GuessLexRel := do
+def evalRecCall (decrTactic? : Option DecreasingBy) (rcc : RecCallWithContext)
+  (paramIdx argIdx : Nat) : MetaM GuessLexRel := do
   rcc.ctxt.run do
     let param := rcc.params[paramIdx]!
     let arg := rcc.args[argIdx]!
@@ -407,7 +411,7 @@ def inspectCall (rc : RecCallCache) : MutualMeasure → MetaM GuessLexRel
       return .eq
 
 /--
-Given a predefinition with value `fun (x_₁ ... xₙ) (y_₁ : α₁)... (yₘ : αₘ) => ...`,
+Given a predefinition with value `fun (x₁ ... xₙ) (y₁ : α₁)... (yₘ : αₘ) => ...`,
 where `n = fixedPrefixSize`, return an array `A` s.t. `i ∈ A` iff `sizeOf yᵢ` reduces to a literal.
 This is the case for types such as `Prop`, `Type u`, etc.
 These arguments should not be considered when guessing a well-founded relation.
@@ -425,6 +429,47 @@ def getForbiddenByTrivialSizeOf (fixedPrefixSize : Nat) (preDef : PreDefinition)
         result := result.push i
     return result
 
+/--
+Given a predefinition with value `fun (x₁ ... xₙ) (y₁ : α₁)... (yₘ : αₘ) => ...`,
+where `n = fixedPrefixSize`, return an array `A` s.t. `i ∈ A` iff the
+`WellFoundedRelation` of `aᵢ` goes via `SizeOf`, and `aᵢ` does not depend on `y₁`….
+
+These are the parameters for which we omit an explicit call to `sizeOf` in the termination argument.
+
+We only use this in the non-mutual case; in the mutual case we would have to additional check
+if the parameters that line up in the actual `TerminationWF` have the same type.
+-/
+def getSizeOfParams (fixedPrefixSize : Nat) (preDef : PreDefinition) : MetaM (Array Nat) :=
+  lambdaTelescope preDef.value fun xs _ => do
+    let xs  : Array Expr := xs[fixedPrefixSize:]
+    let mut result := #[]
+    for x in xs, i in [:xs.size] do
+      try
+        let t ← inferType x
+        if t.hasAnyFVar (fun fvar => xs.contains (.fvar fvar)) then continue
+        let u ← getLevel t
+        let wfi ← synthInstance (.app (.const ``WellFoundedRelation [u]) t)
+        let soi ← synthInstance (.app (.const ``SizeOf [u]) t)
+        if ← isDefEq wfi (mkApp2 (.const ``sizeOfWFRel [u]) t soi) then
+          result := result.push i
+      catch _ =>
+        pure ()
+    return result
+
+/--
+Given a predefinition with value `fun (x₁ ... xₙ) (y₁ : α₁)... (yₘ : αₘ) => ...`,
+where `n = fixedPrefixSize`, return an array `A` s.t. `i ∈ A` iff `aᵢ` is `Nat`.
+These are parameters where we can definitely omit the call to `sizeOf`.
+-/
+def getNatParams (fixedPrefixSize : Nat) (preDef : PreDefinition) : MetaM (Array Nat) :=
+  lambdaTelescope preDef.value fun xs _ => do
+    let xs  : Array Expr := xs[fixedPrefixSize:]
+    let mut result := #[]
+    for x in xs, i in [:xs.size] do
+      let t ← inferType x
+      if ← withReducible (isDefEq t (.const `Nat [])) then
+        result := result.push i
+    return result
 
 /--
 Generate all combination of arguments, skipping those that are forbidden.
@@ -539,23 +584,26 @@ combination of these measures. The parameters are
 * `measures`: The measures to be used.
 -/
 def buildTermWF (originalVarNamess : Array (Array Name)) (varNamess : Array (Array Name))
-  (measures : Array MutualMeasure) : MetaM TerminationWF := do
+  (needsNoSizeOf : Array (Array Nat)) (measures : Array MutualMeasure) : MetaM TerminationWF := do
   varNamess.mapIdxM fun funIdx varNames => do
     let idents := varNames.map mkIdent
     let measureStxs ← measures.mapM fun
       | .args varIdxs => do
           let varIdx := varIdxs[funIdx]!
           let v := idents[varIdx]!
-          -- Print `sizeOf` as such, unless it is shadowed.
-          -- Shadowing by a `def` in the current namespace is handled by `unresolveNameGlobal`.
-          -- But it could also be shadowed by an earlier parameter (including the fixed prefix),
-          -- so look for unqualified (single tick) occurrences in `originalVarNames`
-          let sizeOfIdent :=
-            if originalVarNamess[funIdx]!.any (· = `sizeOf) then
-              mkIdent ``sizeOf -- fully qualified
-            else
-              mkIdent (← unresolveNameGlobal ``sizeOf)
-          `($sizeOfIdent $v)
+          if needsNoSizeOf[funIdx]!.contains varIdx then
+            `($v)
+          else
+            -- Print `sizeOf` as such, unless it is shadowed.
+            -- Shadowing by a `def` in the current namespace is handled by `unresolveNameGlobal`.
+            -- But it could also be shadowed by an earlier parameter (including the fixed prefix),
+            -- so look for unqualified (single tick) occurrences in `originalVarNames`
+            let sizeOfIdent :=
+              if originalVarNamess[funIdx]!.any (· = `sizeOf) then
+                mkIdent ``sizeOf -- fully qualified
+              else
+                mkIdent (← unresolveNameGlobal ``sizeOf)
+            `($sizeOfIdent $v)
       | .func funIdx' => if funIdx' == funIdx then `(1) else `(0)
     let body ← mkTupleSyntax measureStxs
     return { ref := .missing, vars := idents, body, synthetic := true }
@@ -668,11 +716,20 @@ def explainFailure (declNames : Array Name) (varNamess : Array (Array Name))
     r := r ++ (← explainMutualFailure declNames varNamess rcs)
   return r
 
-end Lean.Elab.WF.GuessLex
+/--
+Shows the termination measure used to the user, and implements `termination_by?`
+-/
+def reportWF (preDefs : Array PreDefinition) (wf : TerminationWF) : MetaM Unit := do
+  let extraParamss := preDefs.map (·.termination.extraParams)
+  let wf' := trimTermWF extraParamss wf
+  for preDef in preDefs, term in wf' do
+    if showInferredTerminationBy.get (← getOptions) then
+      logInfoAt preDef.ref m!"Inferred termination argument:\n{← term.unexpand}"
+    if let some ref := preDef.termination.terminationBy?? then
+      Tactic.TryThis.addSuggestion ref (← term.unexpand)
 
-namespace Lean.Elab.WF
-
-open Lean.Elab.WF.GuessLex
+end GuessLex
+open GuessLex
 
 /--
 Main entry point of this module:
@@ -683,14 +740,17 @@ terminates. See the module doc string for a high-level overview.
 def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
     (fixedPrefixSize : Nat) :
     MetaM TerminationWF := do
-  let extraParamss := preDefs.map (·.termination.extraParams)
   let originalVarNamess ← preDefs.mapM originalVarNames
   let varNamess ← originalVarNamess.mapM (naryVarNames fixedPrefixSize ·)
   let arities := varNamess.map (·.size)
   trace[Elab.definition.wf] "varNames is: {varNamess}"
 
-  let forbiddenArgs ← preDefs.mapM fun preDef =>
-    getForbiddenByTrivialSizeOf fixedPrefixSize preDef
+  let forbiddenArgs ← preDefs.mapM (getForbiddenByTrivialSizeOf fixedPrefixSize)
+  let needsNoSizeOf ←
+    if preDefs.size = 1 then
+      preDefs.mapM (getSizeOfParams fixedPrefixSize)
+    else
+      preDefs.mapM (getNatParams fixedPrefixSize)
 
   -- The list of measures, including the measures that order functions.
   -- The function ordering measures come last
@@ -698,7 +758,9 @@ def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
 
   -- If there is only one plausible measure, use that
   if let #[solution] := measures then
-    return ← buildTermWF originalVarNamess varNamess #[solution]
+    let wf ← buildTermWF originalVarNamess varNamess needsNoSizeOf #[solution]
+    reportWF preDefs wf
+    return wf
 
   -- Collect all recursive calls and extract their context
   let recCalls ← collectRecCalls unaryPreDef fixedPrefixSize arities
@@ -708,15 +770,8 @@ def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
 
   match ← liftMetaM <| solve measures callMatrix with
   | .some solution => do
-    let wf ← buildTermWF originalVarNamess varNamess solution
-
-    let wf' := trimTermWF extraParamss wf
-    for preDef in preDefs, term in wf' do
-      if showInferredTerminationBy.get (← getOptions) then
-        logInfoAt preDef.ref m!"Inferred termination argument:\n{← term.unexpand}"
-      if let some ref := preDef.termination.terminationBy?? then
-        Tactic.TryThis.addSuggestion ref (← term.unexpand)
-
+    let wf ← buildTermWF originalVarNamess varNamess needsNoSizeOf solution
+    reportWF preDefs wf
     return wf
   | .none =>
     let explanation ← explainFailure (preDefs.map (·.declName)) varNamess rcs

src/Lean/Elab/Syntax.lean

@@ -382,7 +382,6 @@ def addMacroScopeIfLocal [MonadQuotation m] [Monad m] (name : Name) (attrKind :
   let name ← match name? with
     | some name => pure name.getId
     | none => addMacroScopeIfLocal (← liftMacroM <| mkNameFromParserSyntax cat syntaxParser) attrKind
-  trace[Meta.debug] "name: {name}"
   let prio ← liftMacroM <| evalOptPrio prio?
   let idRef := (name?.map (·.raw)).getD tk
   let stxNodeKind := (← getCurrNamespace) ++ name

src/Lean/Elab/Tactic/Induction.lean

@@ -534,9 +534,9 @@ private def elabTermForElim (stx : Syntax) : TermElabM Expr := do
       return e
 
 -- `optElimId` is of the form `("using" term)?`
-private def getElimNameInfo (optElimId : Syntax) (targets : Array Expr) (induction : Bool): TacticM ElimInfo := do
+private def getElimNameInfo (optElimId : Syntax) (targets : Array Expr) (induction : Bool) : TacticM ElimInfo := do
   if optElimId.isNone then
-    if let some elimName ← getCustomEliminator? targets then
+    if let some elimName ← getCustomEliminator? targets induction then
       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]`"

src/Lean/Elab/Tactic/Omega/MinNatAbs.lean

@@ -5,8 +5,10 @@ Authors: Scott Morrison
 -/
 prelude
 import Init.BinderPredicates
-import Init.Data.List
-import Init.Data.Option
+import Init.Data.Int.Order
+import Init.Data.List.Lemmas
+import Init.Data.Nat.MinMax
+import Init.Data.Option.Lemmas
 
 /-!
 # `List.nonzeroMinimum`, `List.minNatAbs`, `List.maxNatAbs`

src/Lean/Elab/Tactic/Omega/OmegaM.lean

@@ -7,8 +7,9 @@ prelude
 import Init.Omega.LinearCombo
 import Init.Omega.Int
 import Init.Omega.Logic
-import Init.Data.BitVec
+import Init.Data.BitVec.Basic
 import Lean.Meta.AppBuilder
+import Lean.Meta.Canonicalizer
 
 /-!
 # The `OmegaM` state monad.
@@ -54,7 +55,7 @@ structure State where
   atoms : HashMap Expr Nat := {}
 
 /-- An intermediate layer in the `OmegaM` monad. -/
-abbrev OmegaM' := StateRefT State (ReaderT Context MetaM)
+abbrev OmegaM' := StateRefT State (ReaderT Context CanonM)
 
 /--
 Cache of expressions that have been visited, and their reflection as a linear combination.
@@ -70,7 +71,7 @@ abbrev OmegaM := StateRefT Cache OmegaM'
 
 /-- Run a computation in the `OmegaM` monad, starting with no recorded atoms. -/
 def OmegaM.run (m : OmegaM α) (cfg : OmegaConfig) : MetaM α :=
-  m.run' HashMap.empty |>.run' {} { cfg }
+  m.run' HashMap.empty |>.run' {} { cfg } |>.run
 
 /-- Retrieve the user-specified configuration options. -/
 def cfg : OmegaM OmegaConfig := do pure (← read).cfg
@@ -176,7 +177,7 @@ def analyzeAtom (e : Expr) : OmegaM (HashSet Expr) := do
       | _, (``Fin.val, #[n, i]) =>
         r := r.insert (mkApp2 (.const ``Fin.isLt []) n i)
       | _, (``BitVec.toNat, #[n, x]) =>
-        r := r.insert (mkApp2 (.const ``BitVec.toNat_lt []) n x)
+        r := r.insert (mkApp2 (.const ``BitVec.isLt []) n x)
       | _, _ => pure ()
     return r
   | (``HDiv.hDiv, #[_, _, _, _, x, k]) => match natCast? k with
@@ -244,6 +245,7 @@ Return its index, and, if it is new, a collection of interesting facts about the
 -/
 def lookup (e : Expr) : OmegaM (Nat × Option (HashSet Expr)) := do
   let c ← getThe State
+  let e ← canon e
   match c.atoms.find? e with
   | some i => return (i, none)
   | none =>

src/Lean/Elab/Tactic/Simp.lean

@@ -434,7 +434,7 @@ where
   if tactic.simp.trace.get (← getOptions) then
     traceSimpCall stx usedSimps
 
-def dsimpLocation (ctx : Simp.Context) (loc : Location) : TacticM Unit := do
+def dsimpLocation (ctx : Simp.Context) (simprocs : Simp.SimprocsArray) (loc : Location) : TacticM Unit := do
   match loc with
   | Location.targets hyps simplifyTarget =>
     withMainContext do
@@ -446,7 +446,7 @@ def dsimpLocation (ctx : Simp.Context) (loc : Location) : TacticM Unit := do
 where
   go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM Unit := do
     let mvarId ← getMainGoal
-    let (result?, usedSimps) ← dsimpGoal mvarId ctx (simplifyTarget := simplifyTarget) (fvarIdsToSimp := fvarIdsToSimp)
+    let (result?, usedSimps) ← dsimpGoal mvarId ctx simprocs (simplifyTarget := simplifyTarget) (fvarIdsToSimp := fvarIdsToSimp)
     match result? with
     | none => replaceMainGoal []
     | some mvarId => replaceMainGoal [mvarId]
@@ -454,8 +454,8 @@ where
       mvarId.withContext <| traceSimpCall (← getRef) usedSimps
 
 @[builtin_tactic Lean.Parser.Tactic.dsimp] def evalDSimp : Tactic := fun stx => do
-  let { ctx, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp)
-  dsimpLocation ctx (expandOptLocation stx[5])
+  let { ctx, simprocs, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp)
+  dsimpLocation ctx simprocs (expandOptLocation stx[5])
 
 end Lean.Elab.Tactic
 

src/Lean/Elab/Tactic/SimpTrace.lean

@@ -56,7 +56,8 @@ def mkSimpCallStx (stx : Syntax) (usedSimps : UsedSimps) : MetaM (TSyntax `tacti
   | _ => throwUnsupportedSyntax
 
 /-- Implementation of `dsimp?`. -/
-def dsimpLocation' (ctx : Simp.Context) (loc : Location) : TacticM Simp.UsedSimps := do
+def dsimpLocation' (ctx : Simp.Context) (simprocs : SimprocsArray) (loc : Location) :
+    TacticM Simp.UsedSimps := do
   match loc with
   | Location.targets hyps simplifyTarget =>
     withMainContext do
@@ -69,8 +70,8 @@ where
   /-- Implementation of `dsimp?`. -/
   go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM Simp.UsedSimps := do
     let mvarId ← getMainGoal
-    let (result?, usedSimps) ←
-      dsimpGoal mvarId ctx (simplifyTarget := simplifyTarget) (fvarIdsToSimp := fvarIdsToSimp)
+    let (result?, usedSimps) ← dsimpGoal mvarId ctx simprocs (simplifyTarget := simplifyTarget)
+      (fvarIdsToSimp := fvarIdsToSimp)
     match result? with
     | none => replaceMainGoal []
     | some mvarId => replaceMainGoal [mvarId]
@@ -83,8 +84,9 @@ where
       `(tactic| dsimp!%$tk $(config)? $[only%$o]? $[[$args,*]]? $(loc)?)
     else
       `(tactic| dsimp%$tk $(config)? $[only%$o]? $[[$args,*]]? $(loc)?)
-    let { ctx, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp)
-    let usedSimps ← dsimpLocation' ctx <| (loc.map expandLocation).getD (.targets #[] true)
+    let { ctx, simprocs, .. } ←
+      withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp)
+    let usedSimps ← dsimpLocation' ctx simprocs <| (loc.map expandLocation).getD (.targets #[] true)
     let stx ← mkSimpCallStx stx usedSimps
     addSuggestion tk stx (origSpan? := ← getRef)
   | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Simproc.lean

@@ -26,10 +26,11 @@ def elabSimprocKeys (stx : Syntax) : MetaM (Array Meta.SimpTheoremKey) := do
   let pattern ← elabSimprocPattern stx
   DiscrTree.mkPath pattern simpDtConfig
 
-def checkSimprocType (declName : Name) : CoreM Unit := do
+def checkSimprocType (declName : Name) : CoreM Bool := do
   let decl ← getConstInfo declName
   match decl.type with
-  | .const ``Simproc _ => pure ()
+  | .const ``Simproc _ => pure false
+  | .const ``DSimproc _ => pure true
   | _ => throwError "unexpected type at '{declName}', 'Simproc' expected"
 
 namespace Command
@@ -38,7 +39,7 @@ namespace Command
   let `(simproc_pattern% $pattern => $declName) := stx | throwUnsupportedSyntax
   let declName ← resolveGlobalConstNoOverload declName
   liftTermElabM do
-    checkSimprocType declName
+    discard <| checkSimprocType declName
     let keys ← elabSimprocKeys pattern
     registerSimproc declName keys
 
@@ -46,9 +47,10 @@ namespace Command
   let `(builtin_simproc_pattern% $pattern => $declName) := stx | throwUnsupportedSyntax
   let declName ← resolveGlobalConstNoOverload declName
   liftTermElabM do
-    checkSimprocType declName
+    let dsimp ← checkSimprocType declName
     let keys ← elabSimprocKeys pattern
-    let val := mkAppN (mkConst ``registerBuiltinSimproc) #[toExpr declName, toExpr keys, mkConst declName]
+    let registerProcName := if dsimp then ``registerBuiltinDSimproc else ``registerBuiltinSimproc
+    let val := mkAppN (mkConst registerProcName) #[toExpr declName, toExpr keys, mkConst declName]
     let initDeclName ← mkFreshUserName (declName ++ `declare)
     declareBuiltin initDeclName val
 

src/Lean/Elab/Term.lean

@@ -793,10 +793,10 @@ def mkCoe (expectedType : Expr) (e : Expr) (f? : Option Expr := none) (errorMsgH
     | _            => throwTypeMismatchError errorMsgHeader? expectedType (← inferType e) e f?
 
 /--
-  If `expectedType?` is `some t`, then ensure `t` and `eType` are definitionally equal.
-  If they are not, then try coercions.
+If `expectedType?` is `some t`, then ensures `t` and `eType` are definitionally equal by inserting a coercion if necessary.
 
-  Argument `f?` is used only for generating error messages. -/
+Argument `f?` is used only for generating error messages when inserting coercions fails.
+-/
 def ensureHasType (expectedType? : Option Expr) (e : Expr)
     (errorMsgHeader? : Option String := none) (f? : Option Expr := none) : TermElabM Expr := do
   let some expectedType := expectedType? | return e
@@ -1432,9 +1432,22 @@ def addDotCompletionInfo (stx : Syntax) (e : Expr) (expectedType? : Option Expr)
 def elabTerm (stx : Syntax) (expectedType? : Option Expr) (catchExPostpone := true) (implicitLambda := true) : TermElabM Expr :=
   withRef stx <| elabTermAux expectedType? catchExPostpone implicitLambda stx
 
+/--
+Similar to `Lean.Elab.Term.elabTerm`, but ensures that the type of the elaborated term is `expectedType?`
+by inserting coercions if necessary.
+
+If `errToSorry` is true, then if coercion insertion fails, this function returns `sorry` and logs the error.
+Otherwise, it throws the error.
+-/
 def elabTermEnsuringType (stx : Syntax) (expectedType? : Option Expr) (catchExPostpone := true) (implicitLambda := true) (errorMsgHeader? : Option String := none) : TermElabM Expr := do
   let e ← elabTerm stx expectedType? catchExPostpone implicitLambda
-  withRef stx <| ensureHasType expectedType? e errorMsgHeader?
+  try
+    withRef stx <| ensureHasType expectedType? e errorMsgHeader?
+  catch ex =>
+    if (← read).errToSorry && ex matches .error .. then
+      exceptionToSorry ex expectedType?
+    else
+      throw ex
 
 /-- Execute `x` and return `some` if no new errors were recorded or exceptions were thrown. Otherwise, return `none`. -/
 def commitIfNoErrors? (x : TermElabM α) : TermElabM (Option α) := do

src/Lean/Environment.lean

@@ -230,6 +230,7 @@ inductive KernelException where
   | exprTypeMismatch (env : Environment) (lctx : LocalContext) (expr : Expr) (expectedType : Expr)
   | appTypeMismatch  (env : Environment) (lctx : LocalContext) (app : Expr) (funType : Expr) (argType : Expr)
   | invalidProj      (env : Environment) (lctx : LocalContext) (proj : Expr)
+  | thmTypeIsNotProp (env : Environment) (name : Name) (type : Expr)
   | other            (msg : String)
   | deterministicTimeout
   | excessiveMemory
@@ -769,6 +770,33 @@ partial def importModulesCore (imports : Array Import) : ImportStateM Unit := do
       moduleNames := s.moduleNames.push i.module
     }
 
+/--
+Return `true` if `cinfo₁` and `cinfo₂` are theorems with the same name, universe parameters,
+and types. We allow different modules to prove the same theorem.
+
+Motivation: We want to generate equational theorems on demand and potentially
+in different files, and we want them to have non-private names.
+We may add support for other kinds of definitions in the future. For now, theorems are
+sufficient for our purposes.
+
+We may have to revise this design decision and eagerly generate equational theorems when
+we implement the module system.
+
+Remark: we do not check whether the theorem `value` field match. This feature is useful and
+ensures the proofs for equational theorems do not need to be identical. This decision
+relies on the fact that theorem types are propositions, we have proof irrelevance,
+and theorems are (mostly) opaque in Lean. For `Acc.rec`, we may unfold theorems
+during type-checking, but we are assuming this is not an issue in practice,
+and we are planning to address this issue in the future.
+-/
+private def equivInfo (cinfo₁ cinfo₂ : ConstantInfo) : Bool := Id.run do
+  let .thmInfo tval₁ := cinfo₁ | false
+  let .thmInfo tval₂ := cinfo₂ | false
+  return tval₁.name == tval₂.name
+    && tval₁.type == tval₂.type
+    && tval₁.levelParams == tval₂.levelParams
+    && tval₁.all == tval₂.all
+
 /--
   Construct environment from `importModulesCore` results.
 
@@ -787,11 +815,13 @@ def finalizeImport (s : ImportState) (imports : Array Import) (opts : Options) (
   for h:modIdx in [0:s.moduleData.size] do
     let mod := s.moduleData[modIdx]'h.upper
     for cname in mod.constNames, cinfo in mod.constants do
-      match constantMap.insert' cname cinfo with
-      | (constantMap', replaced) =>
+      match constantMap.insertIfNew cname cinfo with
+      | (constantMap', cinfoPrev?) =>
         constantMap := constantMap'
-        if replaced then
-          throwAlreadyImported s const2ModIdx modIdx cname
+        if let some cinfoPrev := cinfoPrev? then
+          -- Recall that the map has not been modified when `cinfoPrev? = some _`.
+          unless equivInfo cinfoPrev cinfo do
+            throwAlreadyImported s const2ModIdx modIdx cname
       const2ModIdx := const2ModIdx.insert cname modIdx
     for cname in mod.extraConstNames do
       const2ModIdx := const2ModIdx.insert cname modIdx

src/Lean/Expr.lean

@@ -924,7 +924,7 @@ def isRawNatLit : Expr → Bool
   | lit (Literal.natVal _) => true
   | _                      => false
 
-def natLit? : Expr → Option Nat
+def rawNatLit? : Expr → Option Nat
   | lit (Literal.natVal v) => v
   | _                      => none
 
@@ -2003,4 +2003,38 @@ def mkEM (p : Expr) : Expr := mkApp (mkConst ``Classical.em) p
 /-- Return `p ↔ q` -/
 def mkIff (p q : Expr) : Expr := mkApp2 (mkConst ``Iff) p q
 
+private def natAddFn : Expr :=
+  let nat := mkConst ``Nat
+  mkApp4 (mkConst ``HAdd.hAdd [0, 0, 0]) nat nat nat (mkApp2 (mkConst ``instHAdd [0]) nat (mkConst ``instAddNat))
+
+private def natMulFn : Expr :=
+  let nat := mkConst ``Nat
+  mkApp4 (mkConst ``HMul.hMul [0, 0, 0]) nat nat nat (mkApp2 (mkConst ``instHMul [0]) nat (mkConst ``instMulNat))
+
+/-- Given `a : Nat`, returns `Nat.succ a` -/
+def mkNatSucc (a : Expr) : Expr :=
+  mkApp (mkConst ``Nat.succ) a
+
+/-- Given `a b : Nat`, returns `a + b` -/
+def mkNatAdd (a b : Expr) : Expr :=
+  mkApp2 natAddFn a b
+
+/-- Given `a b : Nat`, returns `a * b` -/
+def mkNatMul (a b : Expr) : Expr :=
+  mkApp2 natMulFn a b
+
+private def natLEPred : Expr :=
+  mkApp2 (mkConst ``LE.le [0]) (mkConst ``Nat) (mkConst ``instLENat)
+
+/-- Given `a b : Nat`, return `a ≤ b` -/
+def mkNatLE (a b : Expr) : Expr :=
+  mkApp2 natLEPred a b
+
+private def natEqPred : Expr :=
+  mkApp (mkConst ``Eq [1]) (mkConst ``Nat)
+
+/-- Given `a b : Nat`, return `a = b` -/
+def mkNatEq (a b : Expr) : Expr :=
+  mkApp2 natEqPred a b
+
 end Lean

src/Lean/Message.lean

@@ -366,6 +366,7 @@ def toMessageData (e : KernelException) (opts : Options) : MessageData :=
   | appTypeMismatch  env lctx e fnType argType =>
     mkCtx env lctx opts m!"application type mismatch{indentExpr e}\nargument has type{indentExpr argType}\nbut function has type{indentExpr fnType}"
   | invalidProj env lctx e              => mkCtx env lctx opts m!"(kernel) invalid projection{indentExpr e}"
+  | thmTypeIsNotProp env constName type => mkCtx env {} opts m!"(kernel) type of theorem '{constName}' is not a proposition{indentExpr type}"
   | other msg                           => m!"(kernel) {msg}"
   | deterministicTimeout                => "(kernel) deterministic timeout"
   | excessiveMemory                     => "(kernel) excessive memory consumption detected"

src/Lean/Meta.lean

@@ -48,3 +48,4 @@ import Lean.Meta.Iterator
 import Lean.Meta.LazyDiscrTree
 import Lean.Meta.LitValues
 import Lean.Meta.CheckTactic
+import Lean.Meta.Canonicalizer

src/Lean/Meta/Basic.lean

@@ -1347,6 +1347,16 @@ private def withNewMCtxDepthImp (allowLevelAssignments : Bool) (x : MetaM α) :
   finally
     modify fun s => { s with mctx := saved.mctx, postponed := saved.postponed }
 
+/--
+Removes `fvarId` from the local context, and replaces occurrences of it with `e`.
+It is the responsibility of the caller to ensure that `e` is well-typed in the context
+of any occurrence of `fvarId`.
+-/
+def withReplaceFVarId {α} (fvarId : FVarId) (e : Expr) : MetaM α → MetaM α :=
+  withReader fun ctx => { ctx with
+    lctx := ctx.lctx.replaceFVarId fvarId e
+    localInstances := ctx.localInstances.erase fvarId }
+
 /--
   `withNewMCtxDepth k` executes `k` with a higher metavariable context depth,
   where metavariables created outside the `withNewMCtxDepth` (with a lower depth) cannot be assigned.

src/Lean/Meta/Canonicalizer.lean

@@ -0,0 +1,146 @@
+/-
+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.Util.ShareCommon
+import Lean.Data.HashMap
+import Lean.Meta.Basic
+import Lean.Meta.FunInfo
+
+namespace Lean.Meta
+namespace Canonicalizer
+
+/-!
+Applications have implicit arguments. Thus, two terms that may look identical when pretty-printed can be structurally different.
+For example, `@id (Id Nat) x` and `@id Nat x` are structurally different but are both pretty-printed as `id x`.
+Moreover, these two terms are definitionally equal since `Id Nat` reduces to `Nat`. This may create situations
+that are counterintuitive to our users. Furthermore, several tactics (e.g., `omega`) need to collect unique atoms in a goal.
+One simple approach is to maintain a list of atoms found so far, and whenever a new atom is discovered, perform a
+linear scan to test whether it is definitionally equal to a previously found one. However, this method is too costly,
+even if the definitional equality test were inexpensive.
+
+This module aims to efficiently identify terms that are structurally different, definitionally equal, and structurally equal
+when we disregard implicit arguments like `@id (Id Nat) x` and `@id Nat x`. The procedure is straightforward. For each atom,
+we create a new abstracted atom by erasing all implicit information. We refer to this abstracted atom as a 'key.' For the two
+terms mentioned, the key would be `@id _ x`, where `_` denotes a placeholder for a dummy term. To preserve any
+pre-existing directed acyclic graph (DAG) structure and prevent exponential blowups while constructing the key, we employ
+unsafe techniques, such as pointer equality. Additionally, we maintain a mapping from keys to lists of terms, where each
+list contains terms sharing the same key but not definitionally equal. We posit that these lists will be small in practice.
+-/
+
+/--
+Auxiliary structure for creating a pointer-equality mapping from `Expr` to `Key`.
+We use this mapping to ensure we preserve the dag-structure of input expressions.
+-/
+structure ExprVisited where
+  e : Expr
+  deriving Inhabited
+
+unsafe instance : BEq ExprVisited where
+  beq a b := ptrAddrUnsafe a == ptrAddrUnsafe b
+
+unsafe instance : Hashable ExprVisited where
+  hash a := USize.toUInt64 (ptrAddrUnsafe a)
+
+abbrev Key := ExprVisited
+
+/--
+State for the `CanonM` monad.
+-/
+structure State where
+  /-- "Set" of all keys created so far. This is a hash-consing helper structure available in Lean. -/
+  keys       : ShareCommon.State.{0} Lean.ShareCommon.objectFactory := ShareCommon.State.mk Lean.ShareCommon.objectFactory
+  /-- Mapping from `Expr` to `Key`. See comment at `ExprVisited`. -/
+  -- We use `HashMapImp` to ensure we don't have to tag `State` as `unsafe`.
+  cache      : HashMapImp ExprVisited Key := mkHashMapImp
+  /--
+  Given a key `k` and `keyToExprs.find? k = some es`, we have that all `es` share key `k`, and
+  are not definitionally equal modulo the transparency setting used. -/
+  keyToExprs : HashMapImp Key (List Expr) := mkHashMapImp
+
+instance : Inhabited State where
+  default := {}
+
+abbrev CanonM := ReaderT TransparencyMode $ StateRefT State MetaM
+
+/--
+The definitionally equality tests are performed using the given transparency mode.
+We claim `TransparencyMode.instances` is a good setting for most applications.
+-/
+def CanonM.run (x : CanonM α) (transparency := TransparencyMode.instances) : MetaM α :=
+  StateRefT'.run' (x transparency) {}
+
+private def shareCommon (a : α) : CanonM α :=
+  modifyGet fun { keys, cache, keyToExprs } =>
+    let (a, keys) := ShareCommon.State.shareCommon keys a
+    (a, { keys, cache, keyToExprs })
+
+private partial def mkKey (e : Expr) : CanonM Key := do
+  if let some key := unsafe (← get).cache.find? { e } then
+    return key
+  else
+    let key ← match e with
+      | .sort .. | .fvar .. | .bvar .. | .const .. | .lit .. =>
+        pure { e := (← shareCommon e) }
+      | .mvar .. =>
+        -- We instantiate assigned metavariables because the
+        -- pretty-printer also instantiates them.
+        let eNew ← instantiateMVars e
+        if eNew == e then pure { e := (← shareCommon e) }
+        else mkKey eNew
+      | .mdata _ a => mkKey a
+      | .app .. =>
+        let f := (← mkKey e.getAppFn).e
+        if f.isMVar then
+          let eNew ← instantiateMVars e
+          unless eNew == e do
+            return (← mkKey eNew)
+        let info ← getFunInfo f
+        let args ← e.getAppArgs.mapIdxM fun i arg => do
+          if h : i < info.paramInfo.size then
+            let info := info.paramInfo[i]
+            if info.isExplicit then
+              pure (← mkKey arg).e
+            else
+              pure (mkSort 0) -- some dummy value for erasing implicit
+          else
+            pure (← mkKey arg).e
+        pure { e := (← shareCommon (mkAppN f args)) }
+      | .lam n t b i =>
+        pure { e := (← shareCommon (.lam n (← mkKey t).e (← mkKey b).e i)) }
+      | .forallE n t b i =>
+        pure { e := (← shareCommon (.forallE n (← mkKey t).e (← mkKey b).e i)) }
+      | .letE n t v b d =>
+        pure { e := (← shareCommon (.letE n (← mkKey t).e (← mkKey v).e (← mkKey b).e d)) }
+      | .proj t i s =>
+        pure { e := (← shareCommon (.proj t i (← mkKey s).e)) }
+    unsafe modify fun { keys, cache, keyToExprs} => { keys, keyToExprs, cache := cache.insert { e } key |>.1 }
+    return key
+
+/--
+"Canonicalize" the given expression.
+-/
+def canon (e : Expr) : CanonM Expr := do
+  let k ← mkKey e
+  -- Find all expressions canonicalized before that have the same key.
+  if let some es' := unsafe (← get).keyToExprs.find? k then
+    withTransparency (← read) do
+      for e' in es' do
+        -- Found an expression `e'` that is definitionally equal to `e` and share the same key.
+        if (← isDefEq e e') then
+          return e'
+      -- `e` is not definitionally equal to any expression in `es'`. We claim this should be rare.
+      unsafe modify fun { keys, cache, keyToExprs } => { keys, cache, keyToExprs := keyToExprs.insert k (e :: es') |>.1 }
+      return e
+  else
+    -- `e` is the first expression we found with key `k`.
+    unsafe modify fun { keys, cache, keyToExprs } => { keys, cache, keyToExprs := keyToExprs.insert k [e] |>.1 }
+    return e
+
+end Canonicalizer
+
+export Canonicalizer (CanonM canon)
+
+end Lean.Meta

src/Lean/Meta/Coe.lean

@@ -4,7 +4,6 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Lean.Meta.WHNF
 import Lean.Meta.Transform
 import Lean.Meta.SynthInstance
 import Lean.Meta.AppBuilder

src/Lean/Meta/CtorRecognizer.lean

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Lean.Meta.LitValues
+import Lean.Meta.Offset
 
 namespace Lean.Meta
 
@@ -64,9 +65,17 @@ def constructorApp? (e : Expr) : MetaM (Option (ConstructorVal × Array Expr)) :
 
 /--
 Similar to `constructorApp?`, but on failure it puts `e` in WHNF and tries again.
+It also `isOffset?`
 -/
 def constructorApp'? (e : Expr) : MetaM (Option (ConstructorVal × Array Expr)) := do
-  if let some r ← constructorApp? e then
+  if let some (e, k) ← isOffset? e then
+    if k = 0 then
+      return none
+    else
+      let .ctorInfo val ← getConstInfo ``Nat.succ | return none
+      if k = 1 then return some (val, #[e])
+      else return some (val, #[mkNatAdd e (toExpr (k-1))])
+  else if let some r ← constructorApp? e then
     return some r
   else
     constructorApp? (← whnf e)

src/Lean/Meta/DiscrTree.lean

@@ -69,21 +69,36 @@ instance : LT Key := ⟨fun a b => Key.lt a b⟩
 instance (a b : Key) : Decidable (a < b) := inferInstanceAs (Decidable (Key.lt a b))
 
 def Key.format : Key → Format
-  | .star                   => "*"
-  | .other                  => "◾"
-  | .lit (Literal.natVal v) => Std.format v
-  | .lit (Literal.strVal v) => repr v
-  | .const k _              => Std.format k
-  | .proj s i _             => Std.format s ++ "." ++ Std.format i
-  | .fvar k _               => Std.format k.name
-  | .arrow                  => "→"
+  | .star            => "*"
+  | .other           => "◾"
+  | .lit (.natVal v) => Std.format v
+  | .lit (.strVal v) => repr v
+  | .const k _       => Std.format k
+  | .proj s i _      => Std.format s ++ "." ++ Std.format i
+  | .fvar k _        => Std.format k.name
+  | .arrow           => "→"
 
 instance : ToFormat Key := ⟨Key.format⟩
 
 def Key.arity : Key → Nat
   | .const _ a  => a
   | .fvar _ a   => a
-  | .arrow      => 2
+  /-
+  Remark: `.arrow` used to have arity 2, and was used to encode non-dependent arrows.
+  However, this feature was a recurrent source of bugs. For example, a theorem about
+  a dependent arrow can be applied to a non-dependent one. The reverse direction may
+  also happen. See issue #2835.
+  ```
+  -- A theorem about the non-dependent arrow `a → a`
+  theorem imp_self' {a : Prop} : (a → a) ↔ True := ⟨fun _ => trivial, fun _ => id⟩
+
+  -- can be applied to the dependent one `(h : P a) → P (f h)`.
+  example {α : Prop} {P : α → Prop} {f : ∀ {a}, P a → α} {a : α} : (h : P a) → P (f h) := by
+    simp only [imp_self']
+  ```
+  Thus, we now index dependent and non-dependent arrows using the key `.arrow` with arity 0.
+  -/
+  | .arrow      => 0
   | .proj _ _ a => 1 + a
   | _           => 0
 
@@ -270,39 +285,12 @@ partial def reduce (e : Expr) (config : WhnfCoreConfig) : MetaM Expr := do
 -/
 private def isBadKey (fn : Expr) : Bool :=
   match fn with
-  | .lit ..   => false
-  | .const .. => false
-  | .fvar ..  => false
-  | .proj ..  => false
-  | .forallE _ _ b _ => b.hasLooseBVars
-  | _ => true
-
-/--
-  Try to eliminate loose bound variables by performing beta-reduction.
-  We use this method when processing terms in discrimination trees.
-  These trees distinguish dependent arrows from nondependent ones.
-  Recall that dependent arrows are indexed as `.other`, but nondependent arrows as `.arrow ..`.
-  Motivation: we want to "discriminate" implications and simple arrows in our index.
-
-  Now suppose we add the term `Foo (Nat → Nat)` to our index. The nested arrow appears as
-  `.arrow ..`. Then, suppose we want to check whether the index contains
-  `(x : Nat) → (fun _ => Nat) x`, but it will fail to retrieve `Foo (Nat → Nat)` because
-  it assumes the nested arrow is a dependent one and uses `.other`.
-
-  We use this method to address this issue by beta-reducing terms containing loose bound variables.
-  See issue #2232.
-
-  Remark: we expect the performance impact will be minimal.
--/
-private def elimLooseBVarsByBeta (e : Expr) : CoreM Expr :=
-  Core.transform e
-    (pre := fun e => do
-      if !e.hasLooseBVars then
-        return .done e
-      else if e.isHeadBetaTarget then
-        return .visit e.headBeta
-      else
-        return .continue)
+  | .lit ..     => false
+  | .const ..   => false
+  | .fvar ..    => false
+  | .proj ..    => false
+  | .forallE .. => false
+  | _           => true
 
 /--
   Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
@@ -326,7 +314,6 @@ def reduceDT (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM Expr :=
 
 /- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/
 
-
 /--
 Append `n` wildcards to `todo`
 -/
@@ -390,15 +377,8 @@ private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : Whnf
         return (.other, todo)
       else
         return (.star, todo)
-    | .forallE _ d b _ =>
-      -- See comment at elimLooseBVarsByBeta
-      let b ← if b.hasLooseBVars then elimLooseBVarsByBeta b else pure b
-      if b.hasLooseBVars then
-        return (.other, todo)
-      else
-        return (.arrow, todo.push d |>.push b)
-    | _ =>
-      return (.other, todo)
+    | .forallE .. => return (.arrow, todo)
+    | _ => return (.other, todo)
 
 @[inherit_doc pushArgs]
 partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) (config : WhnfCoreConfig) (noIndexAtArgs : Bool) : MetaM (Array Key) := do
@@ -556,15 +536,8 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
   | .proj s i a .. =>
     let nargs := e.getAppNumArgs
     return (.proj s i nargs, #[a] ++ e.getAppRevArgs)
-  | .forallE _ d b _ =>
-    -- See comment at elimLooseBVarsByBeta
-    let b ← if b.hasLooseBVars then elimLooseBVarsByBeta b else pure b
-    if b.hasLooseBVars then
-      return (.other, #[])
-    else
-      return (.arrow, #[d, b])
-  | _ =>
-    return (.other, #[])
+  | .forallE .. => return (.arrow, #[])
+  | _ => return (.other, #[])
 
 private abbrev getMatchKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) :=
   getKeyArgs e (isMatch := true) (root := root) (config := config)
@@ -608,12 +581,6 @@ private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Arr
       let result ← visitStar result
       match k with
       | .star  => return result
-      /-
-        Note: dep-arrow vs arrow
-        Recall that dependent arrows are `(Key.other, #[])`, and non-dependent arrows are `(Key.arrow, #[a, b])`.
-        A non-dependent arrow may be an instance of a dependent arrow (stored at `DiscrTree`). Thus, we also visit the `Key.other` child.
-      -/
-      | .arrow => visitNonStar .other #[] (← visitNonStar k args result)
       | _      => visitNonStar k args result
 
 private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) (config : WhnfCoreConfig) : MetaM (Array α) :=
@@ -627,8 +594,6 @@ private def getMatchCore (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig)
     let (k, args) ← getMatchKeyArgs e (root := true) config
     match k with
     | .star  => return (k, result)
-    /- See note about "dep-arrow vs arrow" at `getMatchLoop` -/
-    | .arrow => return (k, (← getMatchRoot d k args (← getMatchRoot d .other #[] result config) config))
     | _      => return (k, (← getMatchRoot d k args result config))
 
 /--
@@ -708,8 +673,6 @@ where
           | some c => process 0 (todo ++ args) c.2 result
         match k with
         | .star  => cs.foldlM (init := result) fun result ⟨k, c⟩ => process k.arity todo c result
-        -- See comment a `getMatch` regarding non-dependent arrows vs dependent arrows
-        | .arrow => visitNonStar .other #[] (← visitNonStar k args (← visitStar result))
         | _      => visitNonStar k args (← visitStar result)
 
 namespace Trie

src/Lean/Meta/Injective.lean

@@ -26,8 +26,10 @@ private def mkAnd? (args : Array Expr) : Option Expr := Id.run do
 
 def elimOptParam (type : Expr) : CoreM Expr := do
   Core.transform type fun e =>
-    let_expr optParam _ a := e | return .continue
-    return TransformStep.visit a
+    if e.isAppOfArity ``optParam 2 then
+      return TransformStep.visit (e.getArg! 0)
+    else
+      return .continue
 
 private partial def mkInjectiveTheoremTypeCore? (ctorVal : ConstructorVal) (useEq : Bool) : MetaM (Option Expr) := do
   let us := ctorVal.levelParams.map mkLevelParam

src/Lean/Meta/LazyDiscrTree.lean

@@ -700,35 +700,42 @@ private structure ImportFailure where
 
 /-- Information generation from imported modules. -/
 private structure ImportData where
-  cache : IO.Ref (Lean.Meta.Cache)
   errors : IO.Ref (Array ImportFailure)
 
 private def ImportData.new : BaseIO ImportData := do
-  let cache ← IO.mkRef {}
   let errors ← IO.mkRef #[]
-  pure { cache, errors }
+  pure { errors }
+
+structure Cache where
+  ngen : NameGenerator
+  core : Lean.Core.Cache
+  meta : Lean.Meta.Cache
+
+def Cache.empty (ngen : NameGenerator) : Cache := { ngen := ngen, core := {}, meta := {} }
 
 private def addConstImportData
     (env : Environment)
     (modName : Name)
     (d : ImportData)
+    (cacheRef : IO.Ref Cache)
     (tree : PreDiscrTree α)
     (act : Name → ConstantInfo → MetaM (Array (InitEntry α)))
     (name : Name) (constInfo : ConstantInfo) : BaseIO (PreDiscrTree α) := do
   if constInfo.isUnsafe then return tree
   if !allowCompletion env name then return tree
-  let mstate : Meta.State := { cache := ←d.cache.get }
-  d.cache.set {}
+  let { ngen, core := core_cache, meta := meta_cache } ← cacheRef.get
+  let mstate : Meta.State := { cache := meta_cache }
+  cacheRef.set (Cache.empty ngen)
   let ctx : Meta.Context := { config := { transparency := .reducible } }
   let cm := (act name constInfo).run ctx mstate
   let cctx : Core.Context := {
     fileName := default,
     fileMap := default
   }
-  let cstate : Core.State := {env}
+  let cstate : Core.State := {env, cache := core_cache, ngen}
   match ←(cm.run cctx cstate).toBaseIO with
-  | .ok ((a, ms), _) =>
-    d.cache.set ms.cache
+  | .ok ((a, ms), cs) =>
+    cacheRef.set { ngen := cs.ngen, core := cs.cache, meta := ms.cache }
     pure <| a.foldl (fun t e => t.push e.key e.entry) tree
   | .error e =>
     let i : ImportFailure := {
@@ -771,6 +778,7 @@ private def toFlat (d : ImportData) (tree : PreDiscrTree α) :
 private partial def loadImportedModule (env : Environment)
     (act : Name → ConstantInfo → MetaM (Array (InitEntry α)))
     (d : ImportData)
+    (cacheRef : IO.Ref Cache)
     (tree : PreDiscrTree α)
     (mname : Name)
     (mdata : ModuleData)
@@ -778,21 +786,22 @@ private partial def loadImportedModule (env : Environment)
   if h : i < mdata.constNames.size then
     let name := mdata.constNames[i]
     let constInfo  := mdata.constants[i]!
-    let tree ← addConstImportData env mname d tree act name constInfo
-    loadImportedModule env act d tree mname mdata (i+1)
+    let tree ← addConstImportData env mname d cacheRef tree act name constInfo
+    loadImportedModule env act d cacheRef tree mname mdata (i+1)
   else
     pure tree
 
-private def createImportedEnvironmentSeq (env : Environment)
+private def createImportedEnvironmentSeq (ngen : NameGenerator) (env : Environment)
     (act : Name → ConstantInfo → MetaM (Array (InitEntry α)))
-    (start stop : Nat) : BaseIO (InitResults α) :=
-      do go (← ImportData.new) {} start stop
-    where go d (tree : PreDiscrTree α) (start stop : Nat) : BaseIO _ := do
+    (start stop : Nat) : BaseIO (InitResults α) := do
+      let cacheRef ← IO.mkRef (Cache.empty ngen)
+      go (← ImportData.new) cacheRef {} start stop
+    where go d cacheRef (tree : PreDiscrTree α) (start stop : Nat) : BaseIO _ := do
             if start < stop then
               let mname := env.header.moduleNames[start]!
               let mdata := env.header.moduleData[start]!
-              let tree ← loadImportedModule env act d tree mname mdata
-              go d tree (start+1) stop
+              let tree ← loadImportedModule env act d cacheRef tree mname mdata
+              go d cacheRef tree (start+1) stop
             else
               toFlat d tree
     termination_by stop - start
@@ -802,29 +811,31 @@ private def combineGet [Append α] (z : α) (tasks : Array (Task α)) : α :=
   tasks.foldl (fun x t => x ++ t.get) (init := z)
 
 /-- Create an imported environment for tree. -/
-def createImportedEnvironment (env : Environment)
+def createImportedEnvironment (ngen : NameGenerator) (env : Environment)
     (act : Name → ConstantInfo → MetaM (Array (InitEntry α)))
     (constantsPerTask : Nat := 1000) :
     EIO Exception (LazyDiscrTree α) := do
   let n := env.header.moduleData.size
   let rec
     /-- Allocate constants to tasks according to `constantsPerTask`. -/
-    go tasks start cnt idx := do
+    go ngen tasks start cnt idx := do
       if h : idx < env.header.moduleData.size then
         let mdata := env.header.moduleData[idx]
         let cnt := cnt + mdata.constants.size
         if cnt > constantsPerTask then
-          let t ← createImportedEnvironmentSeq env act start (idx+1) |>.asTask
-          go (tasks.push t) (idx+1) 0 (idx+1)
+          let (childNGen, ngen) := ngen.mkChild
+          let t ← createImportedEnvironmentSeq childNGen env act start (idx+1) |>.asTask
+          go ngen (tasks.push t) (idx+1) 0 (idx+1)
         else
-          go tasks start cnt (idx+1)
+          go ngen tasks start cnt (idx+1)
       else
         if start < n then
-          tasks.push <$> (createImportedEnvironmentSeq env act start n).asTask
+          let (childNGen, _) := ngen.mkChild
+          tasks.push <$> (createImportedEnvironmentSeq childNGen env act start n).asTask
         else
           pure tasks
     termination_by env.header.moduleData.size - idx
-  let tasks ← go #[] 0 0 0
+  let tasks ← go ngen #[] 0 0 0
   let r := combineGet default tasks
   if p : r.errors.size > 0 then
     throw r.errors[0].exception

src/Lean/Meta/Match/MatchEqs.lean

@@ -110,6 +110,8 @@ def unfoldNamedPattern (e : Expr) : MetaM Expr := do
   - `type` is the resulting type for `altType`.
 
   We use the `mask` to build the splitter proof. See `mkSplitterProof`.
+
+  This can be used to use the alternative of a match expression in its splitter.
 -/
 partial def forallAltTelescope (altType : Expr) (altNumParams numDiscrEqs : Nat)
     (k : (ys : Array Expr) → (eqs : Array Expr) → (args : Array Expr) → (mask : Array Bool) → (type : Expr) → MetaM α)
@@ -132,9 +134,11 @@ where
                let some k  := args.getIdx? lhs | unreachable!
                let mask    := mask.set! k false
                let args    := args.map fun arg => if arg == lhs then rhs else arg
-               let args    := args.push (← mkEqRefl rhs)
+               let arg     ← mkEqRefl rhs
                let typeNew := typeNew.replaceFVar lhs rhs
-               return (← go ys eqs args (mask.push false) (i+1) typeNew)
+               return ← withReplaceFVarId lhs.fvarId! rhs do
+                withReplaceFVarId y.fvarId! arg do
+                  go ys eqs (args.push arg) (mask.push false) (i+1) typeNew
           go (ys.push y) eqs (args.push y) (mask.push true) (i+1) typeNew
       else
         let arg ← if let some (_, _, rhs) ← matchEq? d then
@@ -152,7 +156,9 @@ where
          they are not eagerly evaluated. -/
       if ys.size == 1 then
         if (← inferType ys[0]!).isConstOf ``Unit && !(← dependsOn type ys[0]!.fvarId!) then
-          return (← k #[] #[] #[mkConst ``Unit.unit] #[false] type)
+          let rhs := mkConst ``Unit.unit
+          return ← withReplaceFVarId ys[0]!.fvarId! rhs do
+          return (← k #[] #[] #[rhs] #[false] type)
       k ys eqs args mask type
 
   isNamedPatternProof (type : Expr) (h : Expr) : Bool :=

src/Lean/Meta/Match/MatcherApp/Transform.lean

@@ -156,4 +156,273 @@ def refineThrough? (matcherApp : MatcherApp) (e : Expr) :
   catch _ =>
     return none
 
+
+/--
+Given `n` and a non-dependent function type `α₁ → α₂ → ... → αₙ → Sort u`, returns the
+types `α₁, α₂, ..., αₙ`. Throws an error if there are not at least `n` argument types or if a
+later argument type depends on a prior one (i.e., it's a dependent function type).
+
+This can be used to infer the expected type of the alternatives when constructing a `MatcherApp`.
+-/
+-- TODO: Which is the natural module for this?
+def arrowDomainsN (n : Nat) (type : Expr) : MetaM (Array Expr) := do
+  let mut type := type
+  let mut ts := #[]
+  for i in [:n] do
+    type ← whnfForall type
+    let Expr.forallE _ α β _ ← pure type | throwError "expected {n} arguments, got {i}"
+    if β.hasLooseBVars then throwError "unexpected dependent type"
+    ts := ts.push α
+    type := β
+  return ts
+
+/--
+Sets the user name of the FVars in the local context according to the given array of names.
+
+If they differ in size the shorter size wins.
+-/
+def withUserNames {α} (fvars : Array Expr) (names : Array Name) (k : MetaM α ) : MetaM α := do
+  let lctx := (Array.zip fvars names).foldl (init := ← (getLCtx)) fun lctx (fvar, name) =>
+    lctx.setUserName fvar.fvarId! name
+  withTheReader Meta.Context (fun ctx => { ctx with lctx }) k
+
+
+/--
+Performs a possibly type-changing transformation to a `MatcherApp`.
+
+* `onParams` is run on each parameter and discriminant
+* `onMotive` runs on the body of the motive, and is passed the motive parameters
+  (one for each `MatcherApp.discrs`)
+* `onAlt` runs on each alternative, and is passed the expected type of the alternative,
+   as inferred from the motive
+* `onRemaining` runs on the remaining arguments (and may change their number)
+
+If `useSplitter` is true, the matcher is replaced with the splitter.
+NB: Not all operations on `MatcherApp` can handle one `matcherName` is a splitter.
+
+The array `addEqualities`, if provided, indicates for which of the discriminants an equality
+connecting the discriminant to the parameters of the alternative (like in `match h : x with …`)
+should be added (if it is isn't already there).
+
+This function works even if the the type of alternatives do *not* fit the inferred type. This
+allows you to post-process the `MatcherApp` with `MatcherApp.inferMatchType`, which will
+infer a type, given all the alternatives.
+-/
+def transform (matcherApp : MatcherApp)
+    (useSplitter := false)
+    (addEqualities : Array Bool := mkArray matcherApp.discrs.size false)
+    (onParams : Expr → MetaM Expr := pure)
+    (onMotive : Array Expr → Expr → MetaM Expr := fun _ e => pure e)
+    (onAlt : Expr → Expr → MetaM Expr := fun _ e => pure e)
+    (onRemaining : Array Expr → MetaM (Array Expr) := pure) :
+    MetaM MatcherApp := do
+
+  if addEqualities.size != matcherApp.discrs.size then
+    throwError "MatcherApp.transform: addEqualities has wrong size"
+
+  -- Do not add equalities when the matcher already does so
+  let addEqualities := Array.zipWith addEqualities matcherApp.discrInfos fun b di =>
+    if di.hName?.isSome then false else b
+
+  -- We also handle CasesOn applications here, and need to treat them specially in a
+  -- few places.
+  -- TODO: Expand MatcherApp with the necessary fields to make this more uniform
+  -- (in particular, include discrEq and whether there is a splitter)
+  let isCasesOn := isCasesOnRecursor (← getEnv) matcherApp.matcherName
+
+  let numDiscrEqs ←
+    if isCasesOn then pure 0 else
+    match ← getMatcherInfo? matcherApp.matcherName with
+    | some info => pure info.getNumDiscrEqs
+    | none      => throwError "matcher {matcherApp.matcherName} has no MatchInfo found"
+
+  let params' ← matcherApp.params.mapM onParams
+  let discrs' ← matcherApp.discrs.mapM onParams
+
+
+  let (motive', uElim) ← lambdaTelescope matcherApp.motive fun motiveArgs motiveBody => do
+    unless motiveArgs.size == matcherApp.discrs.size do
+      throwError "unexpected matcher application, motive must be lambda expression with #{matcherApp.discrs.size} arguments"
+    let mut motiveBody' ← onMotive motiveArgs motiveBody
+
+    -- Prepend (x = e) → to the motive when an equality is requested
+    for arg in motiveArgs, discr in discrs', b in addEqualities do if b then
+      motiveBody' ← mkArrow (← mkEq discr arg) motiveBody'
+
+    return (← mkLambdaFVars motiveArgs motiveBody', ← getLevel motiveBody')
+
+  let matcherLevels ← match matcherApp.uElimPos? with
+    | none     => pure matcherApp.matcherLevels
+    | some pos => pure <| matcherApp.matcherLevels.set! pos uElim
+
+  -- We pass `Eq.refl`s for all the equations we added as extra arguments
+  -- (and count them along the way)
+  let mut remaining' := #[]
+  let mut extraEqualities : Nat := 0
+  for discr in discrs'.reverse, b in addEqualities.reverse do if b then
+    remaining' := remaining'.push (← mkEqRefl discr)
+    extraEqualities := extraEqualities + 1
+
+  if useSplitter && !isCasesOn then
+    -- We replace the matcher with the splitter
+    let matchEqns ← Match.getEquationsFor matcherApp.matcherName
+    let splitter := matchEqns.splitterName
+
+    let aux1 := mkAppN (mkConst matcherApp.matcherName matcherLevels.toList) params'
+    let aux1 := mkApp aux1 motive'
+    let aux1 := mkAppN aux1 discrs'
+    unless (← isTypeCorrect aux1) do
+      logError m!"failed to transform matcher, type error when constructing new motive:{indentExpr aux1}"
+      check aux1
+    let origAltTypes ← arrowDomainsN matcherApp.alts.size (← inferType aux1)
+
+    let aux2 := mkAppN (mkConst splitter matcherLevels.toList) params'
+    let aux2 := mkApp aux2 motive'
+    let aux2 := mkAppN aux2 discrs'
+    unless (← isTypeCorrect aux2) do
+      logError m!"failed to transform matcher, type error when constructing new motive:{indentExpr aux2}"
+      check aux2
+    let altTypes ← arrowDomainsN matcherApp.alts.size (← inferType aux2)
+
+    let mut alts' := #[]
+    for alt in matcherApp.alts,
+        numParams in matcherApp.altNumParams,
+        splitterNumParams in matchEqns.splitterAltNumParams,
+        origAltType in origAltTypes,
+        altType in altTypes do
+      let alt' ← Match.forallAltTelescope origAltType (numParams - numDiscrEqs) 0 fun ys _eqs args _mask _bodyType => do
+        let altType ← instantiateForall altType ys
+        -- The splitter inserts its extra paramters after the first ys.size parameters, before
+        -- the parameters for the numDiscrEqs
+        forallBoundedTelescope altType (splitterNumParams - ys.size) fun ys2 altType => do
+          forallBoundedTelescope altType numDiscrEqs fun ys3 altType => do
+            forallBoundedTelescope altType extraEqualities fun ys4 altType => do
+              let alt ← try instantiateLambda alt (args ++ ys3)
+                        catch _ => throwError "unexpected matcher application, insufficient number of parameters in alternative"
+              let alt' ← onAlt altType alt
+              mkLambdaFVars (ys ++ ys2 ++ ys3 ++ ys4) alt'
+      alts' := alts'.push alt'
+
+    remaining' := remaining' ++ (← onRemaining matcherApp.remaining)
+
+    return { matcherApp with
+      matcherName   := splitter
+      matcherLevels := matcherLevels
+      params        := params'
+      motive        := motive'
+      discrs        := discrs'
+      altNumParams  := matchEqns.splitterAltNumParams.map (· + extraEqualities)
+      alts          := alts'
+      remaining     := remaining'
+    }
+  else
+    let aux := mkAppN (mkConst matcherApp.matcherName matcherLevels.toList) params'
+    let aux := mkApp aux motive'
+    let aux := mkAppN aux discrs'
+    unless (← isTypeCorrect aux) do
+      -- check aux
+      logError m!"failed to transform matcher, type error when constructing new motive:{indentExpr aux}"
+      check aux
+    let altTypes ← arrowDomainsN matcherApp.alts.size (← inferType aux)
+
+    let mut alts' := #[]
+    for alt in matcherApp.alts,
+        numParams in matcherApp.altNumParams,
+        altType in altTypes do
+      let alt' ← forallBoundedTelescope altType numParams fun xs altType => do
+        forallBoundedTelescope altType extraEqualities fun ys4 altType => do
+          -- we should try to preserve the variable names in the alternative
+          let names ← lambdaTelescope alt fun xs _ => xs.mapM (·.fvarId!.getUserName)
+          withUserNames xs names do
+            let alt ← instantiateLambda alt xs
+            let alt' ← onAlt altType alt
+            mkLambdaFVars (xs ++ ys4) alt'
+      alts' := alts'.push alt'
+
+    remaining' := remaining' ++ (← onRemaining matcherApp.remaining)
+
+    return { matcherApp with
+      matcherLevels := matcherLevels
+      params        := params'
+      motive        := motive'
+      discrs        := discrs'
+      altNumParams  := matcherApp.altNumParams.map (· + extraEqualities)
+      alts          := alts'
+      remaining     := remaining'
+    }
+
+
+
+/--
+Given a `MatcherApp`, replaces the motive with one that is inferred from the actual types of the
+alternatives.
+
+For example, given
+```
+(match (motive := Nat → Unit → ?) n with
+ 0 => 1
+ _ => true) ()
+```
+(for any `?`; the motive’s result type be ignored) will give this type
+```
+(match n with
+ | 0 => Nat
+ | _ => Bool)
+```
+
+The given `MatcherApp` must not use a splitter in `matcherName`.
+The resulting expression *will* use the splitter corresponding to `matcherName` (this is necessary
+for the construction).
+
+Interally, this needs to reduce the matcher in a given branch; this is done using
+`Split.simpMatchTarget`.
+-/
+def inferMatchType (matcherApp : MatcherApp) : MetaM MatcherApp := do
+  -- In matcherApp.motive, replace the (dummy) matcher body with a type
+  -- derived from the inferred types of the alterantives
+  let nExtra := matcherApp.remaining.size
+  matcherApp.transform (useSplitter := true)
+    (onMotive := fun motiveArgs body => do
+      let extraParams ← arrowDomainsN nExtra body
+      let propMotive ← mkLambdaFVars motiveArgs (.sort levelZero)
+      let propAlts ← matcherApp.alts.mapM fun termAlt =>
+        lambdaTelescope termAlt fun xs termAltBody => do
+          -- We have alt parameters and parameters corresponding to the extra args
+          let xs1 := xs[0 : xs.size - nExtra]
+          let xs2 := xs[xs.size - nExtra : xs.size]
+          -- logInfo m!"altIH: {xs} => {altIH}"
+          let altType ← inferType termAltBody
+          for x in xs2 do
+            if altType.hasAnyFVar (· == x.fvarId!) then
+              throwError "Type {altType} of alternative {termAlt} still depends on {x}"
+          -- logInfo m!"altIH type: {altType}"
+          mkLambdaFVars xs1 altType
+      let matcherLevels ← match matcherApp.uElimPos? with
+        | none     => pure matcherApp.matcherLevels
+        | some pos => pure <| matcherApp.matcherLevels.set! pos levelOne
+      let typeMatcherApp := { matcherApp with
+        motive := propMotive
+        matcherLevels := matcherLevels
+        discrs := motiveArgs
+        alts := propAlts
+        remaining := #[]
+      }
+      mkArrowN extraParams typeMatcherApp.toExpr
+    )
+    (onAlt := fun expAltType alt => do
+      let altType ← inferType alt
+      let eq ← mkEq expAltType altType
+      let proof ← mkFreshExprSyntheticOpaqueMVar eq
+      let goal := proof.mvarId!
+      -- logInfo m!"Goal: {goal}"
+      let goal ← Split.simpMatchTarget goal
+      -- logInfo m!"Goal after splitting: {goal}"
+      try
+        goal.refl
+      catch _ =>
+        logInfo m!"Cannot close goal after splitting: {goal}"
+        goal.admit
+      mkEqMPR proof alt
+    )
+
 end Lean.Meta.MatcherApp

src/Lean/Meta/NatInstTesters.lean

@@ -0,0 +1,63 @@
+/-
+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.Basic
+
+namespace Lean.Meta
+/-!
+Functions for testing whether expressions are canonical `Nat` instances.
+-/
+
+def isInstOfNatNat (e : Expr) : MetaM Bool := do
+  let_expr instOfNatNat _ ← e | return false
+  return true
+def isInstAddNat (e : Expr) : MetaM Bool := do
+  let_expr instAddNat ← e | return false
+  return true
+def isInstSubNat (e : Expr) : MetaM Bool := do
+  let_expr instSubNat ← e | return false
+  return true
+def isInstMulNat (e : Expr) : MetaM Bool := do
+  let_expr instMulNat ← e | return false
+  return true
+def isInstDivNat (e : Expr) : MetaM Bool := do
+  let_expr Nat.instDivNat ← e | return false
+  return true
+def isInstModNat (e : Expr) : MetaM Bool := do
+  let_expr Nat.instModNat ← e | return false
+  return true
+def isInstNatPowNat (e : Expr) : MetaM Bool := do
+  let_expr instNatPowNat ← e | return false
+  return true
+def isInstPowNat (e : Expr) : MetaM Bool := do
+  let_expr instPowNat _ i ← e | return false
+  isInstNatPowNat i
+def isInstHAddNat (e : Expr) : MetaM Bool := do
+  let_expr instHAdd _ i ← e | return false
+  isInstAddNat i
+def isInstHSubNat (e : Expr) : MetaM Bool := do
+  let_expr instHSub _ i ← e | return false
+  isInstSubNat i
+def isInstHMulNat (e : Expr) : MetaM Bool := do
+  let_expr instHMul _ i ← e | return false
+  isInstMulNat i
+def isInstHDivNat (e : Expr) : MetaM Bool := do
+  let_expr instHDiv _ i ← e | return false
+  isInstDivNat i
+def isInstHModNat (e : Expr) : MetaM Bool := do
+  let_expr instHMod _ i ← e | return false
+  isInstModNat i
+def isInstHPowNat (e : Expr) : MetaM Bool := do
+  let_expr instHPow _ _ i ← e | return false
+  isInstPowNat i
+def isInstLTNat (e : Expr) : MetaM Bool := do
+  let_expr instLTNat ← e | return false
+  return true
+def isInstLENat (e : Expr) : MetaM Bool := do
+  let_expr instLENat ← e | return false
+  return true
+
+end Lean.Meta

src/Lean/Meta/Offset.lean

@@ -6,7 +6,7 @@ Authors: Leonardo de Moura
 prelude
 import Lean.Data.LBool
 import Lean.Meta.InferType
-import Lean.Meta.AppBuilder
+import Lean.Meta.NatInstTesters
 
 namespace Lean.Meta
 
@@ -17,12 +17,6 @@ private abbrev withInstantiatedMVars (e : Expr) (k : Expr → OptionT MetaM α)
   else
     k eNew
 
-def isNatProjInst (declName : Name) (numArgs : Nat) : Bool :=
-    (numArgs == 4 && (declName == ``Add.add || declName == ``Sub.sub || declName == ``Mul.mul || declName == ``Div.div || declName == ``Mod.mod || declName == ``NatPow.pow))
- || (numArgs == 5 && (declName == ``Pow.pow))
- || (numArgs == 6 && (declName == ``HAdd.hAdd || declName == ``HSub.hSub || declName == ``HMul.hMul || declName == ``HDiv.hDiv || declName == ``HMod.hMod || declName == ``HPow.hPow))
- || (numArgs == 3 && declName == ``OfNat.ofNat)
-
 /--
   Evaluate simple `Nat` expressions.
   Remark: this method assumes the given expression has type `Nat`. -/
@@ -37,20 +31,28 @@ partial def evalNat (e : Expr) : OptionT MetaM Nat := do
 where
   visit e := do
     match_expr e with
+    | OfNat.ofNat _ n i => guard (← isInstOfNatNat i); evalNat n
     | Nat.succ a => return (← evalNat a) + 1
     | Nat.add a b => return (← evalNat a) + (← evalNat b)
+    | Add.add _ i a b => guard (← isInstAddNat i); return (← evalNat a) + (← evalNat b)
+    | HAdd.hAdd _ _ _ i a b => guard (← isInstHAddNat i); return (← evalNat a) + (← evalNat b)
     | Nat.sub a b => return (← evalNat a) - (← evalNat b)
+    | Sub.sub _ i a b => guard (← isInstSubNat i); return (← evalNat a) - (← evalNat b)
+    | HSub.hSub _ _ _ i a b => guard (← isInstHSubNat i); return (← evalNat a) - (← evalNat b)
     | Nat.mul a b => return (← evalNat a) * (← evalNat b)
+    | Mul.mul _ i a b => guard (← isInstMulNat i); return (← evalNat a) * (← evalNat b)
+    | HMul.hMul _ _ _ i a b => guard (← isInstHMulNat i); return (← evalNat a) * (← evalNat b)
     | Nat.div a b => return (← evalNat a) / (← evalNat b)
+    | Div.div _ i a b => guard (← isInstDivNat i); return (← evalNat a) / (← evalNat b)
+    | HDiv.hDiv _ _ _ i a b => guard (← isInstHDivNat i); return (← evalNat a) / (← evalNat b)
     | Nat.mod a b => return (← evalNat a) % (← evalNat b)
+    | Mod.mod _ i a b => guard (← isInstModNat i); return (← evalNat a) % (← evalNat b)
+    | HMod.hMod _ _ _ i a b => guard (← isInstHModNat i); return (← evalNat a) % (← evalNat b)
     | Nat.pow a b => return (← evalNat a) ^ (← evalNat b)
-    | _ =>
-      let e ← instantiateMVarsIfMVarApp e
-      let f := e.getAppFn
-      if f.isConst && isNatProjInst f.constName! e.getAppNumArgs then
-        evalNat (← unfoldProjInst? e)
-      else
-        failure
+    | NatPow.pow _ i a b => guard (← isInstNatPowNat i); return (← evalNat a) ^ (← evalNat b)
+    | Pow.pow _ _ i a b => guard (← isInstPowNat i); return (← evalNat a) ^ (← evalNat b)
+    | HPow.hPow _ _ _ i a b => guard (← isInstHPowNat i); return (← evalNat a) ^ (← evalNat b)
+    | _ => failure
 
 mutual
 
@@ -65,26 +67,18 @@ private partial def getOffset (e : Expr) : MetaM (Expr × Nat) :=
 /--
 Similar to `getOffset` but returns `none` if the expression is not syntactically an offset.
 -/
-private partial def isOffset? (e : Expr) : OptionT MetaM (Expr × Nat) := do
-  match e with
-  | .app _ a => do
-    let f := e.getAppFn
-    match f with
-    | .mvar .. => withInstantiatedMVars e isOffset?
-    | .const c _ =>
-      let nargs := e.getAppNumArgs
-      if c == ``Nat.succ && nargs == 1 then
-        let (s, k) ← getOffset a
-        pure (s, k+1)
-      else if c == ``Nat.add && nargs == 2 then
-        let v ← evalNat (e.getArg! 1)
-        let (s, k) ← getOffset (e.getArg! 0)
-        pure (s, k+v)
-      else if (c == ``Add.add && nargs == 4) || (c == ``HAdd.hAdd && nargs == 6) then
-        isOffset? (← unfoldProjInst? e)
-      else
-        failure
-    | _ => failure
+partial def isOffset? (e : Expr) : OptionT MetaM (Expr × Nat) := do
+  let add (a b : Expr) := do
+    let v ← evalNat b
+    let (s, k) ← getOffset a
+    return (s, k+v)
+  match_expr e with
+  | Nat.succ a =>
+    let (s, k) ← getOffset a
+    return (s, k+1)
+  | Nat.add a b => add a b
+  | Add.add _ i a b => guard (← isInstAddNat i); add a b
+  | HAdd.hAdd _ _ _ i a b => guard (← isInstHAddNat i); add a b
   | _ => failure
 
 end
@@ -100,7 +94,7 @@ private def mkOffset (e : Expr) (offset : Nat) : MetaM Expr := do
   else if (← isNatZero e) then
     return mkNatLit offset
   else
-    mkAdd e (mkNatLit offset)
+    return mkNatAdd e (mkNatLit offset)
 
 def isDefEqOffset (s t : Expr) : MetaM LBool := do
   let ifNatExpr (x : MetaM LBool) : MetaM LBool := do

src/Lean/Meta/Reduce.lean

@@ -33,7 +33,7 @@ partial def reduce (e : Expr) (explicitOnly skipTypes skipProofs := true) : Meta
             else
               args ← args.modifyM i visit
           if f.isConstOf ``Nat.succ && args.size == 1 && args[0]!.isRawNatLit then
-            return mkRawNatLit (args[0]!.natLit?.get! + 1)
+            return mkRawNatLit (args[0]!.rawNatLit?.get! + 1)
           else
             return mkAppN f args
         | Expr.lam ..        => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← visit b)

src/Lean/Meta/SynthInstance.lean

@@ -10,7 +10,6 @@ import Init.Data.Array.InsertionSort
 import Lean.Meta.Basic
 import Lean.Meta.Instances
 import Lean.Meta.AbstractMVars
-import Lean.Meta.WHNF
 import Lean.Meta.Check
 import Lean.Util.Profile
 
@@ -322,6 +321,26 @@ def getSubgoals (lctx : LocalContext) (localInsts : LocalInstances) (xs : Array
     subgoals := inst.synthOrder.map (mvars[·]!) |>.toList
   }
 
+/--
+Similar to `mkLambdaFVars`, but ensures result is eta-reduced.
+For example, suppose `e` is the local variable `inst x y`, and `xs` is `#[x, y]`, then
+the result is `inst` instead of `fun x y => inst x y`.
+
+We added this auxiliary function because of aliases such as `DecidablePred`. For example,
+consider the following definition.
+```
+def filter (p : α → Prop) [inst : DecidablePred p] (xs : List α) : List α :=
+  match xs with
+  | [] => []
+  | x :: xs' => if p x then x :: filter p xs' else filter p xs'
+```
+Without `mkLambdaFVars'`, the implicit instance at the `filter` applications would be `fun x => inst x` instead of `inst`.
+Moreover, the equation lemmas associated with `filter` would have `fun x => inst x` on their right-hand-side. Then,
+we would start getting terms such as `fun x => (fun x => inst x) x` when using the equational theorem.
+-/
+private def mkLambdaFVars' (xs : Array Expr) (e : Expr) : MetaM Expr :=
+  return (← mkLambdaFVars xs e).eta
+
 /--
   Try to synthesize metavariable `mvar` using the instance `inst`.
   Remark: `mctx` is set using `withMCtx`.
@@ -336,7 +355,7 @@ def tryResolve (mvar : Expr) (inst : Instance) : MetaM (Option (MetavarContext
     withTraceNode `Meta.synthInstance.tryResolve (withMCtx (← getMCtx) do
         return m!"{exceptOptionEmoji ·} {← instantiateMVars mvarTypeBody} ≟ {← instantiateMVars instTypeBody}") do
     if (← isDefEq mvarTypeBody instTypeBody) then
-      let instVal ← mkLambdaFVars xs instVal
+      let instVal ← mkLambdaFVars' xs instVal
       if (← isDefEq mvar instVal) then
         return some ((← getMCtx), subgoals)
     return none
@@ -449,7 +468,7 @@ private def removeUnusedArguments? (mctx : MetavarContext) (mvar : Expr) : MetaM
         let ys := ys.toArray
         let mvarType' ← mkForallFVars ys body
         withLocalDeclD `redf mvarType' fun f => do
-          let transformer ← mkLambdaFVars #[f] (← mkLambdaFVars xs (mkAppN f ys))
+          let transformer ← mkLambdaFVars' #[f] (← mkLambdaFVars' xs (mkAppN f ys))
           trace[Meta.synthInstance.unusedArgs] "{mvarType}\nhas unused arguments, reduced type{indentExpr mvarType'}\nTransformer{indentExpr transformer}"
           return some (mvarType', transformer)
 

src/Lean/Meta/Tactic.lean

@@ -37,3 +37,4 @@ import Lean.Meta.Tactic.IndependentOf
 import Lean.Meta.Tactic.Symm
 import Lean.Meta.Tactic.Backtrack
 import Lean.Meta.Tactic.SolveByElim
+import Lean.Meta.Tactic.FunInd

src/Lean/Meta/Tactic/Apply.lean

@@ -193,6 +193,11 @@ def apply (mvarId : MVarId) (e : Expr) (cfg : ApplyConfig := {}) : MetaM (List M
 def _root_.Lean.MVarId.applyConst (mvar : MVarId) (c : Name) (cfg : ApplyConfig := {}) : MetaM (List MVarId) := do
   mvar.apply (← mkConstWithFreshMVarLevels c) cfg
 
+end Meta
+
+open Meta
+namespace MVarId
+
 partial def splitAndCore (mvarId : MVarId) : MetaM (List MVarId) :=
   mvarId.withContext do
     mvarId.checkNotAssigned `splitAnd
@@ -219,14 +224,14 @@ partial def splitAndCore (mvarId : MVarId) : MetaM (List MVarId) :=
 /--
 Apply `And.intro` as much as possible to goal `mvarId`.
 -/
-abbrev _root_.Lean.MVarId.splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
+abbrev splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
   splitAndCore mvarId
 
-@[deprecated MVarId.splitAnd]
-def splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
+@[deprecated splitAnd]
+def _root_.Lean.Meta.splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
   mvarId.splitAnd
 
-def _root_.Lean.MVarId.exfalso (mvarId : MVarId) : MetaM MVarId :=
+def exfalso (mvarId : MVarId) : MetaM MVarId :=
   mvarId.withContext do
     mvarId.checkNotAssigned `exfalso
     let target ← instantiateMVars (← mvarId.getType)
@@ -240,7 +245,7 @@ Apply the `n`-th constructor of the target type,
 checking that it is an inductive type,
 and that there are the expected number of constructors.
 -/
-def _root_.Lean.MVarId.nthConstructor
+def nthConstructor
     (name : Name) (idx : Nat) (expected? : Option Nat := none) (goal : MVarId) :
     MetaM (List MVarId) := do
   goal.withContext do
@@ -256,4 +261,68 @@ def _root_.Lean.MVarId.nthConstructor
         else
           throwTacticEx name goal s!"index {idx} out of bounds, only {ival.ctors.length} constructors"
 
-end Lean.Meta
+/--
+Try to convert an `Iff` into an `Eq` by applying `iff_of_eq`.
+If successful, returns the new goal, and otherwise returns the original `MVarId`.
+
+This may be regarded as being a special case of `Lean.MVarId.liftReflToEq`, specifically for `Iff`.
+-/
+def iffOfEq (mvarId : MVarId) : MetaM MVarId := do
+  let res ← observing? do
+    let [mvarId] ← mvarId.apply (mkConst ``iff_of_eq []) | failure
+    return mvarId
+  return res.getD mvarId
+
+/--
+Try to convert an `Eq` into an `Iff` by applying `propext`.
+If successful, then returns then new goal, otherwise returns the original `MVarId`.
+-/
+def propext (mvarId : MVarId) : MetaM MVarId := do
+  let res ← observing? do
+    -- Avoid applying `propext` if the target is not an equality of `Prop`s.
+    -- We don't want a unification specializing `Sort*` to `Prop`.
+    let tgt ← withReducible mvarId.getType'
+    let some (_, x, _) := tgt.eq? | failure
+    guard <| ← Meta.isProp x
+    let [mvarId] ← mvarId.apply (mkConst ``propext []) | failure
+    return mvarId
+  return res.getD mvarId
+
+/--
+Try to close the goal using `proof_irrel_heq`. Returns whether or not it succeeds.
+
+We need to be somewhat careful not to assign metavariables while doing this, otherwise we might
+specialize `Sort _` to `Prop`.
+-/
+def proofIrrelHeq (mvarId : MVarId) : MetaM Bool :=
+  mvarId.withContext do
+    let res ← observing? do
+      mvarId.checkNotAssigned `proofIrrelHeq
+      let tgt ← withReducible mvarId.getType'
+      let some (_, lhs, _, rhs) := tgt.heq? | failure
+      -- Note: `mkAppM` uses `withNewMCtxDepth`, which prevents `Sort _` from specializing to `Prop`
+      let pf ← mkAppM ``proof_irrel_heq #[lhs, rhs]
+      mvarId.assign pf
+      return true
+    return res.getD false
+
+/--
+Try to close the goal using `Subsingleton.elim`. Returns whether or not it succeeds.
+
+We are careful to apply `Subsingleton.elim` in a way that does not assign any metavariables.
+This is to prevent the `Subsingleton Prop` instance from being used as justification to specialize
+`Sort _` to `Prop`.
+-/
+def subsingletonElim (mvarId : MVarId) : MetaM Bool :=
+  mvarId.withContext do
+    let res ← observing? do
+      mvarId.checkNotAssigned `subsingletonElim
+      let tgt ← withReducible mvarId.getType'
+      let some (_, lhs, rhs) := tgt.eq? | failure
+      -- Note: `mkAppM` uses `withNewMCtxDepth`, which prevents `Sort _` from specializing to `Prop`
+      let pf ← mkAppM ``Subsingleton.elim #[lhs, rhs]
+      mvarId.assign pf
+      return true
+    return res.getD false
+
+end Lean.MVarId

src/Lean/Meta/Tactic/ElimInfo.lean

@@ -123,17 +123,18 @@ where
       return (implicits, targets')
 
 structure CustomEliminator where
+  induction : Bool
   typeNames : Array Name
   elimName  : Name -- NB: Do not store the ElimInfo, it can contain MVars
   deriving Inhabited, Repr
 
 structure CustomEliminators where
-  map : SMap (Array Name) Name := {}
+  map : SMap (Bool × Array Name) Name := {}
   deriving Inhabited, Repr
 
 def addCustomEliminatorEntry (es : CustomEliminators) (e : CustomEliminator) : CustomEliminators :=
   match es with
-  | { map := map } => { map := map.insert e.typeNames e.elimName }
+  | { map := map } => { map := map.insert (e.induction, e.typeNames) e.elimName }
 
 builtin_initialize customEliminatorExt : SimpleScopedEnvExtension CustomEliminator CustomEliminators ←
   registerSimpleScopedEnvExtension {
@@ -142,7 +143,7 @@ builtin_initialize customEliminatorExt : SimpleScopedEnvExtension CustomEliminat
     finalizeImport := fun { map := map } => { map := map.switch }
   }
 
-def mkCustomEliminator (elimName : Name) : MetaM CustomEliminator := do
+def mkCustomEliminator (elimName : Name) (induction : Bool) : MetaM CustomEliminator := do
   let elimInfo ← getElimInfo elimName
   let info ← getConstInfo elimName
   forallTelescopeReducing info.type fun xs _ => do
@@ -164,29 +165,46 @@ def mkCustomEliminator (elimName : Name) : MetaM CustomEliminator := do
         let xType ← inferType x
         let .const typeName .. := xType.getAppFn | throwError "unexpected eliminator target type{indentExpr xType}"
         typeNames := typeNames.push typeName
-    return { typeNames, elimName}
+    return { induction, typeNames, elimName }
 
-def addCustomEliminator (declName : Name) (attrKind : AttributeKind) : MetaM Unit := do
-  let e ← mkCustomEliminator declName
+def addCustomEliminator (declName : Name) (attrKind : AttributeKind) (induction : Bool) : MetaM Unit := do
+  let e ← mkCustomEliminator declName induction
   customEliminatorExt.add e attrKind
 
 builtin_initialize
   registerBuiltinAttribute {
-    name  := `eliminator
-    descr := "custom eliminator for `cases` and `induction` tactics"
+    name  := `induction_eliminator
+    descr := "custom `rec`-like eliminator for the `induction` tactic"
     add   := fun declName _ attrKind => do
-      discard <| addCustomEliminator declName attrKind |>.run {} {}
+      discard <| addCustomEliminator declName attrKind (induction := true) |>.run {} {}
   }
 
+builtin_initialize
+  registerBuiltinAttribute {
+    name  := `cases_eliminator
+    descr := "custom `casesOn`-like eliminator for the `cases` tactic"
+    add   := fun declName _ attrKind => do
+      discard <| addCustomEliminator declName attrKind (induction := false) |>.run {} {}
+  }
+
+/-- Gets all the eliminators defined using the `@[induction_eliminator]` and `@[cases_eliminator]` attributes. -/
 def getCustomEliminators : CoreM CustomEliminators := do
   return customEliminatorExt.getState (← getEnv)
 
-def getCustomEliminator? (targets : Array Expr) : MetaM (Option Name) := do
+/--
+Gets an eliminator appropriate for the provided array of targets.
+If `induction` is `true` then returns a matching eliminator defined using the `@[induction_eliminator]` attribute
+and otherwise returns one defined using the `@[cases_eliminator]` attribute.
+
+The `@[induction_eliminator]` attribute is for the `induction` tactic
+and the `@[cases_eliminator]` attribute is for the `cases` tactic.
+-/
+def getCustomEliminator? (targets : Array Expr) (induction : Bool) : MetaM (Option Name) := do
   let mut key := #[]
   for target in targets do
     let targetType := (← instantiateMVars (← inferType target)).headBeta
     let .const declName .. := targetType.getAppFn | return none
     key := key.push declName
-  return customEliminatorExt.getState (← getEnv) |>.map.find? key
+  return customEliminatorExt.getState (← getEnv) |>.map.find? (induction, key)
 
 end Lean.Meta

src/Lean/Meta/Tactic/FunInd.lean

@@ -0,0 +1,924 @@
+/-
+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.Basic
+import Lean.Meta.Match.MatcherApp.Transform
+import Lean.Meta.Check
+import Lean.Meta.Tactic.Cleanup
+import Lean.Meta.Tactic.Subst
+import Lean.Meta.Injective -- for elimOptParam
+import Lean.Elab.PreDefinition.WF.Eqns
+import Lean.Elab.PreDefinition.WF.PackMutual
+import Lean.Elab.Command
+
+/-!
+This module contains code to derive, from the definition of a recursive function
+(or mutually recursive functions) defined by well-founded recursion, a
+**functional induction principle** tailored to proofs about that function(s). For
+example from:
+
+```
+def ackermann : Nat → Nat → Nat
+  | 0, m => m + 1
+  | n+1, 0 => ackermann n 1
+  | n+1, m+1 => ackermann n (ackermann (n + 1) m)
+derive_functional_induction ackermann
+```
+we get
+```
+ackermann.induct (motive : Nat → Nat → Prop) (case1 : ∀ (m : Nat), motive 0 m)
+  (case2 : ∀ (n : Nat), motive n 1 → motive (Nat.succ n) 0)
+  (case3 : ∀ (n m : Nat), motive (n + 1) m → motive n (ackermann (n + 1) m) → motive (Nat.succ n) (Nat.succ m))
+  (x x : Nat) : motive x x
+```
+
+## Specification
+
+The functional induction principle takes the same fixed parameters as the function, and
+the motive takes the same non-fixed parameters as the original function.
+
+For each branch of the original function, there is a case in the induction principle.
+Here "branch" roughly corresponds to tail-call positions: branches of top-level
+`if`-`then`-`else` and of `match` expressions.
+
+For every recursive call in that branch, an induction hypothesis asserting the
+motive for the arguments of the recursive call is provided.
+If the recursive call is under binders and it, or its proof of termination,
+depend on the the bound values, then these become assumptions of the inductive
+hypothesis.
+
+Additionally, the local context of the branch (e.g. the condition of an
+if-then-else; a let-binding, a have-binding) is provided as assumptions in the
+corresponding induction case, if they are likely to be useful (as determined
+by `MVarId.cleanup`).
+
+Mutual recursion is supported and results in multiple motives.
+
+
+## Implementation overview
+
+For a non-mutual, unary function `foo` (or else for the `_unary` function), we
+
+1. expect its definition, possibly after some `whnf`’ing, to be of the form
+   ```
+   def foo := fun x₁ … xₙ (y : a) => WellFounded.fix (fun y' oldIH => body) y
+   ```
+   where `xᵢ…` are the fixed parameter prefix and `y` is the varying parameter of
+   the function.
+
+2. From this structure we derive the type of the motive, and start assembling the induction
+   principle:
+   ```
+   def foo.induct := fun x₁ … xₙ (motive : (y : a) → Prop) =>
+    fix (fun y' newIH => T[body])
+   ```
+
+3. The first phase, transformation `T1[body]` (implemented in) `buildInductionBody`,
+   mirrors the branching structure of `foo`, i.e. replicates `dite` and some matcher applications,
+   while adjusting their motive. It also unfolds calls to `oldIH` and collects induction hypotheses
+   in conditions (see below).
+
+   In particular, when translating a `match` it is prepared to recognize the idiom
+   as introduced by `mkFix` via `Lean.Meta.MatcherApp.addArg?`, which refines the type of `oldIH`
+   throughout the match. The transformation will replace `oldIH` with `newIH` here.
+   ```
+        T[(match (motive := fun oldIH => …) y with | … => fun oldIH' => body) oldIH]
+    ==> (match (motive := fun newIH => …) y with | … => fun newIH' => T[body]) newIH
+   ```
+
+   In addition, the information gathered from the match is preserved, so that when performing the
+   proof by induction, the user can reliably enter the right case. To achieve this
+
+   * the matcher is replaced by its splitter, which brings extra assumptions into scope when
+     patterns are overlapping
+   * simple discriminants that are mentioned in the goal (i.e plain parameters) are instantiated
+     in the code.
+   * for discriminants that are not instantiated that way, equalities connecting the discriminant
+     to the instantiation are added (just as if the user wrote `match h : x with …`)
+
+4. When a tail position (no more branching) is found, function `buildInductionCase` assembles the
+   type of the case: a fresh `MVar` asserts the current goal, unwanted values from the local context
+   are cleared, and the current `body` is searched for recursive calls using `collectIHs`,
+   which are then asserted as inductive hyptheses in the `MVar`.
+
+5. The function `collectIHs` walks the term and collects the induction hypotheses for the current case
+   (with proofs). When it encounters a saturated application of `oldIH x proof`, it returns
+   `newIH x proof : motive x`.
+
+   Since `x` and `proof` can contain further recursive calls, it uses
+   `foldCalls` to replace these with calls to `foo`. This assumes that the
+   termination proof `proof` works nevertheless.
+
+   Again, `collectIHs` may encounter the `Lean.Meta.Matcherapp.addArg?` idiom, and again it threads `newIH`
+   through, replacing the extra argument. The resulting type of this induction hypothesis is now
+   itself a `match` statement (cf. `Lean.Meta.MatcherApp.inferMatchType`)
+
+   The termination proof of `foo` may have abstracted over some proofs; these proofs must be transferred, so
+   auxillary lemmas are unfolded if needed.
+
+6. The function `foldCalls` replaces calls to `oldIH` with calls to `foo` that
+   make sense to the user.
+
+   At the end of this transformation, no mention of `oldIH` must remain.
+
+7. After this construction, the MVars introduced by `buildInductionCase` are turned into parameters.
+
+The resulting term then becomes `foo.induct` at its inferred type.
+
+If `foo` is not unary and/or part of a mutual reduction, then the induction theorem for `foo._unary`
+(i.e. the unary non-mutual recursion function produced by the equation compiler)
+of the form
+```
+foo._unary.induct : {motive : (a ⊗' b) ⊕' c → Prop} →
+  (case1 : ∀ …, motive (PSum.inl (x,y)) →  …) → … →
+  (x : (a ⊗' b) ⊕' c) → motive x
+```
+will first in `unpackMutualInduction` be turned into a joint induction theorem of the form
+```
+foo.mutual_induct : {motive1 : a → b → Prop} {motive2 : c → Prop} →
+  (case1 : ∀ …, motive1 x y  →  …) → … →
+  ((x : a) → (y : b) → motive1 x y) ∧ ((z : c) → motive2 z)
+```
+where all the `PSum`/`PSigma` encoding has been resolved. This theorem is attached to the
+name of the first function in the mutual group, like the `._unary` definition.
+
+Finally, in `deriveUnpackedInduction`, for each of the funtions in the mutual group, a simple
+projection yields the final `foo.induct` theorem:
+```
+foo.induct : {motive1 : a → b → Prop} {motive2 : c → Prop} →
+  (case1 : ∀ …, motive1 x y  →  …) → … →
+  (x : a) → (y : b) → motive1 x y
+```
+
+-/
+
+set_option autoImplicit false
+
+namespace Lean.Tactic.FunInd
+
+open Lean Elab Meta
+
+/-- Opens the body of a lambda, _without_ putting the free variable into the local context.
+This is used when replacing parameters with different expressions.
+This way it will not be picked up by metavariables.
+-/
+def removeLamda {α} (e : Expr) (k : FVarId → Expr →  MetaM α) : MetaM α := do
+  let .lam _n _d b _bi := ← whnfD e | throwError "removeLamda: expected lambda, got {e}"
+  let x ← mkFreshFVarId
+  let b := b.instantiate1 (.fvar x)
+  k x b
+
+/-- Replace calls to oldIH back to calls to the original function. At the end, if `oldIH` occurs, an error is thrown. -/
+partial def foldCalls (fn : Expr) (oldIH : FVarId) (e : Expr) : MetaM Expr := do
+  unless e.containsFVar oldIH do
+    return e
+
+  if e.getAppNumArgs = 2 && e.getAppFn.isFVarOf oldIH then
+    let #[arg, _proof] := e.getAppArgs | unreachable!
+    let arg' ← foldCalls fn oldIH arg
+    return .app fn arg'
+
+  if let some matcherApp ← matchMatcherApp? e (alsoCasesOn := true) then
+    if matcherApp.remaining.size == 1 && matcherApp.remaining[0]!.isFVarOf oldIH then
+      let matcherApp' ← matcherApp.transform
+        (onParams := foldCalls fn oldIH)
+        (onMotive := fun _motiveArgs motiveBody => do
+          let some (_extra, body) := motiveBody.arrow? | throwError "motive not an arrow"
+          foldCalls fn oldIH body)
+        (onAlt := fun _altType alt => do
+          removeLamda alt fun oldIH alt => do
+            foldCalls fn oldIH alt)
+        (onRemaining := fun _ => pure #[])
+      return matcherApp'.toExpr
+
+  if e.getAppArgs.any (·.isFVarOf oldIH) then
+    -- Sometimes Fix.lean abstracts over oldIH in a proof definition.
+    -- So beta-reduce that definition.
+
+    -- Need to look through theorems here!
+    let e' ← withTransparency .all do whnf e
+    if e == e' then
+      throwError "foldCalls: cannot reduce application of {e.getAppFn} in {indentExpr e} "
+    return ← foldCalls fn oldIH e'
+
+  if let some (n, t, v, b) := e.letFun? then
+    let t' ← foldCalls fn oldIH t
+    let v' ← foldCalls fn oldIH v
+    return ← withLocalDecl n .default t' fun x => do
+      let b' ← foldCalls fn oldIH (b.instantiate1 x)
+      mkLetFun x v' b'
+
+  match e with
+  | .app e1 e2 =>
+    return .app (← foldCalls fn oldIH e1) (← foldCalls fn oldIH e2)
+
+  | .lam n t body bi =>
+    let t' ← foldCalls fn oldIH t
+    return ← withLocalDecl n bi t' fun x => do
+      let body' ← foldCalls fn oldIH (body.instantiate1 x)
+      mkLambdaFVars #[x] body'
+
+  | .forallE n t body bi =>
+    let t' ← foldCalls fn oldIH t
+    return ← withLocalDecl n bi t' fun x => do
+      let body' ← foldCalls fn oldIH (body.instantiate1 x)
+      mkForallFVars #[x] body'
+
+  | .letE n t v b _ =>
+    let t' ← foldCalls fn oldIH t
+    let v' ← foldCalls fn oldIH v
+    return ← withLetDecl n t' v' fun x => do
+      let b' ← foldCalls fn oldIH (b.instantiate1 x)
+      mkLetFVars  #[x] b'
+
+  | .mdata m b =>
+    return .mdata m (← foldCalls fn oldIH b)
+
+  | .proj t i e =>
+    return .proj t i (← foldCalls fn oldIH e)
+
+  | .sort .. | .lit .. | .const .. | .mvar .. | .bvar .. =>
+    unreachable! -- cannot contain free variables, so early exit above kicks in
+
+  | .fvar .. =>
+    throwError m!"collectIHs: cannot eliminate unsaturated call to induction hypothesis"
+
+
+/--
+Given proofs of `P₁`, …, `Pₙ`, returns a proof of `P₁ ∧ … ∧ Pₙ`.
+If `n = 0` returns a proof of `True`.
+If `n = 1` returns the proof of `P₁`.
+-/
+def mkAndIntroN : Array Expr → MetaM Expr
+| #[] => return mkConst ``True.intro []
+| #[e] => return e
+| es => es.foldrM (start := es.size - 1) (fun a b => mkAppM ``And.intro #[a,b]) es.back
+
+/-- Given a proof of `P₁ ∧ … ∧ Pᵢ ∧ … ∧ Pₙ`, return the proof of `Pᵢ` -/
+def mkProjAndN (n i : Nat) (e : Expr) : Expr := Id.run do
+  let mut value := e
+  for _ in [:i] do
+      value := mkProj ``And 1 value
+  if i + 1 < n then
+      value := mkProj ``And 0 value
+  return value
+
+
+-- Non-tail-positions: Collect induction hypotheses
+-- (TODO: Worth folding with `foldCalls`, like before?)
+-- (TODO: Accumulated with a left fold)
+partial def collectIHs (fn : Expr) (oldIH newIH : FVarId) (e : Expr) : MetaM (Array Expr) := do
+  unless e.containsFVar oldIH do
+    return #[]
+
+  if e.getAppNumArgs = 2 && e.getAppFn.isFVarOf oldIH then
+    let #[arg, proof] := e.getAppArgs  | unreachable!
+
+    let arg' ← foldCalls fn oldIH arg
+    let proof' ← foldCalls fn oldIH proof
+    let ihs ← collectIHs fn oldIH newIH arg
+
+    return ihs.push (mkApp2 (.fvar newIH) arg' proof')
+
+  if let some (n, t, v, b) := e.letFun? then
+    let ihs1 ← collectIHs fn oldIH newIH v
+    let v' ← foldCalls fn oldIH v
+    return ← withLetDecl n t v' fun x => do
+      let ihs2 ← collectIHs fn oldIH newIH (b.instantiate1 x)
+      let ihs2 ← ihs2.mapM (mkLetFVars (usedLetOnly := true) #[x] ·)
+      return ihs1 ++ ihs2
+
+  if let some matcherApp ← matchMatcherApp? e (alsoCasesOn := true) then
+    if matcherApp.remaining.size == 1 && matcherApp.remaining[0]!.isFVarOf oldIH then
+
+      let matcherApp' ← matcherApp.transform
+        (onParams := foldCalls fn oldIH)
+        (onMotive := fun xs _body => do
+          -- Remove the old IH that was added in mkFix
+          let eType ← newIH.getType
+          let eTypeAbst ← matcherApp.discrs.size.foldRevM (init := eType) fun i eTypeAbst => do
+            let motiveArg := xs[i]!
+            let discr     := matcherApp.discrs[i]!
+            let eTypeAbst ← kabstract eTypeAbst discr
+            return eTypeAbst.instantiate1 motiveArg
+
+          -- Will later be overriden with a type that’s itself a match
+          -- statement and the infered alt types
+          let dummyGoal := mkConst ``True []
+          mkArrow eTypeAbst dummyGoal)
+        (onAlt := fun altType alt => do
+          removeLamda alt fun oldIH' alt => do
+            forallBoundedTelescope altType (some 1) fun newIH' _goal' => do
+              let #[newIH'] := newIH' | unreachable!
+              let altIHs ← collectIHs fn oldIH' newIH'.fvarId! alt
+              let altIH ← mkAndIntroN altIHs
+              mkLambdaFVars #[newIH'] altIH)
+        (onRemaining := fun _ => pure #[mkFVar newIH])
+      let matcherApp'' ← matcherApp'.inferMatchType
+
+      return #[ matcherApp''.toExpr ]
+
+  if e.getAppArgs.any (·.isFVarOf oldIH) then
+    -- Sometimes Fix.lean abstracts over oldIH in a proof definition.
+    -- So beta-reduce that definition.
+
+    -- Need to look through theorems here!
+    let e' ← withTransparency .all do whnf e
+    if e == e' then
+      throwError "collectIHs: cannot reduce application of {e.getAppFn} in {indentExpr e} "
+    return ← collectIHs fn oldIH newIH e'
+
+  if e.getAppArgs.any (·.isFVarOf oldIH) then
+    throwError "collectIHs: could not collect recursive calls from call {indentExpr e}"
+
+  match e with
+  | .letE n t v b _ =>
+    let ihs1 ← collectIHs fn oldIH newIH v
+    let v' ← foldCalls fn oldIH v
+    return ← withLetDecl n t v' fun x => do
+      let ihs2 ← collectIHs fn oldIH newIH (b.instantiate1 x)
+      let ihs2 ← ihs2.mapM (mkLetFVars (usedLetOnly := true) #[x] ·)
+      return ihs1 ++ ihs2
+
+  | .app e1 e2 =>
+    return (← collectIHs fn oldIH newIH e1) ++ (← collectIHs fn oldIH newIH e2)
+
+  | .proj _ _ e =>
+    return ← collectIHs fn oldIH newIH e
+
+  | .forallE n t body bi =>
+    let t' ← foldCalls fn oldIH t
+    return ← withLocalDecl n bi t' fun x => do
+      let ihs ← collectIHs fn oldIH newIH (body.instantiate1 x)
+      ihs.mapM (mkLambdaFVars (usedOnly := true) #[x])
+
+  | .lam n t body bi =>
+    let t' ← foldCalls fn oldIH t
+    return ← withLocalDecl n bi t' fun x => do
+      let ihs ← collectIHs fn oldIH newIH (body.instantiate1 x)
+      ihs.mapM (mkLambdaFVars (usedOnly := true) #[x])
+
+  | .mdata _m b =>
+    return ← collectIHs fn oldIH newIH b
+
+  | .sort .. | .lit .. | .const .. | .mvar .. | .bvar .. =>
+    unreachable! -- cannot contain free variables, so early exit above kicks in
+
+  | .fvar _ =>
+    throwError "collectIHs: could not collect recursive calls, unsaturated application of old induction hypothesis"
+
+-- Because of term duplications we might encounter the same IH multiple times.
+-- We deduplicate them (by type, not proof term) here.
+-- This could be improved and catch cases where the same IH is used in different contexts.
+-- (Cf. `assignSubsumed` in `WF.Fix`)
+def deduplicateIHs (vals : Array Expr) : MetaM (Array Expr) := do
+  let mut vals' := #[]
+  let mut types := #[]
+  for v in vals do
+    let t ← inferType v
+    unless types.contains t do
+      vals' := vals'.push v
+      types := types.push t
+  return vals'
+
+def assertIHs (vals : Array Expr) (mvarid : MVarId) : MetaM MVarId := do
+  let mut mvarid := mvarid
+  for v in vals.reverse, i in [0:vals.size] do
+    mvarid ← mvarid.assert s!"ih{i+1}" (← inferType v) v
+  return mvarid
+
+/-- Base case of `buildInductionBody`: Construct a case for the final induction hypthesis.  -/
+def buildInductionCase (fn : Expr) (oldIH newIH : FVarId) (toClear toPreserve : Array FVarId)
+    (goal : Expr) (IHs : Array Expr) (e : Expr) : MetaM Expr := do
+  let IHs := IHs ++ (← collectIHs fn oldIH newIH e)
+  let IHs ← deduplicateIHs IHs
+
+  let mvar ← mkFreshExprSyntheticOpaqueMVar goal (tag := `hyp)
+  let mut mvarId := mvar.mvarId!
+  mvarId ← assertIHs IHs mvarId
+  for fvarId in toClear do
+    mvarId ← mvarId.clear fvarId
+  mvarId ← mvarId.cleanup (toPreserve := toPreserve)
+  mvarId ← substVars mvarId
+  let mvar ← instantiateMVars mvar
+  pure mvar
+
+/--
+Like `mkLambdaFVars (usedOnly := true)`, but
+
+ * silently skips expression in `xs` that are not `.isFVar`
+ * returns a mask (same size as `xs`) indicating which variables have been abstracted
+   (`true` means was abstracted).
+
+The result `r` can be applied with `r.beta (maskArray mask args)`.
+
+We use this when generating the functional induction principle to refine the goal through a `match`,
+here `xs` are the discriminans of the `match`.
+We do not expect non-trivial discriminants to appear in the goal (and if they do, the user will
+get a helpful equality into the context).
+-/
+def mkLambdaFVarsMasked (xs : Array Expr) (e : Expr) : MetaM (Array Bool × Expr) := do
+  let mut e := e
+  let mut xs := xs
+  let mut mask := #[]
+  while ! xs.isEmpty do
+    let discr := xs.back
+    if discr.isFVar && e.containsFVar discr.fvarId! then
+        e ← mkLambdaFVars #[discr] e
+        mask := mask.push true
+    else
+        mask := mask.push false
+    xs := xs.pop
+  return (mask.reverse, e)
+
+/-- `maskArray mask xs` keeps those `x` where the corresponding entry in `mask` is `true` -/
+def maskArray {α} (mask : Array Bool) (xs : Array α) : Array α := Id.run do
+  let mut ys := #[]
+  for b in mask, x in xs do
+    if b then ys := ys.push x
+  return ys
+
+partial def buildInductionBody (fn : Expr) (toClear toPreserve : Array FVarId)
+    (goal : Expr) (oldIH newIH : FVarId) (IHs : Array Expr) (e : Expr) : MetaM Expr := do
+
+  if e.isDIte then
+    let #[_α, c, h, t, f] := e.getAppArgs | unreachable!
+    let IHs := IHs ++ (← collectIHs fn oldIH newIH c)
+    let c' ← foldCalls fn oldIH c
+    let h' ← foldCalls fn oldIH h
+    let t' ← withLocalDecl `h .default c' fun h => do
+      let t ← instantiateLambda t #[h]
+      let t' ← buildInductionBody fn toClear (toPreserve.push h.fvarId!) goal oldIH newIH IHs t
+      mkLambdaFVars #[h] t'
+    let f' ← withLocalDecl `h .default (mkNot c') fun h => do
+      let f ← instantiateLambda f #[h]
+      let f' ← buildInductionBody fn toClear (toPreserve.push h.fvarId!) goal oldIH newIH IHs f
+      mkLambdaFVars #[h] f'
+    let u ← getLevel goal
+    return mkApp5 (mkConst ``dite [u]) goal c' h' t' f'
+
+  if let some matcherApp ← matchMatcherApp? e (alsoCasesOn := true) then
+    -- Collect IHs from the parameters and discrs of the matcher
+    let paramsAndDiscrs := matcherApp.params ++ matcherApp.discrs
+    let IHs := IHs ++ (← paramsAndDiscrs.concatMapM (collectIHs fn oldIH newIH))
+
+    -- Calculate motive
+    let eType ← newIH.getType
+    let motiveBody ← mkArrow eType goal
+    let (mask, absMotiveBody) ← mkLambdaFVarsMasked matcherApp.discrs motiveBody
+
+    -- A match that refines the parameter has been modified by `Fix.lean` to refine the IH,
+    -- so we need to replace that IH
+    if matcherApp.remaining.size == 1 && matcherApp.remaining[0]!.isFVarOf oldIH then
+      let matcherApp' ← matcherApp.transform (useSplitter := true)
+        (addEqualities := mask.map not)
+        (onParams := foldCalls fn oldIH)
+        (onMotive := fun xs _body => pure (absMotiveBody.beta (maskArray mask xs)))
+        (onAlt := fun expAltType alt => do
+          removeLamda alt fun oldIH' alt => do
+            forallBoundedTelescope expAltType (some 1) fun newIH' goal' => do
+              let #[newIH'] := newIH' | unreachable!
+              let alt' ← buildInductionBody fn (toClear.push newIH'.fvarId!) toPreserve goal' oldIH' newIH'.fvarId! IHs alt
+              mkLambdaFVars #[newIH'] alt')
+        (onRemaining := fun _ => pure #[.fvar newIH])
+      return matcherApp'.toExpr
+
+    -- A match that does not refine the parameter, but that we still want to split into separate
+    -- cases
+    if matcherApp.remaining.isEmpty then
+      -- Calculate motive
+      let (mask, absMotiveBody) ← mkLambdaFVarsMasked matcherApp.discrs goal
+
+      let matcherApp' ← matcherApp.transform (useSplitter := true)
+        (addEqualities := mask.map not)
+        (onParams := foldCalls fn oldIH)
+        (onMotive := fun xs _body => pure (absMotiveBody.beta (maskArray mask xs)))
+        (onAlt := fun expAltType alt => do
+          buildInductionBody fn toClear toPreserve expAltType oldIH newIH IHs alt)
+      return matcherApp'.toExpr
+
+  if let .letE n t v b _ := e then
+    let IHs := IHs ++ (← collectIHs fn oldIH newIH v)
+    let t' ← foldCalls fn oldIH t
+    let v' ← foldCalls fn oldIH v
+    return ← withLetDecl n t' v' fun x => do
+      let b' ← buildInductionBody fn toClear toPreserve goal oldIH newIH IHs (b.instantiate1 x)
+      mkLetFVars #[x] b'
+
+  if let some (n, t, v, b) := e.letFun? then
+    let IHs := IHs ++ (← collectIHs fn oldIH newIH v)
+    let t' ← foldCalls fn oldIH t
+    let v' ← foldCalls fn oldIH v
+    return ← withLocalDecl n .default t' fun x => do
+      let b' ← buildInductionBody fn toClear toPreserve goal oldIH newIH IHs (b.instantiate1 x)
+      mkLetFun x v' b'
+
+  buildInductionCase fn oldIH newIH toClear toPreserve goal IHs e
+
+partial def findFixF {α} (name : Name) (e : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α := do
+  lambdaTelescope e fun params body => do
+    if body.isAppOf ``WellFounded.fixF then
+      k params body
+    else if body.isAppOf ``WellFounded.fix then
+      findFixF name (← unfoldDefinition body) fun args e' => k (params ++ args) e'
+    else
+      throwError m!"Function {name} does not look like a function defined by well-founded " ++
+        m!"recursion.\nNB: If {name} is not itself recursive, but contains an inner recursive " ++
+        m!"function (via `let rec` or `where`), try `{name}.go` where `go` is name of the inner " ++
+        "function."
+
+/--
+Given a definition `foo` defined via `WellFounded.fixF`, derive a suitable induction principle
+`foo.induct` for it. See module doc for details.
+ -/
+def deriveUnaryInduction (name : Name) : MetaM Name := do
+  let inductName := .append name `induct
+  if ← hasConst inductName then return inductName
+
+  let info ← getConstInfoDefn name
+  findFixF name info.value fun params body => body.withApp fun f fixArgs => do
+    -- logInfo f!"{fixArgs}"
+    unless params.size > 0 do
+      throwError "Value of {name} is not a lambda application"
+    unless f.isConstOf ``WellFounded.fixF do
+      throwError "Term isn’t application of {``WellFounded.fixF}, but of {f}"
+    let #[argType, rel, _motive, body, arg, acc] := fixArgs |
+      throwError "Application of WellFounded.fixF has wrong arity {fixArgs.size}"
+    unless ← isDefEq arg params.back do
+      throwError "fixF application argument {arg} is not function argument "
+    let [argLevel, _motiveLevel] := f.constLevels! | unreachable!
+
+    let motiveType ← mkArrow argType (.sort levelZero)
+    withLocalDecl `motive .default motiveType fun motive => do
+
+    let e' := mkApp3 (.const ``WellFounded.fixF [argLevel, levelZero]) argType rel motive
+    let fn := mkAppN (.const name (info.levelParams.map mkLevelParam)) params.pop
+    let body' ← forallTelescope (← inferType e').bindingDomain! fun xs _ => do
+      let #[param, genIH] := xs | unreachable!
+      -- open body with the same arg
+      let body ← instantiateLambda body #[param]
+      removeLamda body fun oldIH body => do
+        let body' ← buildInductionBody fn #[genIH.fvarId!] #[] (.app motive param) oldIH genIH.fvarId! #[] body
+        if body'.containsFVar oldIH then
+          throwError m!"Did not fully eliminate {mkFVar oldIH} from induction principle body:{indentExpr body}"
+        mkLambdaFVars #[param, genIH] body'
+
+    let e' := mkApp3 e' body' arg acc
+
+    let e' ← mkLambdaFVars #[params.back] e'
+    let mvars ← getMVarsNoDelayed e'
+    let mvars ← mvars.mapM fun mvar => do
+      let (_, mvar) ← mvar.revertAfter motive.fvarId!
+      pure mvar
+    -- Using `mkLambdaFVars` on mvars directly does not reliably replace
+    -- the mvars with the parameter, in the presence of delayed assignemnts.
+    -- Also `abstractMVars` does not handle delayed assignments correctly (as of now).
+    -- So instead we bring suitable fvars into scope and use `assign`; this handles
+    -- delayed assignemnts correctly.
+    -- NB: This idiom only works because
+    -- * we know that the `MVars` have the right local context (thanks to `mvarId.revertAfter`)
+    -- * the MVars are independent (so we don’t need to reorder them)
+    -- * we do no need the mvars in their unassigned form later
+    let e' ← Meta.withLocalDecls
+      (mvars.mapIdx (fun i mvar => (s!"case{i.val+1}", .default, (fun _ => mvar.getType))))
+      fun xs => do
+        for mvar in mvars, x in xs do
+          mvar.assign x
+        let e' ← instantiateMVars e'
+        mkLambdaFVars xs e'
+
+    -- We could pass (usedOnly := true) below, and get nicer induction principles that
+    -- do do not mention odd unused parameters.
+    -- But the downside is that automatic instantiation of the principle (e.g. in a tactic
+    -- that derives them from an function application in the goal) is harder, as
+    -- one would have to infer or keep track of which parameters to pass.
+    -- So for now lets just keep them around.
+    let e' ← mkLambdaFVars (binderInfoForMVars := .default) (params.pop ++ #[motive]) e'
+    let e' ← instantiateMVars e'
+
+    let eTyp ← inferType e'
+    let eTyp ← elimOptParam eTyp
+    -- logInfo m!"eTyp: {eTyp}"
+    unless (← isTypeCorrect e') do
+      logError m!"failed to derive induction priciple:{indentExpr e'}"
+      check e'
+
+    addDecl <| Declaration.thmDecl
+      { name := inductName, levelParams := info.levelParams, type := eTyp, value := e' }
+    return inductName
+
+/--
+In the type of `value`, reduces
+* Beta-redexes
+* `PSigma.casesOn (PSigma.mk a b) (fun x y => k x y)  -->  k a b`
+* `PSum.casesOn (PSum.inl x) k₁ k₂                    -->  k₁ x`
+* `foo._unary (PSum.inl (PSigma.mk a b))              -->  foo a b`
+and then wraps `value` in an appropriate type hint.
+-/
+def cleanPackedArgs (eqnInfo : WF.EqnInfo) (value : Expr) : MetaM Expr := do
+  -- TODO: Make arities (or varnames) part of eqnInfo
+  let arities ← eqnInfo.declNames.mapM fun name => do
+      let ci ← getConstInfoDefn name
+      lambdaTelescope ci.value fun xs _body => return xs.size - eqnInfo.fixedPrefixSize
+
+  let t ← Meta.transform (← inferType value) (skipConstInApp := true) (pre := fun e => do
+    -- Need to beta-reduce first
+    let e' := e.headBeta
+    if e' != e then
+      return .visit e'
+    -- Look for PSigma redexes
+    if e.isAppOf ``PSigma.casesOn then
+      let args := e.getAppArgs
+      if 5 ≤ args.size then
+        let scrut := args[3]!
+        let k := args[4]!
+        let extra := args[5:]
+        if scrut.isAppOfArity ``PSigma.mk 4 then
+          let #[_, _, x, y] := scrut.getAppArgs | unreachable!
+          let e' := (k.beta #[x, y]).beta extra
+          return .visit e'
+    -- Look for PSum redexes
+    if e.isAppOf ``PSum.casesOn then
+      let args := e.getAppArgs
+      if 6 ≤ args.size then
+        let scrut := args[3]!
+        let k₁ := args[4]!
+        let k₂ := args[5]!
+        let extra := args[6:]
+        if scrut.isAppOfArity ``PSum.inl 3 then
+          let e' := (k₁.beta #[scrut.appArg!]).beta extra
+          return .visit e'
+        if scrut.isAppOfArity ``PSum.inr 3 then
+          let e' := (k₂.beta #[scrut.appArg!]).beta extra
+          return .visit e'
+    -- Look for _unary redexes
+    if e.isAppOf eqnInfo.declNameNonRec then
+      let args := e.getAppArgs
+      if eqnInfo.fixedPrefixSize + 1 ≤ args.size then
+        let packedArg := args.back
+          let (i, unpackedArgs) ← WF.unpackArg arities packedArg
+          let e' := .const eqnInfo.declNames[i]! e.getAppFn.constLevels!
+          let e' := mkAppN e' args.pop
+          let e' := mkAppN e' unpackedArgs
+          let e' := mkAppN e' args[eqnInfo.fixedPrefixSize+1:]
+          return .continue e'
+
+    return .continue e)
+  mkExpectedTypeHint value t
+
+/-- Given type `A ⊕' B ⊕' … ⊕' D`, return `[A, B, …, D]` -/
+partial def unpackPSum (type : Expr) : List Expr :=
+  if type.isAppOfArity ``PSum 2 then
+    if let #[a, b] := type.getAppArgs then
+      a :: unpackPSum b
+    else unreachable!
+  else
+    [type]
+
+/-- Given `A ⊗' B ⊗' … ⊗' D` and `R`, return `A → B → … → D → R` -/
+partial def uncurryPSumArrow (domain : Expr) (codomain : Expr) : MetaM Expr := do
+  if domain.isAppOfArity ``PSigma 2 then
+    let #[a, b] := domain.getAppArgs | unreachable!
+    withLocalDecl `x .default a fun x => do
+      mkForallFVars #[x] (← uncurryPSumArrow (b.beta #[x]) codomain)
+  else
+    mkArrow domain codomain
+
+/--
+Given expression `e` with type `(x : A ⊗' B ⊗' … ⊗' D) → R[x]`
+return expression of type `(x : A) → (y : B) → … → (z : D) → R[(x,y,z)]`
+-/
+partial def uncurryPSigma (e : Expr) : MetaM Expr := do
+  let packedDomain := (← inferType e).bindingDomain!
+  go packedDomain packedDomain #[]
+where
+  go (packedDomain domain : Expr) args : MetaM Expr :=  do
+    if domain.isAppOfArity ``PSigma 2 then
+      let #[a, b] := domain.getAppArgs | unreachable!
+      withLocalDecl `x .default a fun x => do
+        mkLambdaFVars #[x] (← go packedDomain (b.beta #[x]) (args.push x))
+    else
+      withLocalDecl `x .default domain fun x => do
+        let args := args.push x
+        let packedArg ← WF.mkUnaryArg packedDomain args
+        mkLambdaFVars #[x] (e.beta #[packedArg])
+
+/--
+Iterated `PSigma.casesOn`: Given `y : a ⊗' b ⊗' …` and a type `codomain`,
+and `alt : (x : a) → (y : b) → codomain`, uses `PSigma.casesOn` to invoke `alt` on `y`.
+
+This very is similar to `Lean.Predefinition.WF.mkPSigmaCasesOn`, but takes a lambda rather than
+free variables.
+-/
+partial def mkPSigmaNCasesOn (y : FVarId) (codomain : Expr) (alt : Expr) : MetaM Expr := do
+  let mvar ← mkFreshExprSyntheticOpaqueMVar codomain
+  let rec go (mvarId : MVarId) (y : FVarId) (ys : Array Expr) : MetaM Unit := mvarId.withContext do
+    if (← inferType (mkFVar y)).isAppOfArity ``PSigma 2 then
+      let #[s] ← mvarId.cases y | unreachable!
+      go s.mvarId s.fields[1]!.fvarId! (ys.push s.fields[0]!)
+    else
+      let ys := ys.push (mkFVar y)
+      mvarId.assign (alt.beta ys)
+  go mvar.mvarId! y #[]
+  instantiateMVars mvar
+
+/--
+Given expression `e` with type `(x : A) → (y : B[x]) → … → (z : D[x,y]) → R`
+returns an expression of type `(x : A ⊗' B ⊗' … ⊗' D) → R`.
+-/
+partial def curryPSigma (e : Expr) : MetaM Expr := do
+  let (d, codomain) ← forallTelescope (← inferType e) fun xs codomain => do
+    if xs.any (codomain.containsFVar ·.fvarId!) then
+      throwError "curryPSum: codomain depends on domain variables"
+    let mut d ← inferType xs.back
+    for x in xs.pop.reverse do
+      d ← mkLambdaFVars #[x] d
+      d ← mkAppOptM ``PSigma #[some (← inferType x), some d]
+    return (d, codomain)
+  withLocalDecl `x .default d fun x => do
+    let value ← mkPSigmaNCasesOn x.fvarId! codomain e
+    mkLambdaFVars #[x] value
+
+/--
+Given type `(a ⊗' b ⊕' c ⊗' d) → e`, brings `a → b → e` and `c → d → e`
+into scope as fresh local declarations and passes their FVars to the continuation `k`.
+The `name` is used to form the variable names; uses `name1`, `name2`, … if there are multiple.
+-/
+def withCurriedDecl {α} (name : String) (type : Expr) (k : Array Expr → MetaM α) : MetaM α := do
+  let some (d,c) := type.arrow? | throwError "withCurriedDecl: Expected arrow"
+  let motiveTypes ← (unpackPSum d).mapM (uncurryPSumArrow · c)
+  if let [t] := motiveTypes then
+    -- If a singleton, do not number the names.
+    withLocalDecl name .default t fun x => do k #[x]
+  else
+    go motiveTypes #[]
+where
+  go : List Expr → Array Expr → MetaM α
+  | [], acc => k acc
+  | t::ts, acc => do
+    let name := s!"{name}{acc.size+1}"
+    withLocalDecl name .default t fun x => do
+      go ts (acc.push x)
+
+
+/--
+Given expression `e` of type `(x : a ⊗' b ⊕' c ⊗' d) → e[x]`, wraps that expression
+to produce an expression of the isomorphic type
+```
+((x: a) → (y : b) → e[.inl (x,y)]) ∧ ((x : c) → (y : d) → e[.inr (x,y)])
+```
+-/
+def deMorganPSumPSigma (e : Expr) : MetaM Expr := do
+  let packedDomain := (← inferType e).bindingDomain!
+  let unaryTypes := unpackPSum packedDomain
+  shareIf (unaryTypes.length > 1) e fun e => do
+    let mut es := #[]
+    for unaryType in unaryTypes, i in [:unaryTypes.length] do
+      -- unary : (x : a ⊗ b) → e[inl x]
+      let unary ← withLocalDecl `x .default unaryType fun x => do
+          let packedArg ← WF.mkMutualArg unaryTypes.length packedDomain i x
+          mkLambdaFVars #[x] (e.beta #[packedArg])
+      -- nary : (x : a) → (y : b) → e[inl (x,y)]
+      let nary ← uncurryPSigma unary
+      es := es.push nary
+    mkAndIntroN es
+  where
+    shareIf (b : Bool) (e : Expr) (k : Expr → MetaM Expr) : MetaM Expr := do
+      if b then
+        withLetDecl `packed (← inferType e) e fun e => do mkLetFVars #[e] (← k e)
+      else
+        k e
+
+
+-- Adapted from PackMutual: TODO: Compare and unify
+/--
+  Combine/pack the values of the different definitions in a single value
+  `x` is `PSum`, and we use `PSum.casesOn` to select the appropriate `preDefs.value`.
+  See: `packMutual`.
+
+  Remark: this method does not replace the nested recursive `preDefValues` applications.
+  This step is performed by `transform` with the following `post` method.
+ -/
+private def packValues (x : Expr) (codomain : Expr) (preDefValues : Array Expr) : MetaM Expr := do
+  let varNames := preDefValues.map fun val =>
+    if val.isLambda then val.bindingName! else `x
+  let mvar ← mkFreshExprSyntheticOpaqueMVar codomain
+  let rec go (mvarId : MVarId) (x : FVarId) (i : Nat) : MetaM Unit := do
+    if i < preDefValues.size - 1 then
+      /-
+        Names for the `cases` tactics. The names are important to preserve the user provided names (unary functions).
+      -/
+      let givenNames : Array AltVarNames :=
+         if i == preDefValues.size - 2 then
+           #[{ varNames := [varNames[i]!] }, { varNames := [varNames[i+1]!] }]
+         else
+           #[{ varNames := [varNames[i]!] }]
+       let #[s₁, s₂] ← mvarId.cases x (givenNames := givenNames) | unreachable!
+      s₁.mvarId.assign (mkApp preDefValues[i]! s₁.fields[0]!).headBeta
+      go s₂.mvarId s₂.fields[0]!.fvarId! (i+1)
+    else
+      mvarId.assign (mkApp preDefValues[i]! (mkFVar x)).headBeta
+    termination_by preDefValues.size - 1 - i
+  go mvar.mvarId! x.fvarId! 0
+  instantiateMVars mvar
+
+
+/--
+Takes an induction principle where the motive is a `PSigma`/`PSum` type and
+unpacks it into a n-ary and (possibly) joint induction principle.
+-/
+def unpackMutualInduction (eqnInfo : WF.EqnInfo) (unaryInductName : Name) : MetaM Name := do
+  let inductName := if eqnInfo.declNames.size > 1 then
+    .append eqnInfo.declNames[0]! `mutual_induct
+  else
+    -- If there is no mutual recursion, generate the `foo.induct` directly.
+    .append eqnInfo.declNames[0]! `induct
+  if ← hasConst inductName then return inductName
+
+  let ci ← getConstInfo unaryInductName
+  let us := ci.levelParams
+  let value := .const ci.name (us.map mkLevelParam)
+  let motivePos ← forallTelescope ci.type fun xs concl => concl.withApp fun motive targets => do
+    unless motive.isFVar && targets.size = 1 && targets.all (·.isFVar) do
+      throwError "conclusion {concl} does not look like a packed motive application"
+    let packedTarget := targets[0]!
+    unless xs.back == packedTarget do
+      throwError "packed target not last argument to {unaryInductName}"
+    let some motivePos := xs.findIdx? (· == motive)
+      | throwError "could not find motive {motive} in {xs}"
+    pure motivePos
+  let value ← forallBoundedTelescope ci.type motivePos fun params type => do
+    let value := mkAppN value params
+    -- Next parameter is the motive (motive : a ⊗' b ⊕' c ⊗' d → Prop).
+    let packedMotiveType := type.bindingDomain!
+    -- Bring unpacked motives (motive1 : a → b → Prop and motive2 : c → d → Prop) into scope
+    withCurriedDecl "motive" packedMotiveType fun motives => do
+      -- Combine them into a packed motive (motive : a ⊗' b ⊕' c ⊗' d → Prop), and use that
+      let motive ← forallBoundedTelescope packedMotiveType (some 1) fun xs motiveCodomain => do
+        let #[x] := xs | throwError "packedMotiveType is not a forall: {packedMotiveType}"
+        let packedMotives ← motives.mapM curryPSigma
+        let motiveBody ← packValues x motiveCodomain packedMotives
+        mkLambdaFVars xs motiveBody
+      let type ← instantiateForall type #[motive]
+      let value := mkApp value motive
+      -- Bring the rest into scope
+      forallTelescope type fun xs _concl => do
+        let alts := xs.pop
+        let value := mkAppN value alts
+        let value ← deMorganPSumPSigma value
+        let value ← mkLambdaFVars alts value
+        let value ← mkLambdaFVars motives value
+        let value ← mkLambdaFVars params value
+        check value
+        let value ← cleanPackedArgs eqnInfo value
+        return value
+
+  unless ← isTypeCorrect value do
+    logError m!"failed to unpack induction priciple:{indentExpr value}"
+    check value
+  let type ← inferType value
+  let type ← elimOptParam type
+
+  addDecl <| Declaration.thmDecl
+    { name := inductName, levelParams := ci.levelParams, type, value }
+  return inductName
+
+/-- Given `foo._unary.induct`, define `foo.mutual_induct` and then `foo.induct`, `bar.induct`, … -/
+def deriveUnpackedInduction (eqnInfo : WF.EqnInfo) (unaryInductName : Name): MetaM Unit := do
+  let unpackedInductName ← unpackMutualInduction eqnInfo unaryInductName
+  let ci ← getConstInfo unpackedInductName
+  let levelParams := ci.levelParams
+
+  for name in eqnInfo.declNames, idx in [:eqnInfo.declNames.size] do
+    let inductName := .append name `induct
+    unless ← hasConst inductName do
+      let value ← forallTelescope ci.type fun xs _body => do
+        let value := .const ci.name (levelParams.map mkLevelParam)
+        let value := mkAppN value xs
+        let value := mkProjAndN eqnInfo.declNames.size idx value
+        mkLambdaFVars xs value
+      let type ← inferType value
+      addDecl <| Declaration.thmDecl { name := inductName, levelParams, type, value }
+
+/--
+Given a recursively defined function `foo`, derives `foo.induct`. See the module doc for details.
+-/
+def deriveInduction (name : Name) : MetaM Unit := do
+  if let some eqnInfo := WF.eqnInfoExt.find? (← getEnv) name then
+    let unaryInductName ← deriveUnaryInduction eqnInfo.declNameNonRec
+    unless eqnInfo.declNameNonRec = name do
+      deriveUnpackedInduction eqnInfo unaryInductName
+  else
+    _ ← deriveUnaryInduction name
+
+@[builtin_command_elab Parser.Command.deriveInduction]
+def elabDeriveInduction : Command.CommandElab := fun stx => Command.runTermElabM fun _xs => do
+  let ident := stx[1]
+  let name ← resolveGlobalConstNoOverloadWithInfo ident
+  deriveInduction name
+
+end Lean.Tactic.FunInd

src/Lean/Meta/Tactic/LibrarySearch.lean

@@ -150,9 +150,12 @@ Candidate-finding function that uses a strict discrimination tree for resolution
 def mkImportFinder : IO CandidateFinder := do
   let ref ← IO.mkRef none
   pure fun ty => do
+    let ngen ← getNGen
+    let (childNGen, ngen) := ngen.mkChild
+    setNGen ngen
     let importTree ← (←ref.get).getDM $ do
       profileitM Exception  "librarySearch launch" (←getOptions) $
-        createImportedEnvironment (←getEnv) (constantsPerTask := constantsPerTask) addImport
+        createImportedEnvironment childNGen (←getEnv) (constantsPerTask := constantsPerTask) addImport
     let (imports, importTree) ← importTree.getMatch ty
     ref.set importTree
     pure imports

src/Lean/Meta/Tactic/LinearArith/Nat/Basic.lean

@@ -6,6 +6,7 @@ Authors: Leonardo de Moura
 prelude
 import Lean.Meta.Check
 import Lean.Meta.Offset
+import Lean.Meta.AppBuilder
 import Lean.Meta.KExprMap
 
 namespace Lean.Meta.Linear.Nat
@@ -43,15 +44,15 @@ def LinearExpr.toArith (ctx : Array Expr) (e : LinearExpr) : MetaM Expr := do
   match e with
   | num v    => return mkNatLit v
   | var i    => return ctx[i]!
-  | add a b  => mkAdd (← toArith ctx a) (← toArith ctx b)
-  | mulL k a => mkMul (mkNatLit k) (← toArith ctx a)
-  | mulR a k => mkMul (← toArith ctx a) (mkNatLit k)
+  | add a b  => return mkNatAdd (← toArith ctx a) (← toArith ctx b)
+  | mulL k a => return mkNatMul (mkNatLit k) (← toArith ctx a)
+  | mulR a k => return mkNatMul (← toArith ctx a) (mkNatLit k)
 
 def LinearCnstr.toArith (ctx : Array Expr) (c : LinearCnstr) : MetaM Expr := do
   if c.eq then
-    mkEq (← LinearExpr.toArith ctx c.lhs) (← LinearExpr.toArith ctx c.rhs)
+    return mkNatEq (← LinearExpr.toArith ctx c.lhs) (← LinearExpr.toArith ctx c.rhs)
   else
-    return mkApp4 (mkConst ``LE.le [levelZero]) (mkConst ``Nat) (mkConst ``instLENat) (← LinearExpr.toArith ctx c.lhs) (← LinearExpr.toArith ctx c.rhs)
+    return mkNatLE (← LinearExpr.toArith ctx c.lhs) (← LinearExpr.toArith ctx c.rhs)
 
 namespace ToLinear
 
@@ -82,57 +83,55 @@ partial def toLinearExpr (e : Expr) : M LinearExpr := do
   | _                     => addAsVar e
 where
   visit (e : Expr) : M LinearExpr := do
-    match_expr e with
-    | Nat.succ a => return inc (← toLinearExpr a)
-    | Nat.add a b => return add (← toLinearExpr a) (← toLinearExpr b)
-    | Nat.mul a b =>
+    let mul (a b : Expr) := do
       match (← evalNat a |>.run) with
       | some k => return mulL k (← toLinearExpr b)
       | none => match (← evalNat b |>.run) with
         | some k => return mulR (← toLinearExpr a) k
         | none => addAsVar e
-    | _ =>
-      let e ← instantiateMVarsIfMVarApp e
-      let f := e.getAppFn
-      if f.isConst && isNatProjInst f.constName! e.getAppNumArgs then
-        let some e ← unfoldProjInst? e | addAsVar e
-        toLinearExpr e
-      else
-        addAsVar e
+    match_expr e with
+    | OfNat.ofNat _ n i =>
+      if (← isInstOfNatNat i) then toLinearExpr n
+      else addAsVar e
+    | Nat.succ a => return inc (← toLinearExpr a)
+    | Nat.add a b => return add (← toLinearExpr a) (← toLinearExpr b)
+    | Add.add _ i a b =>
+      if (← isInstAddNat i) then return add (← toLinearExpr a) (← toLinearExpr b)
+      else addAsVar e
+    | HAdd.hAdd _ _ _ i a b =>
+      if (← isInstHAddNat i) then return add (← toLinearExpr a) (← toLinearExpr b)
+      else addAsVar e
+    | Nat.mul a b => mul a b
+    | Mul.mul _ i a b =>
+      if (← isInstMulNat i) then mul a b
+      else addAsVar e
+    | HMul.hMul _ _ _ i a b =>
+      if (← isInstHMulNat i) then mul a b
+      else addAsVar e
+    | _ => addAsVar e
 
-partial def toLinearCnstr? (e : Expr) : M (Option LinearCnstr) := do
-  let f := e.getAppFn
-  match f with
-  | Expr.mvar .. =>
-    let eNew ← instantiateMVars e
-    if eNew != e then
-      toLinearCnstr? eNew
-    else
-      return none
-  | Expr.const declName .. =>
-    let numArgs := e.getAppNumArgs
-    if declName == ``Eq && numArgs == 3 then
-      return some { eq := true, lhs := (← toLinearExpr (e.getArg! 1)), rhs := (← toLinearExpr (e.getArg! 2)) }
-    else if declName == ``Nat.le && numArgs == 2 then
-      return some { eq := false, lhs := (← toLinearExpr (e.getArg! 0)), rhs := (← toLinearExpr (e.getArg! 1)) }
-    else if declName == ``Nat.lt && numArgs == 2 then
-      return some { eq := false, lhs := (← toLinearExpr (e.getArg! 0)).inc, rhs := (← toLinearExpr (e.getArg! 1)) }
-    else if numArgs == 4 && (declName == ``GE.ge || declName == ``GT.gt) then
-      if let some e ← unfoldDefinition? e then
-        toLinearCnstr? e
-      else
-        return none
-    else if numArgs == 4 && (declName == ``LE.le || declName == ``LT.lt) then
-      if (← isDefEq (e.getArg! 0) (mkConst ``Nat)) then
-        if let some e ← unfoldProjInst? e then
-          toLinearCnstr? e
-        else
-          return none
-      else
-        return none
-    else
-      return none
-  | _ => return none
+partial def toLinearCnstr? (e : Expr) : M (Option LinearCnstr) := OptionT.run do
+  match_expr e with
+  | Eq α a b =>
+    let_expr Nat ← α | failure
+    return { eq := true, lhs := (← toLinearExpr a), rhs := (← toLinearExpr b) }
+  | Nat.le a b =>
+    return { eq := false, lhs := (← toLinearExpr a), rhs := (← toLinearExpr b) }
+  | Nat.lt a b =>
+    return { eq := false, lhs := (← toLinearExpr a).inc, rhs := (← toLinearExpr b) }
+  | LE.le _ i a b =>
+    guard (← isInstLENat i)
+    return { eq := false, lhs := (← toLinearExpr a), rhs := (← toLinearExpr b) }
+  | LT.lt _ i a b =>
+    guard (← isInstLTNat i)
+    return { eq := false, lhs := (← toLinearExpr a).inc, rhs := (← toLinearExpr b) }
+  | GE.ge _ i a b =>
+    guard (← isInstLENat i)
+    return { eq := false, lhs := (← toLinearExpr b), rhs := (← toLinearExpr a) }
+  | GT.gt _ i a b =>
+    guard (← isInstLTNat i)
+    return { eq := false, lhs := (← toLinearExpr b).inc, rhs := (← toLinearExpr a) }
+  | _ => failure
 
 def run (x : M α) : MetaM (α × Array Expr) := do
   let (a, s) ← x.run {}

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

@@ -31,176 +31,184 @@ def fromExpr? (e : Expr) : SimpM (Option Literal) := do
 Helper function for reducing homogenous unary bitvector operators.
 -/
 @[inline] def reduceUnary (declName : Name) (arity : Nat)
-    (op : {n : Nat} → BitVec n → BitVec n) (e : Expr) : SimpM Step := do
+    (op : {n : Nat} → BitVec n → BitVec n) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op v.value) }
+  return .done <| toExpr (op v.value)
 
 /--
 Helper function for reducing homogenous binary bitvector operators.
 -/
 @[inline] def reduceBin (declName : Name) (arity : Nat)
-    (op : {n : Nat} → BitVec n → BitVec n → BitVec n) (e : Expr) : SimpM Step := do
+    (op : {n : Nat} → BitVec n → BitVec n → BitVec n) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
   let some v₂ ← fromExpr? e.appArg! | return .continue
   if h : v₁.n = v₂.n then
-    trace[Meta.debug] "reduce [{declName}] {v₁.value}, {v₂.value}"
-    return .done { expr := toExpr (op v₁.value (h ▸ v₂.value)) }
+    return .done <| toExpr (op v₁.value (h ▸ v₂.value))
   else
     return .continue
 
 /-- Simplification procedure for `zeroExtend` and `signExtend` on `BitVec`s. -/
 @[inline] def reduceExtend (declName : Name)
-    (op : {n : Nat} → (m : Nat) → BitVec n → BitVec m) (e : Expr) : SimpM Step := do
+    (op : {n : Nat} → (m : Nat) → BitVec n → BitVec m) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName 3 do return .continue
   let some v ← fromExpr? e.appArg! | return .continue
   let some n ← Nat.fromExpr? e.appFn!.appArg! | return .continue
-  return .done { expr := toExpr (op n v.value) }
+  return .done <| toExpr (op n v.value)
 
 /--
 Helper function for reducing bitvector functions such as `getLsb` and `getMsb`.
 -/
 @[inline] def reduceGetBit (declName : Name) (op : {n : Nat} → BitVec n → Nat → Bool) (e : Expr)
-    : SimpM Step := do
+    : SimpM DStep := do
   unless e.isAppOfArity declName 3 do return .continue
   let some v ← fromExpr? e.appFn!.appArg! | return .continue
   let some i ← Nat.fromExpr? e.appArg! | return .continue
   let b := op v.value i
-  return .done { expr := toExpr b }
+  return .done <| toExpr b
 
 /--
 Helper function for reducing bitvector functions such as `shiftLeft` and `rotateRight`.
 -/
 @[inline] def reduceShift (declName : Name) (arity : Nat)
-    (op : {n : Nat} → BitVec n → Nat → BitVec n) (e : Expr) : SimpM Step := do
+    (op : {n : Nat} → BitVec n → Nat → BitVec n) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v ← fromExpr? e.appFn!.appArg! | return .continue
   let some i ← Nat.fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op v.value i) }
+  return .done <| toExpr (op v.value i)
 
 /--
 Helper function for reducing bitvector predicates.
 -/
 @[inline] def reduceBinPred (declName : Name) (arity : Nat)
-    (op : {n : Nat} → BitVec n → BitVec n → Bool) (e : Expr) (isProp := true) : SimpM Step := do
+    (op : {n : Nat} → BitVec n → BitVec n → Bool) (e : Expr) : SimpM Step := do
   unless e.isAppOfArity declName arity do return .continue
   let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
   let some v₂ ← fromExpr? e.appArg! | return .continue
   if h : v₁.n = v₂.n then
     let b := op v₁.value (h ▸ v₂.value)
-    if isProp then
-      evalPropStep e b
-    else
-      return .done { expr := toExpr b }
+    evalPropStep e b
   else
     return .continue
 
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat)
+    (op : {n : Nat} → BitVec n → BitVec n → Bool) (e : Expr) : SimpM DStep := do
+  unless e.isAppOfArity declName arity do return .continue
+  let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
+  let some v₂ ← fromExpr? e.appArg! | return .continue
+  if h : v₁.n = v₂.n then
+    let b := op v₁.value (h ▸ v₂.value)
+    return .done <| toExpr b
+  else
+    return .continue
+
+
 /-- Simplification procedure for negation of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceNeg ((- _ : BitVec _)) := reduceUnary ``Neg.neg 3 (- ·)
+builtin_dsimproc [simp, seval] reduceNeg ((- _ : BitVec _)) := reduceUnary ``Neg.neg 3 (- ·)
 /-- Simplification procedure for bitwise not of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceNot ((~~~ _ : BitVec _)) :=
+builtin_dsimproc [simp, seval] reduceNot ((~~~ _ : BitVec _)) :=
   reduceUnary ``Complement.complement 3 (~~~ ·)
 /-- Simplification procedure for absolute value of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceAbs (BitVec.abs _) := reduceUnary ``BitVec.abs 2 BitVec.abs
+builtin_dsimproc [simp, seval] reduceAbs (BitVec.abs _) := reduceUnary ``BitVec.abs 2 BitVec.abs
 /-- Simplification procedure for bitwise and of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceAnd ((_ &&& _ : BitVec _)) := reduceBin ``HAnd.hAnd 6 (· &&& ·)
+builtin_dsimproc [simp, seval] reduceAnd ((_ &&& _ : BitVec _)) := reduceBin ``HAnd.hAnd 6 (· &&& ·)
 /-- Simplification procedure for bitwise or of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceOr ((_ ||| _ : BitVec _)) := reduceBin ``HOr.hOr 6 (· ||| ·)
+builtin_dsimproc [simp, seval] reduceOr ((_ ||| _ : BitVec _)) := reduceBin ``HOr.hOr 6 (· ||| ·)
 /-- Simplification procedure for bitwise xor of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceXOr ((_ ^^^ _ : BitVec _)) := reduceBin ``HXor.hXor 6 (· ^^^ ·)
+builtin_dsimproc [simp, seval] reduceXOr ((_ ^^^ _ : BitVec _)) := reduceBin ``HXor.hXor 6 (· ^^^ ·)
 /-- Simplification procedure for addition of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceAdd ((_ + _ : BitVec _)) := reduceBin ``HAdd.hAdd 6 (· + ·)
+builtin_dsimproc [simp, seval] reduceAdd ((_ + _ : BitVec _)) := reduceBin ``HAdd.hAdd 6 (· + ·)
 /-- Simplification procedure for multiplication of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceMul ((_ * _ : BitVec _)) := reduceBin ``HMul.hMul 6 (· * ·)
+builtin_dsimproc [simp, seval] reduceMul ((_ * _ : BitVec _)) := reduceBin ``HMul.hMul 6 (· * ·)
 /-- Simplification procedure for subtraction of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSub ((_ - _ : BitVec _)) := reduceBin ``HSub.hSub 6 (· - ·)
+builtin_dsimproc [simp, seval] reduceSub ((_ - _ : BitVec _)) := reduceBin ``HSub.hSub 6 (· - ·)
 /-- Simplification procedure for division of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceDiv ((_ / _ : BitVec _)) := reduceBin ``HDiv.hDiv 6 (· / ·)
+builtin_dsimproc [simp, seval] reduceDiv ((_ / _ : BitVec _)) := reduceBin ``HDiv.hDiv 6 (· / ·)
 /-- Simplification procedure for the modulo operation on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceMod ((_ % _ : BitVec _)) := reduceBin ``HMod.hMod 6 (· % ·)
+builtin_dsimproc [simp, seval] reduceMod ((_ % _ : BitVec _)) := reduceBin ``HMod.hMod 6 (· % ·)
 /-- Simplification procedure for for the unsigned modulo operation on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceUMod ((umod _ _ : BitVec _)) := reduceBin ``umod 3 umod
+builtin_dsimproc [simp, seval] reduceUMod ((umod _ _ : BitVec _)) := reduceBin ``umod 3 umod
 /-- Simplification procedure for unsigned division of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceUDiv ((udiv _ _ : BitVec _)) := reduceBin ``udiv 3 udiv
+builtin_dsimproc [simp, seval] reduceUDiv ((udiv _ _ : BitVec _)) := reduceBin ``udiv 3 udiv
 /-- Simplification procedure for division of `BitVec`s using the SMT-Lib conventions. -/
-builtin_simproc [simp, seval] reduceSMTUDiv ((smtUDiv _ _ : BitVec _)) := reduceBin ``smtUDiv 3 smtUDiv
+builtin_dsimproc [simp, seval] reduceSMTUDiv ((smtUDiv _ _ : BitVec _)) := reduceBin ``smtUDiv 3 smtUDiv
 /-- Simplification procedure for the signed modulo operation on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSMod ((smod _ _ : BitVec _)) := reduceBin ``smod 3 smod
+builtin_dsimproc [simp, seval] reduceSMod ((smod _ _ : BitVec _)) := reduceBin ``smod 3 smod
 /-- Simplification procedure for signed remainder of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSRem ((srem _ _ : BitVec _)) := reduceBin ``srem 3 srem
+builtin_dsimproc [simp, seval] reduceSRem ((srem _ _ : BitVec _)) := reduceBin ``srem 3 srem
 /-- Simplification procedure for signed t-division of `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSDiv ((sdiv _ _ : BitVec _)) := reduceBin ``sdiv 3 sdiv
+builtin_dsimproc [simp, seval] reduceSDiv ((sdiv _ _ : BitVec _)) := reduceBin ``sdiv 3 sdiv
 /-- Simplification procedure for signed division of `BitVec`s using the SMT-Lib conventions. -/
-builtin_simproc [simp, seval] reduceSMTSDiv ((smtSDiv _ _ : BitVec _)) := reduceBin ``smtSDiv 3 smtSDiv
+builtin_dsimproc [simp, seval] reduceSMTSDiv ((smtSDiv _ _ : BitVec _)) := reduceBin ``smtSDiv 3 smtSDiv
 /-- Simplification procedure for `getLsb` (lowest significant bit) on `BitVec`. -/
-builtin_simproc [simp, seval] reduceGetLsb (getLsb _ _) := reduceGetBit ``getLsb getLsb
+builtin_dsimproc [simp, seval] reduceGetLsb (getLsb _ _) := reduceGetBit ``getLsb getLsb
 /-- Simplification procedure for `getMsb` (most significant bit) on `BitVec`. -/
-builtin_simproc [simp, seval] reduceGetMsb (getMsb _ _) := reduceGetBit ``getMsb getMsb
+builtin_dsimproc [simp, seval] reduceGetMsb (getMsb _ _) := reduceGetBit ``getMsb getMsb
 
 /-- Simplification procedure for shift left on `BitVec`. -/
-builtin_simproc [simp, seval] reduceShiftLeft (BitVec.shiftLeft _ _) :=
+builtin_dsimproc [simp, seval] reduceShiftLeft (BitVec.shiftLeft _ _) :=
   reduceShift ``BitVec.shiftLeft 3 BitVec.shiftLeft
 /-- Simplification procedure for unsigned shift right on `BitVec`. -/
-builtin_simproc [simp, seval] reduceUShiftRight (BitVec.ushiftRight _ _) :=
+builtin_dsimproc [simp, seval] reduceUShiftRight (BitVec.ushiftRight _ _) :=
   reduceShift ``BitVec.ushiftRight 3 BitVec.ushiftRight
 /-- Simplification procedure for signed shift right on `BitVec`. -/
-builtin_simproc [simp, seval] reduceSShiftRight (BitVec.sshiftRight _ _) :=
+builtin_dsimproc [simp, seval] reduceSShiftRight (BitVec.sshiftRight _ _) :=
   reduceShift ``BitVec.sshiftRight 3 BitVec.sshiftRight
 /-- Simplification procedure for shift left on `BitVec`. -/
-builtin_simproc [simp, seval] reduceHShiftLeft ((_ <<< _ : BitVec _)) :=
+builtin_dsimproc [simp, seval] reduceHShiftLeft ((_ <<< _ : BitVec _)) :=
   reduceShift ``HShiftLeft.hShiftLeft 6 (· <<< ·)
 /-- Simplification procedure for shift right on `BitVec`. -/
-builtin_simproc [simp, seval] reduceHShiftRight ((_ >>> _ : BitVec _)) :=
+builtin_dsimproc [simp, seval] reduceHShiftRight ((_ >>> _ : BitVec _)) :=
   reduceShift ``HShiftRight.hShiftRight 6 (· >>> ·)
 /-- Simplification procedure for rotate left on `BitVec`. -/
-builtin_simproc [simp, seval] reduceRotateLeft (BitVec.rotateLeft _ _) :=
+builtin_dsimproc [simp, seval] reduceRotateLeft (BitVec.rotateLeft _ _) :=
   reduceShift ``BitVec.rotateLeft 3 BitVec.rotateLeft
 /-- Simplification procedure for rotate right on `BitVec`. -/
-builtin_simproc [simp, seval] reduceRotateRight (BitVec.rotateRight _ _) :=
+builtin_dsimproc [simp, seval] reduceRotateRight (BitVec.rotateRight _ _) :=
   reduceShift ``BitVec.rotateRight 3 BitVec.rotateRight
 
 /-- Simplification procedure for append on `BitVec`. -/
-builtin_simproc [simp, seval] reduceAppend ((_ ++ _ : BitVec _)) := fun e => do
+builtin_dsimproc [simp, seval] reduceAppend ((_ ++ _ : BitVec _)) := fun e => do
   let_expr HAppend.hAppend _ _ _ _ a b ← e | return .continue
   let some v₁ ← fromExpr? a | return .continue
   let some v₂ ← fromExpr? b | return .continue
-  return .done { expr := toExpr (v₁.value ++ v₂.value) }
+  return .done <| toExpr (v₁.value ++ v₂.value)
 
 /-- Simplification procedure for casting `BitVec`s along an equality of the size. -/
-builtin_simproc [simp, seval] reduceCast (cast _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceCast (cast _ _) := fun e => do
   let_expr cast _ m _ v ← e | return .continue
   let some v ← fromExpr? v | return .continue
   let some m ← Nat.fromExpr? m | return .continue
-  return .done { expr := toExpr (BitVec.ofNat m v.value.toNat) }
+  return .done <| toExpr (BitVec.ofNat m v.value.toNat)
 
 /-- Simplification procedure for `BitVec.toNat`. -/
-builtin_simproc [simp, seval] reduceToNat (BitVec.toNat _) := fun e => do
+builtin_dsimproc [simp, seval] reduceToNat (BitVec.toNat _) := fun e => do
   let_expr BitVec.toNat _ v ← e | return .continue
   let some v ← fromExpr? v | return .continue
-  return .done { expr := mkNatLit v.value.toNat }
+  return .done <| mkNatLit v.value.toNat
 
 /-- Simplification procedure for `BitVec.toInt`. -/
-builtin_simproc [simp, seval] reduceToInt (BitVec.toInt _) := fun e => do
+builtin_dsimproc [simp, seval] reduceToInt (BitVec.toInt _) := fun e => do
   let_expr BitVec.toInt _ v ← e | return .continue
   let some v ← fromExpr? v | return .continue
-  return .done { expr := toExpr v.value.toInt }
+  return .done <| toExpr v.value.toInt
 
 /-- Simplification procedure for `BitVec.ofInt`. -/
-builtin_simproc [simp, seval] reduceOfInt (BitVec.ofInt _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceOfInt (BitVec.ofInt _ _) := fun e => do
   let_expr BitVec.ofInt n i ← e | return .continue
   let some n ← Nat.fromExpr? n | return .continue
   let some i ← Int.fromExpr? i | return .continue
-  return .done { expr := toExpr (BitVec.ofInt n i) }
+  return .done <| toExpr (BitVec.ofInt n i)
 
 /-- Simplification procedure for ensuring `BitVec.ofNat` literals are normalized. -/
-builtin_simproc [simp, seval] reduceOfNat (BitVec.ofNat _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceOfNat (BitVec.ofNat _ _) := fun e => do
   let_expr BitVec.ofNat n v ← e | return .continue
   let some n ← Nat.fromExpr? n | return .continue
   let some v ← Nat.fromExpr? v | return .continue
   let bv := BitVec.ofNat n v
   if bv.toNat == v then return .continue -- already normalized
-  return .done { expr := toExpr (BitVec.ofNat n v) }
+  return .done <| toExpr (BitVec.ofNat n v)
 
 /-- Simplification procedure for `<` on `BitVec`s. -/
 builtin_simproc [simp, seval] reduceLT (( _ : BitVec _) < _)  := reduceBinPred ``LT.lt 4 (· < ·)
@@ -212,71 +220,71 @@ builtin_simproc [simp, seval] reduceGT (( _ : BitVec _) > _)  := reduceBinPred `
 builtin_simproc [simp, seval] reduceGE (( _ : BitVec _) ≥ _)  := reduceBinPred ``GE.ge 4 (. ≥ .)
 
 /-- Simplification procedure for unsigned less than `ult` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceULT (BitVec.ult _ _) :=
-  reduceBinPred ``BitVec.ult 3 BitVec.ult (isProp := false)
+builtin_dsimproc [simp, seval] reduceULT (BitVec.ult _ _) :=
+  reduceBoolPred ``BitVec.ult 3 BitVec.ult
 /-- Simplification procedure for unsigned less than or equal `ule` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceULE (BitVec.ule _ _) :=
-  reduceBinPred ``BitVec.ule 3 BitVec.ule (isProp := false)
+builtin_dsimproc [simp, seval] reduceULE (BitVec.ule _ _) :=
+  reduceBoolPred ``BitVec.ule 3 BitVec.ule
 /-- Simplification procedure for signed less than `slt` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSLT (BitVec.slt _ _) :=
-  reduceBinPred ``BitVec.slt 3 BitVec.slt (isProp := false)
+builtin_dsimproc [simp, seval] reduceSLT (BitVec.slt _ _) :=
+  reduceBoolPred ``BitVec.slt 3 BitVec.slt
 /-- Simplification procedure for signed less than or equal `sle` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSLE (BitVec.sle _ _) :=
-  reduceBinPred ``BitVec.sle 3 BitVec.sle (isProp := false)
+builtin_dsimproc [simp, seval] reduceSLE (BitVec.sle _ _) :=
+  reduceBoolPred ``BitVec.sle 3 BitVec.sle
 
 /-- Simplification procedure for `zeroExtend'` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceZeroExtend' (zeroExtend' _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceZeroExtend' (zeroExtend' _ _) := fun e => do
   let_expr zeroExtend' _ w _ v ← e | return .continue
   let some v ← fromExpr? v | return .continue
   let some w ← Nat.fromExpr? w | return .continue
   if h : v.n ≤ w then
-    return .done { expr := toExpr (v.value.zeroExtend' h) }
+    return .done <| toExpr (v.value.zeroExtend' h)
   else
     return .continue
 
 /-- Simplification procedure for `shiftLeftZeroExtend` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceShiftLeftZeroExtend (shiftLeftZeroExtend _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceShiftLeftZeroExtend (shiftLeftZeroExtend _ _) := fun e => do
   let_expr shiftLeftZeroExtend _ v m ← e | return .continue
   let some v ← fromExpr? v | return .continue
   let some m ← Nat.fromExpr? m | return .continue
-  return .done { expr := toExpr (v.value.shiftLeftZeroExtend m) }
+  return .done <| toExpr (v.value.shiftLeftZeroExtend m)
 
 /-- Simplification procedure for `extractLsb'` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceExtracLsb' (extractLsb' _ _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceExtracLsb' (extractLsb' _ _ _) := fun e => do
   let_expr extractLsb' _ start len v ← e | return .continue
   let some v ← fromExpr? v | return .continue
   let some start ← Nat.fromExpr? start | return .continue
   let some len ← Nat.fromExpr? len | return .continue
-  return .done { expr := toExpr (v.value.extractLsb' start len) }
+  return .done <| toExpr (v.value.extractLsb' start len)
 
 /-- Simplification procedure for `replicate` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceReplicate (replicate _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceReplicate (replicate _ _) := fun e => do
   let_expr replicate _ i v ← e | return .continue
   let some v ← fromExpr? v | return .continue
   let some i ← Nat.fromExpr? i | return .continue
-  return .done { expr := toExpr (v.value.replicate i) }
+  return .done <| toExpr (v.value.replicate i)
 
 /-- Simplification procedure for `zeroExtend` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceZeroExtend (zeroExtend _ _) := reduceExtend ``zeroExtend zeroExtend
+builtin_dsimproc [simp, seval] reduceZeroExtend (zeroExtend _ _) := reduceExtend ``zeroExtend zeroExtend
 
 /-- Simplification procedure for `signExtend` on `BitVec`s. -/
-builtin_simproc [simp, seval] reduceSignExtend (signExtend _ _) := reduceExtend ``signExtend signExtend
+builtin_dsimproc [simp, seval] reduceSignExtend (signExtend _ _) := reduceExtend ``signExtend signExtend
 
 /-- Simplification procedure for `allOnes` -/
-builtin_simproc [simp, seval] reduceAllOnes (allOnes _) := fun e => do
+builtin_dsimproc [simp, seval] reduceAllOnes (allOnes _) := fun e => do
   let_expr allOnes n ← e | return .continue
   let some n ← Nat.fromExpr? n | return .continue
-  return .done { expr := toExpr (allOnes n) }
+  return .done <| toExpr (allOnes n)
 
-builtin_simproc [simp, seval] reduceBitVecOfFin (BitVec.ofFin _)  := fun e => do
+builtin_dsimproc [simp, seval] reduceBitVecOfFin (BitVec.ofFin _)  := fun e => do
   let_expr BitVec.ofFin w v ← e | return .continue
   let some w ← evalNat w |>.run | return .continue
   let some ⟨_, v⟩ ← getFinValue? v | return .continue
-  return .done { expr := toExpr (BitVec.ofNat w v.val) }
+  return .done <| toExpr (BitVec.ofNat w v.val)
 
-builtin_simproc [simp, seval] reduceBitVecToFin (BitVec.toFin _)  := fun e => do
+builtin_dsimproc [simp, seval] reduceBitVecToFin (BitVec.toFin _)  := fun e => do
   let_expr BitVec.toFin _ v ← e | return .continue
   let some ⟨_, v⟩ ← getBitVecValue? v | return .continue
-  return .done { expr := toExpr v.toFin }
+  return .done <| toExpr v.toFin
 
 end BitVec

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

@@ -14,10 +14,10 @@ open Lean Meta Simp
 def fromExpr? (e : Expr) : SimpM (Option Char) :=
   getCharValue? e
 
-@[inline] def reduceUnary [ToExpr α] (declName : Name) (op : Char → α) (arity : Nat := 1) (e : Expr) : SimpM Step := do
+@[inline] def reduceUnary [ToExpr α] (declName : Name) (op : Char → α) (arity : Nat := 1) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some c ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op c) }
+  return .done <| toExpr (op c)
 
 @[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Char → Char → Bool) (e : Expr) : SimpM Step := do
   unless e.isAppOfArity declName arity do return .continue
@@ -25,47 +25,47 @@ def fromExpr? (e : Expr) : SimpM (Option Char) :=
   let some m ← fromExpr? e.appArg! | return .continue
   evalPropStep e (op n m)
 
-@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Char → Char → Bool) (e : Expr) : SimpM Step := do
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Char → Char → Bool) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appFn!.appArg! | return .continue
   let some m ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
-builtin_simproc [simp, seval] reduceToLower (Char.toLower _) := reduceUnary ``Char.toLower Char.toLower
-builtin_simproc [simp, seval] reduceToUpper (Char.toUpper _) := reduceUnary ``Char.toUpper Char.toUpper
-builtin_simproc [simp, seval] reduceToNat (Char.toNat _) := reduceUnary ``Char.toNat Char.toNat
-builtin_simproc [simp, seval] reduceIsWhitespace (Char.isWhitespace _) := reduceUnary ``Char.isWhitespace Char.isWhitespace
-builtin_simproc [simp, seval] reduceIsUpper (Char.isUpper _) := reduceUnary ``Char.isUpper Char.isUpper
-builtin_simproc [simp, seval] reduceIsLower (Char.isLower _) := reduceUnary ``Char.isLower Char.isLower
-builtin_simproc [simp, seval] reduceIsAlpha (Char.isAlpha _) := reduceUnary ``Char.isAlpha Char.isAlpha
-builtin_simproc [simp, seval] reduceIsDigit (Char.isDigit _) := reduceUnary ``Char.isDigit Char.isDigit
-builtin_simproc [simp, seval] reduceIsAlphaNum (Char.isAlphanum _) := reduceUnary ``Char.isAlphanum Char.isAlphanum
-builtin_simproc [simp, seval] reduceToString (toString (_ : Char)) := reduceUnary ``toString toString 3
-builtin_simproc [simp, seval] reduceVal (Char.val _) := fun e => do
+builtin_dsimproc [simp, seval] reduceToLower (Char.toLower _) := reduceUnary ``Char.toLower Char.toLower
+builtin_dsimproc [simp, seval] reduceToUpper (Char.toUpper _) := reduceUnary ``Char.toUpper Char.toUpper
+builtin_dsimproc [simp, seval] reduceToNat (Char.toNat _) := reduceUnary ``Char.toNat Char.toNat
+builtin_dsimproc [simp, seval] reduceIsWhitespace (Char.isWhitespace _) := reduceUnary ``Char.isWhitespace Char.isWhitespace
+builtin_dsimproc [simp, seval] reduceIsUpper (Char.isUpper _) := reduceUnary ``Char.isUpper Char.isUpper
+builtin_dsimproc [simp, seval] reduceIsLower (Char.isLower _) := reduceUnary ``Char.isLower Char.isLower
+builtin_dsimproc [simp, seval] reduceIsAlpha (Char.isAlpha _) := reduceUnary ``Char.isAlpha Char.isAlpha
+builtin_dsimproc [simp, seval] reduceIsDigit (Char.isDigit _) := reduceUnary ``Char.isDigit Char.isDigit
+builtin_dsimproc [simp, seval] reduceIsAlphaNum (Char.isAlphanum _) := reduceUnary ``Char.isAlphanum Char.isAlphanum
+builtin_dsimproc [simp, seval] reduceToString (toString (_ : Char)) := reduceUnary ``toString toString 3
+builtin_dsimproc [simp, seval] reduceVal (Char.val _) := fun e => do
   let_expr Char.val arg ← e | return .continue
   let some c ← fromExpr? arg | return .continue
-  return .done { expr := toExpr c.val }
+  return .done <| toExpr c.val
 builtin_simproc [simp, seval] reduceEq  (( _ : Char) = _)  := reduceBinPred ``Eq 3 (. = .)
 builtin_simproc [simp, seval] reduceNe  (( _ : Char) ≠ _)  := reduceBinPred ``Ne 3 (. ≠ .)
-builtin_simproc [simp, seval] reduceBEq  (( _ : Char) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
-builtin_simproc [simp, seval] reduceBNe  (( _ : Char) != _)  := reduceBoolPred ``bne 4 (. != .)
+builtin_dsimproc [simp, seval] reduceBEq  (( _ : Char) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
+builtin_dsimproc [simp, seval] reduceBNe  (( _ : Char) != _)  := reduceBoolPred ``bne 4 (. != .)
 
 /--
 Return `.done` for Char values. We don't want to unfold in the symbolic evaluator.
 In regular `simp`, we want to prevent the nested raw literal from being converted into
 a `OfNat.ofNat` application. TODO: cleanup
 -/
-builtin_simproc ↓ [simp, seval] isValue (Char.ofNat _ ) := fun e => do
+builtin_dsimproc ↓ [simp, seval] isValue (Char.ofNat _ ) := fun e => do
   unless (← fromExpr? e).isSome do return .continue
-  return .done { expr := e }
+  return .done e
 
-builtin_simproc [simp, seval] reduceOfNatAux (Char.ofNatAux _ _) := fun e => do
+builtin_dsimproc [simp, seval] reduceOfNatAux (Char.ofNatAux _ _) := fun e => do
   let_expr Char.ofNatAux n _ ← e | return .continue
   let some n ← Nat.fromExpr? n | return .continue
-  return .done { expr := toExpr (Char.ofNat n) }
+  return .done <| toExpr (Char.ofNat n)
 
-builtin_simproc [simp, seval] reduceDefault ((default : Char)) := fun e => do
+builtin_dsimproc [simp, seval] reduceDefault ((default : Char)) := fun e => do
   let_expr default _ _ ← e | return .continue
-  return .done { expr := toExpr (default : Char) }
+  return .done <| toExpr (default : Char)
 
 end Char

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

@@ -19,13 +19,13 @@ def fromExpr? (e : Expr) : SimpM (Option Value) := do
   let some ⟨n, value⟩ ← getFinValue? e | return none
   return some { n, value }
 
-@[inline] def reduceBin (declName : Name) (arity : Nat) (op : {n : Nat} → Fin n → Fin n → Fin n) (e : Expr) : SimpM Step := do
+@[inline] def reduceBin (declName : Name) (arity : Nat) (op : {n : Nat} → Fin n → Fin n → Fin n) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
   let some v₂ ← fromExpr? e.appArg! | return .continue
   if h : v₁.n = v₂.n then
     let v := op v₁.value (h ▸ v₂.value)
-    return .done { expr := toExpr v }
+    return .done <| toExpr v
   else
     return .continue
 
@@ -35,22 +35,22 @@ def fromExpr? (e : Expr) : SimpM (Option Value) := do
   let some v₂ ← fromExpr? e.appArg! | return .continue
   evalPropStep e (op v₁.value v₂.value)
 
-@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM Step := do
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
   let some v₂ ← fromExpr? e.appArg! | return .continue
-  return .done { expr := Lean.toExpr (op v₁.value v₂.value) }
+  return .done <| toExpr (op v₁.value v₂.value)
 
 /-
 The following code assumes users did not override the `Fin n` instances for the arithmetic operators.
 If they do, they must disable the following `simprocs`.
 -/
 
-builtin_simproc [simp, seval] reduceAdd ((_ + _ : Fin _)) := reduceBin ``HAdd.hAdd 6 (· + ·)
-builtin_simproc [simp, seval] reduceMul ((_ * _ : Fin _)) := reduceBin ``HMul.hMul 6 (· * ·)
-builtin_simproc [simp, seval] reduceSub ((_ - _ : Fin _)) := reduceBin ``HSub.hSub 6 (· - ·)
-builtin_simproc [simp, seval] reduceDiv ((_ / _ : Fin _)) := reduceBin ``HDiv.hDiv 6 (· / ·)
-builtin_simproc [simp, seval] reduceMod ((_ % _ : Fin _)) := reduceBin ``HMod.hMod 6 (· % ·)
+builtin_dsimproc [simp, seval] reduceAdd ((_ + _ : Fin _)) := reduceBin ``HAdd.hAdd 6 (· + ·)
+builtin_dsimproc [simp, seval] reduceMul ((_ * _ : Fin _)) := reduceBin ``HMul.hMul 6 (· * ·)
+builtin_dsimproc [simp, seval] reduceSub ((_ - _ : Fin _)) := reduceBin ``HSub.hSub 6 (· - ·)
+builtin_dsimproc [simp, seval] reduceDiv ((_ / _ : Fin _)) := reduceBin ``HDiv.hDiv 6 (· / ·)
+builtin_dsimproc [simp, seval] reduceMod ((_ % _ : Fin _)) := reduceBin ``HMod.hMod 6 (· % ·)
 
 builtin_simproc [simp, seval] reduceLT  (( _ : Fin _) < _)  := reduceBinPred ``LT.lt 4 (. < .)
 builtin_simproc [simp, seval] reduceLE  (( _ : Fin _) ≤ _)  := reduceBinPred ``LE.le 4 (. ≤ .)
@@ -58,25 +58,25 @@ builtin_simproc [simp, seval] reduceGT  (( _ : Fin _) > _)  := reduceBinPred ``G
 builtin_simproc [simp, seval] reduceGE  (( _ : Fin _) ≥ _)  := reduceBinPred ``GE.ge 4 (. ≥ .)
 builtin_simproc [simp, seval] reduceEq  (( _ : Fin _) = _)  := reduceBinPred ``Eq 3 (. = .)
 builtin_simproc [simp, seval] reduceNe  (( _ : Fin _) ≠ _)  := reduceBinPred ``Ne 3 (. ≠ .)
-builtin_simproc [simp, seval] reduceBEq  (( _ : Fin _) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
-builtin_simproc [simp, seval] reduceBNe  (( _ : Fin _) != _)  := reduceBoolPred ``bne 4 (. != .)
+builtin_dsimproc [simp, seval] reduceBEq  (( _ : Fin _) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
+builtin_dsimproc [simp, seval] reduceBNe  (( _ : Fin _) != _)  := reduceBoolPred ``bne 4 (. != .)
 
 /-- Simplification procedure for ensuring `Fin` literals are normalized. -/
-builtin_simproc [simp, seval] isValue ((OfNat.ofNat _ : Fin _)) := fun e => do
+builtin_dsimproc [simp, seval] isValue ((OfNat.ofNat _ : Fin _)) := fun e => do
   let some ⟨n, v⟩ ← getFinValue? e | return .continue
   let some m ← getNatValue? e.appFn!.appArg! | return .continue
   if n == m then
     -- Design decision: should we return `.continue` instead of `.done` when simplifying.
     -- In the symbolic evaluator, we must return `.done`, otherwise it will unfold the `OfNat.ofNat`
-    return .done { expr := e }
-  return .done { expr := toExpr v }
+    return .done e
+  return .done <| toExpr v
 
-builtin_simproc [simp, seval] reduceFinMk (Fin.mk _ _)  := fun e => do
+builtin_dsimproc [simp, seval] reduceFinMk (Fin.mk _ _)  := fun e => do
   let_expr Fin.mk n v _ ← e | return .continue
   let some n ← evalNat n |>.run | return .continue
   let some v ← getNatValue? v | return .continue
   if h : n > 0 then
-    return .done { expr := toExpr (Fin.ofNat' v h) }
+    return .done <| toExpr (Fin.ofNat' v h)
   else
     return .continue
 

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

@@ -14,16 +14,16 @@ open Lean Meta Simp
 def fromExpr? (e : Expr) : SimpM (Option Int) :=
   getIntValue? e
 
-@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Int → Int) (e : Expr) : SimpM Step := do
+@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Int → Int) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op n) }
+  return .done <| toExpr (op n)
 
-@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Int → Int → Int) (e : Expr) : SimpM Step := do
+@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Int → Int → Int) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
   let some v₂ ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op v₁ v₂) }
+  return .done <| toExpr (op v₁ v₂)
 
 @[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Int → Int → Bool) (e : Expr) : SimpM Step := do
   unless e.isAppOfArity declName arity do return .continue
@@ -31,46 +31,46 @@ def fromExpr? (e : Expr) : SimpM (Option Int) :=
   let some v₂ ← fromExpr? e.appArg! | return .continue
   evalPropStep e (op v₁ v₂)
 
-@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Int → Int → Bool) (e : Expr) : SimpM Step := do
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Int → Int → Bool) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appFn!.appArg! | return .continue
   let some m ← fromExpr? e.appArg! | return .continue
-  return .done { expr := Lean.toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
 /-
 The following code assumes users did not override the `Int` instances for the arithmetic operators.
 If they do, they must disable the following `simprocs`.
 -/
 
-builtin_simproc [simp, seval] reduceNeg ((- _ : Int)) := fun e => do
+builtin_dsimproc [simp, seval] reduceNeg ((- _ : Int)) := fun e => do
   unless e.isAppOfArity ``Neg.neg 3 do return .continue
   let arg := e.appArg!
   if arg.isAppOfArity ``OfNat.ofNat 3 then
     -- We return .done to ensure `Neg.neg` is not unfolded even when `ground := true`.
-    return .done { expr := e }
+    return .done e
   else
     let some v ← fromExpr? arg | return .continue
     if v < 0 then
-      return .done { expr := toExpr (- v) }
+      return .done <| toExpr (- v)
     else
-      return .done { expr := toExpr v }
+      return .done <| toExpr v
 
 /-- Return `.done` for positive Int values. We don't want to unfold in the symbolic evaluator. -/
-builtin_simproc [seval] isPosValue ((OfNat.ofNat _ : Int)) := fun e => do
+builtin_dsimproc [seval] isPosValue ((OfNat.ofNat _ : Int)) := fun e => do
   let_expr OfNat.ofNat _ _ _ ← e | return .continue
-  return .done { expr := e }
+  return .done e
 
-builtin_simproc [simp, seval] reduceAdd ((_ + _ : Int)) := reduceBin ``HAdd.hAdd 6 (· + ·)
-builtin_simproc [simp, seval] reduceMul ((_ * _ : Int)) := reduceBin ``HMul.hMul 6 (· * ·)
-builtin_simproc [simp, seval] reduceSub ((_ - _ : Int)) := reduceBin ``HSub.hSub 6 (· - ·)
-builtin_simproc [simp, seval] reduceDiv ((_ / _ : Int)) := reduceBin ``HDiv.hDiv 6 (· / ·)
-builtin_simproc [simp, seval] reduceMod ((_ % _ : Int)) := reduceBin ``HMod.hMod 6 (· % ·)
+builtin_dsimproc [simp, seval] reduceAdd ((_ + _ : Int)) := reduceBin ``HAdd.hAdd 6 (· + ·)
+builtin_dsimproc [simp, seval] reduceMul ((_ * _ : Int)) := reduceBin ``HMul.hMul 6 (· * ·)
+builtin_dsimproc [simp, seval] reduceSub ((_ - _ : Int)) := reduceBin ``HSub.hSub 6 (· - ·)
+builtin_dsimproc [simp, seval] reduceDiv ((_ / _ : Int)) := reduceBin ``HDiv.hDiv 6 (· / ·)
+builtin_dsimproc [simp, seval] reduceMod ((_ % _ : Int)) := reduceBin ``HMod.hMod 6 (· % ·)
 
-builtin_simproc [simp, seval] reducePow ((_ : Int) ^ (_ : Nat)) := fun e => do
+builtin_dsimproc [simp, seval] reducePow ((_ : Int) ^ (_ : Nat)) := fun e => do
   let_expr HPow.hPow _ _ _ _ a b ← e | return .continue
   let some v₁ ← fromExpr? a | return .continue
   let some v₂ ← Nat.fromExpr? b | return .continue
-  return .done { expr := toExpr (v₁ ^ v₂) }
+  return .done <| toExpr (v₁ ^ v₂)
 
 builtin_simproc [simp, seval] reduceLT  (( _ : Int) < _)  := reduceBinPred ``LT.lt 4 (. < .)
 builtin_simproc [simp, seval] reduceLE  (( _ : Int) ≤ _)  := reduceBinPred ``LE.le 4 (. ≤ .)
@@ -78,25 +78,25 @@ builtin_simproc [simp, seval] reduceGT  (( _ : Int) > _)  := reduceBinPred ``GT.
 builtin_simproc [simp, seval] reduceGE  (( _ : Int) ≥ _)  := reduceBinPred ``GE.ge 4 (. ≥ .)
 builtin_simproc [simp, seval] reduceEq  (( _ : Int) = _)  := reduceBinPred ``Eq 3 (. = .)
 builtin_simproc [simp, seval] reduceNe  (( _ : Int) ≠ _)  := reduceBinPred ``Ne 3 (. ≠ .)
-builtin_simproc [simp, seval] reduceBEq  (( _ : Int) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
-builtin_simproc [simp, seval] reduceBNe  (( _ : Int) != _)  := reduceBoolPred ``bne 4 (. != .)
+builtin_dsimproc [simp, seval] reduceBEq  (( _ : Int) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
+builtin_dsimproc [simp, seval] reduceBNe  (( _ : Int) != _)  := reduceBoolPred ``bne 4 (. != .)
 
-@[inline] def reduceNatCore (declName : Name) (op : Int → Nat) (e : Expr) : SimpM Step := do
+@[inline] def reduceNatCore (declName : Name) (op : Int → Nat) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName 1 do return .continue
   let some v ← fromExpr? e.appArg! | return .continue
-  return .done { expr := mkNatLit (op v) }
+  return .done <| mkNatLit (op v)
 
-builtin_simproc [simp, seval] reduceAbs (natAbs _) := reduceNatCore ``natAbs natAbs
-builtin_simproc [simp, seval] reduceToNat (Int.toNat _) := reduceNatCore ``Int.toNat Int.toNat
+builtin_dsimproc [simp, seval] reduceAbs (natAbs _) := reduceNatCore ``natAbs natAbs
+builtin_dsimproc [simp, seval] reduceToNat (Int.toNat _) := reduceNatCore ``Int.toNat Int.toNat
 
-builtin_simproc [simp, seval] reduceNegSucc (Int.negSucc _) := fun e => do
+builtin_dsimproc [simp, seval] reduceNegSucc (Int.negSucc _) := fun e => do
   let_expr Int.negSucc a ← e | return .continue
   let some a ← getNatValue? a | return .continue
-  return .done { expr := toExpr (-(Int.ofNat a + 1)) }
+  return .done <| toExpr (-(Int.ofNat a + 1))
 
-builtin_simproc [simp, seval] reduceOfNat (Int.ofNat _) := fun e => do
+builtin_dsimproc [simp, seval] reduceOfNat (Int.ofNat _) := fun e => do
   let_expr Int.ofNat a ← e | return .continue
   let some a ← getNatValue? a | return .continue
-  return .done { expr := toExpr (Int.ofNat a) }
+  return .done <| toExpr (Int.ofNat a)
 
 end Int

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

@@ -16,16 +16,16 @@ open Lean Meta Simp
 def fromExpr? (e : Expr) : SimpM (Option Nat) :=
   getNatValue? e
 
-@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Nat → Nat) (e : Expr) : SimpM Step := do
+@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Nat → Nat) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op n) }
+  return .done <| toExpr (op n)
 
-@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : SimpM Step := do
+@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appFn!.appArg! | return .continue
   let some m ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
 @[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM Step := do
   unless e.isAppOfArity declName arity do return .continue
@@ -33,26 +33,26 @@ def fromExpr? (e : Expr) : SimpM (Option Nat) :=
   let some m ← fromExpr? e.appArg! | return .continue
   evalPropStep e (op n m)
 
-@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM Step := do
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← fromExpr? e.appFn!.appArg! | return .continue
   let some m ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
-builtin_simproc [simp, seval] reduceSucc (Nat.succ _) := reduceUnary ``Nat.succ 1 (· + 1)
+builtin_dsimproc [simp, seval] reduceSucc (Nat.succ _) := reduceUnary ``Nat.succ 1 (· + 1)
 
 /-
 The following code assumes users did not override the `Nat` instances for the arithmetic operators.
 If they do, they must disable the following `simprocs`.
 -/
 
-builtin_simproc [simp, seval] reduceAdd ((_ + _ : Nat)) := reduceBin ``HAdd.hAdd 6 (· + ·)
-builtin_simproc [simp, seval] reduceMul ((_ * _ : Nat)) := reduceBin ``HMul.hMul 6 (· * ·)
-builtin_simproc [simp, seval] reduceSub ((_ - _ : Nat)) := reduceBin ``HSub.hSub 6 (· - ·)
-builtin_simproc [simp, seval] reduceDiv ((_ / _ : Nat)) := reduceBin ``HDiv.hDiv 6 (· / ·)
-builtin_simproc [simp, seval] reduceMod ((_ % _ : Nat)) := reduceBin ``HMod.hMod 6 (· % ·)
-builtin_simproc [simp, seval] reducePow ((_ ^ _ : Nat)) := reduceBin ``HPow.hPow 6 (· ^ ·)
-builtin_simproc [simp, seval] reduceGcd (gcd _ _)       := reduceBin ``gcd 2 gcd
+builtin_dsimproc [simp, seval] reduceAdd ((_ + _ : Nat)) := reduceBin ``HAdd.hAdd 6 (· + ·)
+builtin_dsimproc [simp, seval] reduceMul ((_ * _ : Nat)) := reduceBin ``HMul.hMul 6 (· * ·)
+builtin_dsimproc [simp, seval] reduceSub ((_ - _ : Nat)) := reduceBin ``HSub.hSub 6 (· - ·)
+builtin_dsimproc [simp, seval] reduceDiv ((_ / _ : Nat)) := reduceBin ``HDiv.hDiv 6 (· / ·)
+builtin_dsimproc [simp, seval] reduceMod ((_ % _ : Nat)) := reduceBin ``HMod.hMod 6 (· % ·)
+builtin_dsimproc [simp, seval] reducePow ((_ ^ _ : Nat)) := reduceBin ``HPow.hPow 6 (· ^ ·)
+builtin_dsimproc [simp, seval] reduceGcd (gcd _ _)       := reduceBin ``gcd 2 gcd
 
 builtin_simproc [simp, seval] reduceLT  (( _ : Nat) < _)  := reduceBinPred ``LT.lt 4 (. < .)
 builtin_simproc [simp, seval] reduceLE  (( _ : Nat) ≤ _)  := reduceBinPred ``LE.le 4 (. ≤ .)
@@ -60,12 +60,12 @@ builtin_simproc [simp, seval] reduceGT  (( _ : Nat) > _)  := reduceBinPred ``GT.
 builtin_simproc [simp, seval] reduceGE  (( _ : Nat) ≥ _)  := reduceBinPred ``GE.ge 4 (. ≥ .)
 builtin_simproc [simp, seval] reduceEq  (( _ : Nat) = _)  := reduceBinPred ``Eq 3 (. = .)
 builtin_simproc [simp, seval] reduceNe  (( _ : Nat) ≠ _)  := reduceBinPred ``Ne 3 (. ≠ .)
-builtin_simproc [simp, seval] reduceBEq  (( _ : Nat) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
-builtin_simproc [simp, seval] reduceBNe  (( _ : Nat) != _)  := reduceBoolPred ``bne 4 (. != .)
+builtin_dsimproc [simp, seval] reduceBEq  (( _ : Nat) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
+builtin_dsimproc [simp, seval] reduceBNe  (( _ : Nat) != _)  := reduceBoolPred ``bne 4 (. != .)
 
 /-- Return `.done` for Nat values. We don't want to unfold in the symbolic evaluator. -/
-builtin_simproc [seval] isValue ((OfNat.ofNat _ : Nat)) := fun e => do
+builtin_dsimproc [seval] isValue ((OfNat.ofNat _ : Nat)) := fun e => do
   let_expr OfNat.ofNat _ _ _ ← e | return .continue
-  return .done { expr := e }
+  return .done e
 
 end Nat

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

@@ -13,23 +13,22 @@ open Lean Meta Simp
 def fromExpr? (e : Expr) : SimpM (Option String) := do
   return getStringValue? e
 
-builtin_simproc [simp, seval] reduceAppend ((_ ++ _ : String)) := fun e => do
+builtin_dsimproc [simp, seval] reduceAppend ((_ ++ _ : String)) := fun e => do
   unless e.isAppOfArity ``HAppend.hAppend 6 do return .continue
   let some a ← fromExpr? e.appFn!.appArg! | return .continue
   let some b ← fromExpr? e.appArg! | return .continue
-  return .done { expr := toExpr (a ++ b) }
+  return .done <| toExpr (a ++ b)
 
-private partial def reduceListChar (e : Expr) (s : String) : SimpM Step := do
-  trace[Meta.debug] "reduceListChar {e}, {s}"
+private partial def reduceListChar (e : Expr) (s : String) : SimpM DStep := do
   if e.isAppOfArity ``List.nil 1 then
-    return .done { expr := toExpr s }
+    return .done <| toExpr s
   else if e.isAppOfArity ``List.cons 3 then
     let some c ← Char.fromExpr? e.appFn!.appArg! | return .continue
     reduceListChar e.appArg! (s.push c)
   else
     return .continue
 
-builtin_simproc [simp, seval] reduceMk (String.mk _) := fun e => do
+builtin_dsimproc [simp, seval] reduceMk (String.mk _) := fun e => do
   unless e.isAppOfArity ``String.mk 1 do return .continue
   reduceListChar e.appArg! ""
 

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

@@ -21,11 +21,11 @@ def $fromExpr (e : Expr) : SimpM (Option $typeName) := do
   let some (n, _) ← getOfNatValue? e $(quote typeName.getId) | return none
   return $(mkIdent ofNat) n
 
-@[inline] def reduceBin (declName : Name) (arity : Nat) (op : $typeName → $typeName → $typeName) (e : Expr) : SimpM Step := do
+@[inline] def reduceBin (declName : Name) (arity : Nat) (op : $typeName → $typeName → $typeName) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← ($fromExpr e.appFn!.appArg!) | return .continue
   let some m ← ($fromExpr e.appArg!) | return .continue
-  return .done { expr := toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
 @[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : $typeName → $typeName → Bool) (e : Expr) : SimpM Step := do
   unless e.isAppOfArity declName arity do return .continue
@@ -33,17 +33,17 @@ def $fromExpr (e : Expr) : SimpM (Option $typeName) := do
   let some m ← ($fromExpr e.appArg!) | return .continue
   evalPropStep e (op n m)
 
-@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : $typeName → $typeName → Bool) (e : Expr) : SimpM Step := do
+@[inline] def reduceBoolPred (declName : Name) (arity : Nat) (op : $typeName → $typeName → Bool) (e : Expr) : SimpM DStep := do
   unless e.isAppOfArity declName arity do return .continue
   let some n ← ($fromExpr e.appFn!.appArg!) | return .continue
   let some m ← ($fromExpr e.appArg!) | return .continue
-  return .done { expr := toExpr (op n m) }
+  return .done <| toExpr (op n m)
 
-builtin_simproc [simp, seval] $(mkIdent `reduceAdd):ident ((_ + _ : $typeName)) := reduceBin ``HAdd.hAdd 6 (· + ·)
-builtin_simproc [simp, seval] $(mkIdent `reduceMul):ident ((_ * _ : $typeName)) := reduceBin ``HMul.hMul 6 (· * ·)
-builtin_simproc [simp, seval] $(mkIdent `reduceSub):ident ((_ - _ : $typeName)) := reduceBin ``HSub.hSub 6 (· - ·)
-builtin_simproc [simp, seval] $(mkIdent `reduceDiv):ident ((_ / _ : $typeName)) := reduceBin ``HDiv.hDiv 6 (· / ·)
-builtin_simproc [simp, seval] $(mkIdent `reduceMod):ident ((_ % _ : $typeName)) := reduceBin ``HMod.hMod 6 (· % ·)
+builtin_dsimproc [simp, seval] $(mkIdent `reduceAdd):ident ((_ + _ : $typeName)) := reduceBin ``HAdd.hAdd 6 (· + ·)
+builtin_dsimproc [simp, seval] $(mkIdent `reduceMul):ident ((_ * _ : $typeName)) := reduceBin ``HMul.hMul 6 (· * ·)
+builtin_dsimproc [simp, seval] $(mkIdent `reduceSub):ident ((_ - _ : $typeName)) := reduceBin ``HSub.hSub 6 (· - ·)
+builtin_dsimproc [simp, seval] $(mkIdent `reduceDiv):ident ((_ / _ : $typeName)) := reduceBin ``HDiv.hDiv 6 (· / ·)
+builtin_dsimproc [simp, seval] $(mkIdent `reduceMod):ident ((_ % _ : $typeName)) := reduceBin ``HMod.hMod 6 (· % ·)
 
 builtin_simproc [simp, seval] $(mkIdent `reduceLT):ident  (( _ : $typeName) < _)  := reduceBinPred ``LT.lt 4 (. < .)
 builtin_simproc [simp, seval] $(mkIdent `reduceLE):ident  (( _ : $typeName) ≤ _)  := reduceBinPred ``LE.le 4 (. ≤ .)
@@ -51,31 +51,31 @@ builtin_simproc [simp, seval] $(mkIdent `reduceGT):ident  (( _ : $typeName) > _)
 builtin_simproc [simp, seval] $(mkIdent `reduceGE):ident  (( _ : $typeName) ≥ _)  := reduceBinPred ``GE.ge 4 (. ≥ .)
 builtin_simproc [simp, seval] reduceEq  (( _ : $typeName) = _)  := reduceBinPred ``Eq 3 (. = .)
 builtin_simproc [simp, seval] reduceNe  (( _ : $typeName) ≠ _)  := reduceBinPred ``Ne 3 (. ≠ .)
-builtin_simproc [simp, seval] reduceBEq  (( _ : $typeName) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
-builtin_simproc [simp, seval] reduceBNe  (( _ : $typeName) != _)  := reduceBoolPred ``bne 4 (. != .)
+builtin_dsimproc [simp, seval] reduceBEq  (( _ : $typeName) == _)  := reduceBoolPred ``BEq.beq 4 (. == .)
+builtin_dsimproc [simp, seval] reduceBNe  (( _ : $typeName) != _)  := reduceBoolPred ``bne 4 (. != .)
 
-builtin_simproc [simp, seval] $(mkIdent `reduceOfNatCore):ident ($ofNatCore _ _) := fun e => do
+builtin_dsimproc [simp, seval] $(mkIdent `reduceOfNatCore):ident ($ofNatCore _ _) := fun e => do
   unless e.isAppOfArity $(quote ofNatCore.getId) 2 do return .continue
   let some value ← Nat.fromExpr? e.appFn!.appArg! | return .continue
   let value := $(mkIdent ofNat) value
-  return .done { expr := toExpr value }
+  return .done <| toExpr value
 
-builtin_simproc [simp, seval] $(mkIdent `reduceOfNat):ident ($(mkIdent ofNat) _) := fun e => do
+builtin_dsimproc [simp, seval] $(mkIdent `reduceOfNat):ident ($(mkIdent ofNat) _) := fun e => do
   unless e.isAppOfArity $(quote ofNat) 1 do return .continue
   let some value ← Nat.fromExpr? e.appArg! | return .continue
   let value := $(mkIdent ofNat) value
-  return .done { expr := toExpr value }
+  return .done <| toExpr value
 
-builtin_simproc [simp, seval] $(mkIdent `reduceToNat):ident ($toNat _) := fun e => do
+builtin_dsimproc [simp, seval] $(mkIdent `reduceToNat):ident ($toNat _) := fun e => do
   unless e.isAppOfArity $(quote toNat.getId) 1 do return .continue
   let some v ← ($fromExpr e.appArg!) | return .continue
   let n := $toNat v
-  return .done { expr := toExpr n }
+  return .done <| toExpr n
 
 /-- Return `.done` for UInt values. We don't want to unfold in the symbolic evaluator. -/
-builtin_simproc [seval] isValue ((OfNat.ofNat _ : $typeName)) := fun e => do
+builtin_dsimproc [seval] isValue ((OfNat.ofNat _ : $typeName)) := fun e => do
   unless (e.isAppOfArity ``OfNat.ofNat 3) do return .continue
-  return .done { expr := e }
+  return .done e
 
 end $typeName
 )

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

@@ -35,6 +35,25 @@ def Config.updateArith (c : Config) : CoreM Config := do
 def isOfNatNatLit (e : Expr) : Bool :=
   e.isAppOfArity ``OfNat.ofNat 3 && e.appFn!.appArg!.isRawNatLit
 
+/--
+If `e` is a raw Nat literal and `OfNat.ofNat` is not in the list of declarations to unfold,
+return an `OfNat.ofNat`-application.
+-/
+def foldRawNatLit (e : Expr) : SimpM Expr := do
+  match e.rawNatLit? with
+  | some n =>
+    /- If `OfNat.ofNat` is marked to be unfolded, we do not pack orphan nat literals as `OfNat.ofNat` applications
+        to avoid non-termination. See issue #788.  -/
+    if (← readThe Simp.Context).isDeclToUnfold ``OfNat.ofNat then
+      return e
+    else
+      return toExpr n
+  | none   => return e
+
+/-- Return true if `e` is of the form `ofScientific n b m` where `n` and `m` are kernel Nat literals. -/
+def isOfScientificLit (e : Expr) : Bool :=
+  e.isAppOfArity ``OfScientific.ofScientific 5 && (e.getArg! 4).isRawNatLit && (e.getArg! 2).isRawNatLit
+
 private def reduceProjFn? (e : Expr) : SimpM (Option Expr) := do
   matchConst e.getAppFn (fun _ => pure none) fun cinfo _ => do
     match (← getProjectionFnInfo? cinfo.name) with
@@ -159,6 +178,9 @@ private def reduceStep (e : Expr) : SimpM Expr := do
       return f.betaRev e.getAppRevArgs
   -- TODO: eta reduction
   if cfg.proj then
+    match (← reduceProj? e) with
+    | some e => return e
+    | none =>
     match (← reduceProjFn? e) with
     | some e => return e
     | none   => pure ()
@@ -176,7 +198,7 @@ private def reduceStep (e : Expr) : SimpM Expr := do
     trace[Meta.Tactic.simp.rewrite] "unfold {mkConst e.getAppFn.constName!}, {e} ==> {e'}"
     recordSimpTheorem (.decl e.getAppFn.constName!)
     return e'
-  | none => return e
+  | none => foldRawNatLit e
 
 private partial def reduce (e : Expr) : SimpM Expr := withIncRecDepth do
   let e' ← reduceStep e
@@ -230,17 +252,6 @@ def withNewLemmas {α} (xs : Array Expr) (f : SimpM α) : SimpM α := do
   else
     f
 
-def simpLit (e : Expr) : SimpM Result := do
-  match e.natLit? with
-  | some n =>
-    /- If `OfNat.ofNat` is marked to be unfolded, we do not pack orphan nat literals as `OfNat.ofNat` applications
-        to avoid non-termination. See issue #788.  -/
-    if (← readThe Simp.Context).isDeclToUnfold ``OfNat.ofNat then
-      return { expr := e }
-    else
-      return { expr := (← mkNumeral (mkConst ``Nat) n) }
-  | none   => return { expr := e }
-
 def simpProj (e : Expr) : SimpM Result := do
   match (← reduceProj? e) with
   | some e => return { expr := e }
@@ -397,24 +408,42 @@ def simpLet (e : Expr) : SimpM Result := do
           let h ← mkLambdaFVars #[x] h
           return { expr := e', proof? := some (← mkLetBodyCongr v' h) }
 
+private def dsimpReduce : DSimproc := fun e => do
+  let mut eNew ← reduce e
+  if eNew.isFVar then
+    eNew ← reduceFVar (← getConfig) (← getSimpTheorems) eNew
+  if eNew != e then return .visit eNew else return .done e
+
+/-- Helper `dsimproc` for `doNotVisitOfNat` and `doNotVisitOfScientific` -/
+private def doNotVisit (pred : Expr → Bool) (declName : Name) : DSimproc := fun e => do
+  if pred e then
+    if (← readThe Simp.Context).isDeclToUnfold declName then
+      return .continue e
+    else
+      return .done e
+  else
+    return .continue e
+
+/--
+Auliliary `dsimproc` for not visiting `OfNat.ofNat` application subterms.
+This is the `dsimp` equivalent of the approach used at `visitApp`.
+Recall that we fold orphan raw Nat literals.
+-/
+private def doNotVisitOfNat : DSimproc := doNotVisit isOfNatNatLit ``OfNat.ofNat
+
+/--
+Auliliary `dsimproc` for not visiting `OfScientific.ofScientific` application subterms.
+-/
+private def doNotVisitOfScientific : DSimproc := doNotVisit isOfScientificLit ``OfScientific.ofScientific
+
 @[export lean_dsimp]
 private partial def dsimpImpl (e : Expr) : SimpM Expr := do
   let cfg ← getConfig
   unless cfg.dsimp do
     return e
-  let pre (e : Expr) : SimpM TransformStep := do
-    if let Step.visit r ← rewritePre (rflOnly := true) e then
-      if r.expr != e then
-        return .visit r.expr
-    return .continue
-  let post (e : Expr) : SimpM TransformStep := do
-    if let Step.visit r ← rewritePost (rflOnly := true) e then
-      if r.expr != e then
-        return .visit r.expr
-    let mut eNew ← reduce e
-    if eNew.isFVar then
-      eNew ← reduceFVar cfg (← getSimpTheorems) eNew
-    if eNew != e then return .visit eNew else return .done e
+  let m ← getMethods
+  let pre := m.dpre >> doNotVisitOfNat >> doNotVisitOfScientific
+  let post := m.dpost >> dsimpReduce
   transform (usedLetOnly := cfg.zeta) e (pre := pre) (post := post)
 
 def visitFn (e : Expr) : SimpM Result := do
@@ -533,8 +562,8 @@ def congr (e : Expr) : SimpM Result := do
     congrDefault e
 
 def simpApp (e : Expr) : SimpM Result := do
-  if isOfNatNatLit e then
-    -- Recall that we expand "orphan" kernel nat literals `n` into `ofNat n`
+  if isOfNatNatLit e || isOfScientificLit e then
+    -- Recall that we fold "orphan" kernel Nat literals `n` into `OfNat.ofNat n`
     return { expr := e }
   else
     congr e
@@ -550,7 +579,7 @@ def simpStep (e : Expr) : SimpM Result := do
   | .const ..    => simpConst e
   | .bvar ..     => unreachable!
   | .sort ..     => return { expr := e }
-  | .lit ..      => simpLit e
+  | .lit ..      => return { expr := e }
   | .mvar ..     => return { expr := (← instantiateMVars e) }
   | .fvar ..     => return { expr := (← reduceFVar (← getConfig) (← getSimpTheorems) e) }
 
@@ -646,9 +675,9 @@ def simp (e : Expr) (ctx : Simp.Context) (simprocs : SimprocsArray := #[]) (disc
   | none   => Simp.main e ctx usedSimps (methods := Simp.mkDefaultMethodsCore simprocs)
   | some d => Simp.main e ctx usedSimps (methods := Simp.mkMethods simprocs d)
 
-def dsimp (e : Expr) (ctx : Simp.Context)
+def dsimp (e : Expr) (ctx : Simp.Context) (simprocs : SimprocsArray := #[])
     (usedSimps : UsedSimps := {}) : MetaM (Expr × UsedSimps) := do profileitM Exception "dsimp" (← getOptions) do
-  Simp.dsimpMain e ctx usedSimps (methods := Simp.mkDefaultMethodsCore {})
+  Simp.dsimpMain e ctx usedSimps (methods := Simp.mkDefaultMethodsCore simprocs )
 
 /-- See `simpTarget`. This method assumes `mvarId` is not assigned, and we are already using `mvarId`s local context. -/
 def simpTargetCore (mvarId : MVarId) (ctx : Simp.Context) (simprocs : SimprocsArray := #[]) (discharge? : Option Simp.Discharge := none)
@@ -797,7 +826,7 @@ def simpTargetStar (mvarId : MVarId) (ctx : Simp.Context) (simprocs : SimprocsAr
     else
       return (TacticResultCNM.modified mvarId', usedSimps')
 
-def dsimpGoal (mvarId : MVarId) (ctx : Simp.Context) (simplifyTarget : Bool := true) (fvarIdsToSimp : Array FVarId := #[])
+def dsimpGoal (mvarId : MVarId) (ctx : Simp.Context) (simprocs : SimprocsArray := #[]) (simplifyTarget : Bool := true) (fvarIdsToSimp : Array FVarId := #[])
     (usedSimps : UsedSimps := {}) : MetaM (Option MVarId × UsedSimps) := do
    mvarId.withContext do
     mvarId.checkNotAssigned `simp
@@ -805,7 +834,7 @@ def dsimpGoal (mvarId : MVarId) (ctx : Simp.Context) (simplifyTarget : Bool := t
     let mut usedSimps : UsedSimps := usedSimps
     for fvarId in fvarIdsToSimp do
       let type ← instantiateMVars (← fvarId.getType)
-      let (typeNew, usedSimps') ← dsimp type ctx
+      let (typeNew, usedSimps') ← dsimp type ctx simprocs
       usedSimps := usedSimps'
       if typeNew.isFalse then
         mvarIdNew.assign (← mkFalseElim (← mvarIdNew.getType) (mkFVar fvarId))
@@ -814,7 +843,7 @@ def dsimpGoal (mvarId : MVarId) (ctx : Simp.Context) (simplifyTarget : Bool := t
         mvarIdNew ← mvarIdNew.replaceLocalDeclDefEq fvarId typeNew
     if simplifyTarget then
       let target ← mvarIdNew.getType
-      let (targetNew, usedSimps') ← dsimp target ctx usedSimps
+      let (targetNew, usedSimps') ← dsimp target ctx simprocs usedSimps
       usedSimps := usedSimps'
       if targetNew.isTrue then
         mvarIdNew.assign (mkConst ``True.intro)