Add files using upload-large-folder tool

.gitattributes

@@ -4503,3 +4503,6 @@ external/alphageometry/.venv-ag/Lib/site-packages/matplotlib/mpl-data/fonts/ttf/
 external/alphageometry/.venv-ag/Lib/site-packages/matplotlib/mpl-data/fonts/ttf/DejaVuSans.ttf filter=lfs diff=lfs merge=lfs -text
 external/alphageometry/.venv-ag/Lib/site-packages/matplotlib/mpl-data/fonts/ttf/DejaVuSansMono-Bold.ttf filter=lfs diff=lfs merge=lfs -text
 external/alphageometry/.venv-ag/Lib/site-packages/matplotlib/mpl-data/fonts/ttf/DejaVuSansMono-BoldOblique.ttf filter=lfs diff=lfs merge=lfs -text
+external/alphageometry/.venv-ag/Lib/site-packages/scipy.libs/libscipy_openblas-f07f5a5d207a3a47104dca54d6d0c86a.dll filter=lfs diff=lfs merge=lfs -text
+external/alphageometry/.venv-ag/Lib/site-packages/scipy/sparse/linalg/tests/propack_test_data.npz filter=lfs diff=lfs merge=lfs -text
+external/alphageometry/.venv-ag/Lib/site-packages/numpy/_core/lib/npymath.lib filter=lfs diff=lfs merge=lfs -text

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/CheckTactic.lean

@@ -0,0 +1,24 @@
+/-
+Copyright (c) 2024 Lean FRO. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joe Hendrix
+-/
+prelude
+import Lean.Meta.Basic
+
+namespace Lean.Meta.CheckTactic
+
+def mkCheckGoalType (val type : Expr) : MetaM Expr := do
+  let lvl ← mkFreshLevelMVar
+  pure <| mkApp2 (mkConst ``CheckGoalType [lvl]) type val
+
+def matchCheckGoalType (stx : Syntax) (goalType : Expr) : MetaM (Expr × Expr × Level) := do
+  let u ← mkFreshLevelMVar
+  let type ← mkFreshExprMVar (some (.sort u))
+  let val  ← mkFreshExprMVar (some type)
+  let extType := mkAppN (.const ``CheckGoalType [u]) #[type, val]
+  if !(← isDefEq goalType extType) then
+    throwErrorAt stx "Goal{indentExpr goalType}\nis expected to match {indentExpr extType}"
+  pure (val, type, u)
+
+end Lean.Meta.CheckTactic

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/MVarRenaming.lean

@@ -0,0 +1,36 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Util.ReplaceExpr
+
+namespace Lean.Meta
+
+/-- A mapping from MVarId to MVarId -/
+structure MVarRenaming where
+  map : MVarIdMap MVarId := {}
+
+def MVarRenaming.isEmpty (s : MVarRenaming) : Bool :=
+  s.map.isEmpty
+
+def MVarRenaming.find? (s : MVarRenaming) (mvarId : MVarId) : Option MVarId :=
+  s.map.find? mvarId
+
+def MVarRenaming.find! (s : MVarRenaming) (mvarId : MVarId) : MVarId :=
+  (s.find? mvarId).get!
+
+def MVarRenaming.insert (s : MVarRenaming) (mvarId mvarId' : MVarId) : MVarRenaming :=
+  { s with map := s.map.insert mvarId mvarId' }
+
+def MVarRenaming.apply (s : MVarRenaming) (e : Expr) : Expr :=
+  if !e.hasMVar then e
+  else if s.map.isEmpty then e
+  else e.replace fun e => match e with
+    | Expr.mvar mvarId => match s.map.find? mvarId with
+      | none           => e
+      | some newMVarId => mkMVar newMVarId
+    | _ => none
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/MatchPatternAttr.lean

@@ -0,0 +1,37 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Attributes
+
+namespace Lean
+
+/--
+Instructs the pattern matcher to unfold occurrences of this definition.
+
+By default, only constructors and literals can be used for pattern matching. Using
+`@[match_pattern]` allows using other definitions, as long as they eventually reduce to
+constructors and literals.
+
+Example:
+```
+@[match_pattern]
+def yellowString : String := "yellow"
+
+def isYellow (color : String) : Bool :=
+  match color with
+  | yellowString => true
+  | _ => false
+```
+-/
+@[builtin_doc]
+builtin_initialize matchPatternAttr : TagAttribute ←
+  registerTagAttribute `match_pattern "mark that a definition can be used in a pattern (remark: the dependent pattern matching compiler will unfold the definition)"
+
+@[export lean_has_match_pattern_attribute]
+def hasMatchPatternAttribute (env : Environment) (n : Name) : Bool :=
+  matchPatternAttr.hasTag env n
+
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/MatcherApp/Basic.lean

@@ -0,0 +1,80 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Match.MatcherInfo
+
+namespace Lean.Meta
+
+structure MatcherApp where
+  matcherName   : Name
+  matcherLevels : Array Level
+  uElimPos?     : Option Nat
+  discrInfos    : Array Match.DiscrInfo
+  params        : Array Expr
+  motive        : Expr
+  discrs        : Array Expr
+  altNumParams  : Array Nat
+  alts          : Array Expr
+  remaining     : Array Expr
+
+/--
+Recognizes if `e` is a matcher application, and destructs it into the `MatcherApp` data structure.
+
+This can optionally also treat `casesOn` recursor applications as a special case
+of matcher applications.
+-/
+def matchMatcherApp? [Monad m] [MonadEnv m] [MonadError m] (e : Expr) (alsoCasesOn := false) :
+    m (Option MatcherApp) := do
+  if let .const declName declLevels := e.getAppFn then
+    if let some info ← getMatcherInfo? declName then
+      let args := e.getAppArgs
+      if args.size < info.arity then
+        return none
+      return some {
+        matcherName   := declName
+        matcherLevels := declLevels.toArray
+        uElimPos?     := info.uElimPos?
+        discrInfos    := info.discrInfos
+        params        := args.extract 0 info.numParams
+        motive        := args[info.getMotivePos]!
+        discrs        := args[(info.numParams + 1)...(info.numParams + 1 + info.numDiscrs)]
+        altNumParams  := info.altNumParams
+        alts          := args[(info.numParams + 1 + info.numDiscrs)...(info.numParams + 1 + info.numDiscrs + info.numAlts)]
+        remaining     := args[(info.numParams + 1 + info.numDiscrs + info.numAlts)...args.size]
+      }
+
+    if alsoCasesOn && isCasesOnRecursor (← getEnv) declName then
+      let indName := declName.getPrefix
+      let .inductInfo info ← getConstInfo indName | return none
+      let args := e.getAppArgs
+      unless args.size >= info.numParams + 1 /- motive -/ + info.numIndices + 1 /- major -/ + info.numCtors do return none
+      let params     := args[*...info.numParams]
+      let motive     := args[info.numParams]!
+      let discrs     := args[(info.numParams + 1)...(info.numParams + 1 + info.numIndices + 1)]
+      let discrInfos := .replicate (info.numIndices + 1) {}
+      let alts       := args[(info.numParams + 1 + info.numIndices + 1)...(info.numParams + 1 + info.numIndices + 1 + info.numCtors)]
+      let remaining  := args[(info.numParams + 1 + info.numIndices + 1 + info.numCtors)...*]
+      let uElimPos?  := if info.levelParams.length == declLevels.length then none else some 0
+      let mut altNumParams := #[]
+      for ctor in info.ctors do
+        let .ctorInfo ctorInfo ← getConstInfo ctor | unreachable!
+        altNumParams := altNumParams.push ctorInfo.numFields
+      return some {
+        matcherName   := declName
+        matcherLevels := declLevels.toArray
+        uElimPos?, discrInfos, params, motive, discrs, alts, remaining, altNumParams
+      }
+
+  return none
+
+def MatcherApp.toExpr (matcherApp : MatcherApp) : Expr :=
+  let result := mkAppN (mkConst matcherApp.matcherName matcherApp.matcherLevels.toList) matcherApp.params
+  let result := mkApp result matcherApp.motive
+  let result := mkAppN result matcherApp.discrs
+  let result := mkAppN result matcherApp.alts
+  mkAppN result matcherApp.remaining
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/MatcherApp/Transform.lean

@@ -0,0 +1,443 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Joachim Breitner
+-/
+
+prelude
+import Lean.Meta.Match
+import Lean.Meta.InferType
+import Lean.Meta.Check
+import Lean.Meta.Tactic.Split
+
+namespace Lean.Meta.MatcherApp
+
+/-- Auxiliary function for MatcherApp.addArg -/
+private partial def updateAlts (unrefinedArgType : Expr) (typeNew : Expr) (altNumParams : Array Nat) (alts : Array Expr) (refined : Bool) (i : Nat) : MetaM (Array Nat × Array Expr) := do
+  if h : i < alts.size then
+    let alt       := alts[i]
+    let numParams := altNumParams[i]!
+    let typeNew ← whnfD typeNew
+    match typeNew with
+    | Expr.forallE _ d b _ =>
+      let (alt, refined) ← forallBoundedTelescope d (some numParams) fun xs d => do
+        let alt ← try instantiateLambda alt xs catch _ => throwError "unexpected matcher application, insufficient number of parameters in alternative"
+        forallBoundedTelescope d (some 1) fun x _ => do
+          let alt ← mkLambdaFVars x alt -- x is the new argument we are adding to the alternative
+          let refined ← if refined then
+            pure refined
+          else
+            pure <| !(← isDefEq unrefinedArgType (← inferType x[0]!))
+          return (← mkLambdaFVars xs alt, refined)
+      updateAlts unrefinedArgType (b.instantiate1 alt) (altNumParams.set! i (numParams+1)) (alts.set i alt) refined (i+1)
+    | _ => throwError "unexpected type at MatcherApp.addArg"
+  else
+    if refined then
+      return (altNumParams, alts)
+    else
+      throwError "failed to add argument to matcher application, argument type was not refined by `casesOn`"
+
+/--
+Given
+- matcherApp `match_i As (fun xs => motive[xs]) discrs (fun ys_1 => (alt_1 : motive (C_1[ys_1])) ... (fun ys_n => (alt_n : motive (C_n[ys_n]) remaining`, and
+- expression `e : B[discrs]`,
+Construct the term
+`match_i As (fun xs => B[xs] -> motive[xs]) discrs (fun ys_1 (y : B[C_1[ys_1]]) => alt_1) ... (fun ys_n (y : B[C_n[ys_n]]) => alt_n) e remaining`.
+
+We only abstract discriminants that are fvars.  We used to use `kabstract` to abstract all
+discriminants from `B[discrs]`, but that changes the type of the arg in ways that make it no
+longer compatible with the original recursive function (issue #7322).
+
+If this is still not great, then we could try to use `kabstract`, but only on the last parameter
+of the `arg` (the termination proof obligation).
+
+This method assumes
+- the `matcherApp.motive` is a lambda abstraction where `xs.size == discrs.size`
+- each alternative is a lambda abstraction where `ys_i.size == matcherApp.altNumParams[i]`
+
+This is used in `Lean.Elab.PreDefinition.WF.Fix` when replacing recursive calls with calls to
+the argument provided by `fix` to refine type of the local variable used for recursive calls,
+which may mention `major`. See there for how to use this function.
+-/
+def addArg (matcherApp : MatcherApp) (e : Expr) : MetaM MatcherApp :=
+  lambdaTelescope matcherApp.motive fun motiveArgs motiveBody => do
+    unless motiveArgs.size == matcherApp.discrs.size do
+      -- This error can only happen if someone implemented a transformation that rewrites the motive created by `mkMatcher`.
+      throwError "unexpected matcher application, motive must be lambda expression with #{matcherApp.discrs.size} arguments"
+    let eType ← inferType e
+    let eTypeAbst := matcherApp.discrs.size.foldRev (init := eType) fun i _ eTypeAbst =>
+      let discr     := matcherApp.discrs[i]
+      if discr.isFVar then
+        let motiveArg := motiveArgs[i]!
+        eTypeAbst.replaceFVar discr motiveArg
+      else
+        eTypeAbst
+    let motiveBody ← mkArrow eTypeAbst motiveBody
+    let matcherLevels ← match matcherApp.uElimPos? with
+      | none     => pure matcherApp.matcherLevels
+      | some pos =>
+        let uElim ← getLevel motiveBody
+        pure <| matcherApp.matcherLevels.set! pos uElim
+    let motive ← mkLambdaFVars motiveArgs motiveBody
+    -- Construct `aux` `match_i As (fun xs => B[xs] → motive[xs]) discrs`, and infer its type `auxType`.
+    -- We use `auxType` to infer the type `B[C_i[ys_i]]` of the new argument in each alternative.
+    let aux := mkAppN (mkConst matcherApp.matcherName matcherLevels.toList) matcherApp.params
+    let aux := mkApp aux motive
+    let aux := mkAppN aux matcherApp.discrs
+    unless (← isTypeCorrect aux) do
+      throwError "failed to add argument to matcher application, type error when constructing the new motive"
+    let auxType ← inferType aux
+    let (altNumParams, alts) ← updateAlts eType auxType matcherApp.altNumParams matcherApp.alts false 0
+    return { matcherApp with
+      matcherLevels := matcherLevels,
+      motive        := motive,
+      alts          := alts,
+      altNumParams  := altNumParams,
+      remaining     := #[e] ++ matcherApp.remaining
+    }
+
+/-- Similar to `MatcherApp.addArg`, but returns `none` on failure. -/
+def addArg? (matcherApp : MatcherApp) (e : Expr) : MetaM (Option MatcherApp) :=
+  try
+    return some (← matcherApp.addArg e)
+  catch _ =>
+    return none
+
+
+/-- Given
+  - matcherApp `match_i As (fun xs => motive[xs]) discrs (fun ys_1 => (alt_1 : motive (C_1[ys_1])) ... (fun ys_n => (alt_n : motive (C_n[ys_n]) remaining`, and
+  - a expression `B[discrs]` (which may not be a type, e.g. `n : Nat`),
+  returns the expressions `fun ys_1 ... ys_i => B[C_1[ys_1]] ... B[C_n[ys_n]]`,
+
+  This method assumes
+  - the `matcherApp.motive` is a lambda abstraction where `xs.size == discrs.size`
+  - each alternative is a lambda abstraction where `ys_i.size == matcherApp.altNumParams[i]`
+
+  This is similar to `MatcherApp.addArg` when you only have an expression to
+  refined, and not a type with a value.
+
+  This is used in `Lean.Elab.PreDefinition.WF.GuessFix` when constructing the context of recursive
+  calls to refine the functions' parameter, which may mention `major`.
+  See there for how to use this function.
+-/
+def refineThrough (matcherApp : MatcherApp) (e : Expr) : MetaM (Array Expr) :=
+  lambdaTelescope matcherApp.motive fun motiveArgs _motiveBody => do
+    unless motiveArgs.size == matcherApp.discrs.size do
+      -- This error can only happen if someone implemented a transformation that rewrites the motive created by `mkMatcher`.
+      throwError "failed to transfer argument through matcher application, motive must be lambda expression with #{matcherApp.discrs.size} arguments"
+
+    let eAbst ← matcherApp.discrs.size.foldRevM (init := e) fun i _ eAbst => do
+      let motiveArg := motiveArgs[i]!
+      let discr     := matcherApp.discrs[i]
+      let eTypeAbst ← kabstract eAbst discr
+      return eTypeAbst.instantiate1 motiveArg
+    -- Let's create something that’s a `Sort` and mentions `e`
+    -- (recall that `e` itself possibly isn't a type),
+    -- by writing `e = e`, so that we can use it as a motive
+    let eEq ← mkEq eAbst eAbst
+
+    let matcherLevels ← match matcherApp.uElimPos? with
+      | none     => pure matcherApp.matcherLevels
+      | some pos =>
+        pure <| matcherApp.matcherLevels.set! pos levelZero
+    let motive ← mkLambdaFVars motiveArgs eEq
+    let aux := mkAppN (mkConst matcherApp.matcherName matcherLevels.toList) matcherApp.params
+    let aux := mkApp aux motive
+    let aux := mkAppN aux matcherApp.discrs
+    unless (← isTypeCorrect aux) do
+      throwError "failed to transfer argument through matcher application, type error when constructing the new motive"
+    let auxType ← inferType aux
+    forallTelescope auxType fun altAuxs _ => do
+      let altAuxTys ← altAuxs.mapM (inferType ·)
+      (Array.zip matcherApp.altNumParams altAuxTys).mapM fun (altNumParams, altAuxTy) => do
+        forallBoundedTelescope altAuxTy altNumParams fun fvs body => do
+          unless fvs.size = altNumParams do
+            throwError "failed to transfer argument through matcher application, alt type must be telescope with #{altNumParams} arguments"
+          -- extract type from our synthetic equality
+          let body := body.getArg! 2
+          -- and abstract over the parameters of the alternatives, so that we can safely pass the Expr out
+          mkLambdaFVars fvs body
+
+/-- A non-failing version of `MatcherApp.refineThrough` -/
+def refineThrough? (matcherApp : MatcherApp) (e : Expr) :
+    MetaM (Option (Array Expr)) :=
+  try
+    return some (← matcherApp.refineThrough e)
+  catch _ =>
+    return none
+
+
+private def withUserNamesImpl {α} (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
+  withLCtx' lctx k
+
+/--
+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 {n} [MonadControlT MetaM n] [Monad n]
+  {α} (fvars : Array Expr) (names : Array Name) (k : n α) : n α := do
+  mapMetaM (withUserNamesImpl fvars names) k
+
+/-
+`Match.forallAltTelescope` lifted to a monad transformer
+(and only passing those arguments that we care about below)
+-/
+private def forallAltTelescope'
+    {n} [Monad n] [MonadControlT MetaM n]
+    {α} (origAltType : Expr) (numParams numDiscrEqs : Nat)
+    (k : Array Expr → Array Expr → n α) : n α := do
+  map2MetaM (fun k =>
+    Match.forallAltVarsTelescope origAltType numParams numDiscrEqs
+      fun ys args _mask _bodyType => k ys args
+  ) 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.
+
+If `addEqualities` is true, then equalities connecting the discriminant to the parameters of the
+alternative (like in `match h : x with …`) are be added, if not already there.
+
+This function works even if 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
+    {n} [MonadLiftT MetaM n] [MonadControlT MetaM n] [Monad n] [MonadError n] [MonadEnv n] [MonadLog n]
+    [AddMessageContext n] [MonadOptions n]
+    (matcherApp : MatcherApp)
+    (useSplitter := false)
+    (addEqualities : Bool := false)
+    (onParams : Expr → n Expr := pure)
+    (onMotive : Array Expr → Expr → n Expr := fun _ e => pure e)
+    (onAlt : Nat → Expr → Expr → n Expr := fun _ _ e => pure e)
+    (onRemaining : Array Expr → n (Array Expr) := pure) :
+    n MatcherApp := do
+
+  -- 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, addHEqualities) ← 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) →` or `(x ≍ e) → ` to the motive when an equality is requested
+    -- and not already present, and remember whether we added an Eq or a HEq
+    let mut addHEqualities : Array (Option Bool) := #[]
+    for arg in motiveArgs, discr in discrs', di in matcherApp.discrInfos do
+      if addEqualities && di.hName?.isNone then
+        if ← isProof arg then
+          addHEqualities := addHEqualities.push none
+        else
+          let heq ← mkEqHEq discr arg
+          motiveBody' ← liftMetaM <| mkArrow heq motiveBody'
+          addHEqualities := addHEqualities.push heq.isHEq
+      else
+        addHEqualities := addHEqualities.push none
+
+    return (← mkLambdaFVars motiveArgs motiveBody', ← getLevel motiveBody', addHEqualities)
+
+  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 addHEqualities.reverse do
+    match b with
+    | none => pure ()
+    | some is_heq =>
+        remaining' := remaining'.push (← (if is_heq then mkHEqRefl else mkEqRefl) discr)
+        extraEqualities := extraEqualities + 1
+
+  if useSplitter && !isCasesOn then
+    let aux1 := mkAppN (mkConst matcherApp.matcherName matcherLevels.toList) params'
+    let aux1 := mkApp aux1 motive'
+    let aux1 := mkAppN aux1 discrs'
+    unless (← isTypeCorrect aux1) do
+      prependError m!"failed to transform matcher, type error when constructing new pre-splitter motive:{indentExpr aux1}\nfailed with" do
+        check aux1
+    let origAltTypes ← inferArgumentTypesN matcherApp.alts.size aux1
+
+    -- We replace the matcher with the splitter
+    let matchEqns ← Match.getEquationsFor matcherApp.matcherName
+    let splitter := matchEqns.splitterName
+
+    let aux2 := mkAppN (mkConst splitter matcherLevels.toList) params'
+    let aux2 := mkApp aux2 motive'
+    let aux2 := mkAppN aux2 discrs'
+    unless (← isTypeCorrect aux2) do
+      prependError m!"failed to transform matcher, type error when constructing splitter motive:{indentExpr aux2}\nfailed with" do
+        check aux2
+    let altTypes ← inferArgumentTypesN matcherApp.alts.size aux2
+
+    let mut alts' := #[]
+    for altIdx in [:matcherApp.alts.size],
+        alt in matcherApp.alts,
+        numParams in matcherApp.altNumParams,
+        splitterNumParams in matchEqns.splitterAltNumParams,
+        origAltType in origAltTypes,
+        altType in altTypes do
+      let alt' ← forallAltTelescope' origAltType (numParams - numDiscrEqs) 0 fun ys args => do
+        let altType ← instantiateForall altType ys
+        -- The splitter inserts its extra parameters 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 altIdx 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
+      logError m!"failed to transform matcher, type error when constructing new motive:{indentExpr aux}"
+      check aux
+    let altTypes ← inferArgumentTypesN matcherApp.alts.size aux
+
+    let mut alts' := #[]
+    for altIdx in [:matcherApp.alts.size],
+        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 altIdx 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).
+
+Internally, 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 alternatives
+  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[*...(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 _altIdx 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

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/MatcherInfo.lean

@@ -0,0 +1,134 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. 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
+namespace Match
+
+structure DiscrInfo where
+  /-- `some h` if the discriminant is annotated with `h:` -/
+  hName? : Option Name := none
+  deriving Inhabited
+
+/--
+A "matcher" auxiliary declaration has the following structure:
+- `numParams` parameters
+- motive
+- `numDiscrs` discriminators (aka major premises)
+- `altNumParams.size` alternatives (aka minor premises) where alternative `i` has `altNumParams[i]` parameters
+- `uElimPos?` is `some pos` when the matcher can eliminate in different universe levels, and
+   `pos` is the position of the universe level parameter that specifies the elimination universe.
+   It is `none` if the matcher only eliminates into `Prop`. -/
+structure MatcherInfo where
+  numParams    : Nat
+  numDiscrs    : Nat
+  altNumParams : Array Nat
+  uElimPos?    : Option Nat
+  /--
+    `discrInfos[i] = { hName? := some h }` if the i-th discriminant was annotated with `h :`.
+  -/
+  discrInfos   : Array DiscrInfo
+
+def MatcherInfo.numAlts (info : MatcherInfo) : Nat :=
+  info.altNumParams.size
+
+def MatcherInfo.arity (info : MatcherInfo) : Nat :=
+  info.numParams + 1 + info.numDiscrs + info.numAlts
+
+def MatcherInfo.getFirstDiscrPos (info : MatcherInfo) : Nat :=
+  info.numParams + 1
+
+def MatcherInfo.getDiscrRange (info : MatcherInfo) : Std.Range :=
+  [info.getFirstDiscrPos : info.getFirstDiscrPos + info.numDiscrs]
+
+def MatcherInfo.getFirstAltPos (info : MatcherInfo) : Nat :=
+  info.numParams + 1 + info.numDiscrs
+
+def MatcherInfo.getAltRange (info : MatcherInfo) : Std.Range :=
+  [info.getFirstAltPos : info.getFirstAltPos + info.numAlts]
+
+def MatcherInfo.getMotivePos (info : MatcherInfo) : Nat :=
+  info.numParams
+
+def getNumEqsFromDiscrInfos (infos : Array DiscrInfo) : Nat := Id.run do
+  let mut r := 0
+  for info in infos do
+    if info.hName?.isSome then
+      r := r + 1
+  return r
+
+def MatcherInfo.getNumDiscrEqs (info : MatcherInfo) : Nat :=
+  getNumEqsFromDiscrInfos info.discrInfos
+
+namespace Extension
+
+structure Entry where
+  name : Name
+  info : MatcherInfo
+
+structure State where
+  map : SMap Name MatcherInfo := {}
+
+instance : Inhabited State := ⟨{}⟩
+
+def State.addEntry (s : State) (e : Entry) : State := { s with map  := s.map.insert e.name e.info }
+def State.switch (s : State) : State :=  { s with map := s.map.switch }
+
+builtin_initialize extension : SimplePersistentEnvExtension Entry State ←
+  registerSimplePersistentEnvExtension {
+    addEntryFn    := State.addEntry
+    addImportedFn := fun es => (mkStateFromImportedEntries State.addEntry {} es).switch
+    asyncMode     := .async
+  }
+
+def addMatcherInfo (env : Environment) (matcherName : Name) (info : MatcherInfo) : Environment :=
+  let _ : Inhabited Environment := ⟨env⟩
+  assert! env.asyncMayContain matcherName
+  extension.addEntry env { name := matcherName, info := info }
+
+def getMatcherInfo? (env : Environment) (declName : Name) : Option MatcherInfo :=
+  (extension.findStateAsync env declName).map.find? declName
+
+end Extension
+
+def addMatcherInfo [Monad m] [MonadEnv m] (matcherName : Name) (info : MatcherInfo) : m Unit :=
+  modifyEnv fun env => Extension.addMatcherInfo env matcherName info
+
+end Match
+
+export Match (MatcherInfo)
+
+def getMatcherInfoCore? (env : Environment) (declName : Name) : Option MatcherInfo :=
+  Match.Extension.getMatcherInfo? env declName
+
+def getMatcherInfo? [Monad m] [MonadEnv m] (declName : Name) : m (Option MatcherInfo) :=
+  return getMatcherInfoCore? (← getEnv) declName
+
+@[export lean_is_matcher]
+def isMatcherCore (env : Environment) (declName : Name) : Bool :=
+  getMatcherInfoCore? env declName |>.isSome
+
+def isMatcher [Monad m] [MonadEnv m] (declName : Name) : m Bool :=
+  return isMatcherCore (← getEnv) declName
+
+def isMatcherAppCore? (env : Environment) (e : Expr) : Option MatcherInfo :=
+  let fn := e.getAppFn
+  if fn.isConst then
+    if let some matcherInfo := getMatcherInfoCore? env fn.constName! then
+      if e.getAppNumArgs ≥ matcherInfo.arity then some matcherInfo else none
+    else
+      none
+  else
+    none
+
+def isMatcherAppCore (env : Environment) (e : Expr) : Bool :=
+  isMatcherAppCore? env e |>.isSome
+
+def isMatcherApp [Monad m] [MonadEnv m] (e : Expr) : m Bool :=
+  return isMatcherAppCore (← getEnv) e
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Match/Value.lean

@@ -0,0 +1,27 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.LitValues
+import Lean.Expr
+
+namespace Lean.Meta
+
+/-- Return true is `e` is a term that should be processed by the `match`-compiler using `casesValues` -/
+def isMatchValue (e : Expr) : MetaM Bool := do
+  let e ← instantiateMVars e
+  if (← getNatValue? e).isSome then return true
+  if (← getIntValue? e).isSome then return true
+  if (← getFinValue? e).isSome then return true
+  if (← getBitVecValue? e).isSome then return true
+  if (getStringValue? e).isSome then return true
+  if (← getCharValue? e).isSome then return true
+  if (← getUInt8Value? e).isSome then return true
+  if (← getUInt16Value? e).isSome then return true
+  if (← getUInt32Value? e).isSome then return true
+  if (← getUInt64Value? e).isSome then return true
+  return false
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/AC.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Dany Fabian
+-/
+prelude
+import Lean.Meta.Tactic.AC.Main

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/AC/Main.lean

@@ -0,0 +1,242 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Dany Fabian
+-/
+prelude
+import Init.Data.AC
+import Lean.Meta.AppBuilder
+import Lean.Meta.Tactic.Refl
+import Lean.Meta.Tactic.Simp.Main
+import Lean.Elab.Tactic.Rewrite
+
+namespace Lean.Meta.AC
+open Lean.Data.AC
+open Lean.Elab.Tactic
+open Std
+
+abbrev ACExpr := Lean.Data.AC.Expr
+
+structure PreContext where
+  id : Nat
+  op : Expr
+  assoc : Expr
+  comm : Option Expr
+  idem : Option Expr
+  deriving Inhabited
+
+instance : ContextInformation (PreContext × Array Bool) where
+  isComm ctx := ctx.1.comm.isSome
+  isIdem ctx := ctx.1.idem.isSome
+  isNeutral ctx x := ctx.2[x]!
+
+instance : EvalInformation PreContext ACExpr where
+  arbitrary _ := Data.AC.Expr.var 0
+  evalOp _ := Data.AC.Expr.op
+  evalVar _ x := Data.AC.Expr.var x
+
+def getInstance (cls : Name) (exprs : Array Expr) : MetaM (Option Expr) := do
+  try
+    let app ← mkAppM cls exprs
+    trace[Meta.AC] "trying: {indentExpr app}"
+    let inst ← synthInstance app
+    trace[Meta.AC] "got instance"
+    return some inst
+  catch
+  | _ => return none
+
+def preContext (expr : Expr) : MetaM (Option PreContext) := do
+  if let some assoc := ←getInstance ``Associative #[expr] then
+    return some
+      { assoc,
+        op := expr
+        id := 0
+        comm := ←getInstance ``Commutative #[expr]
+        idem := ←getInstance ``IdempotentOp #[expr] }
+
+  return none
+
+inductive PreExpr
+| op (lhs rhs : PreExpr)
+| var (e : Expr)
+
+@[match_pattern] def bin (op l r : Expr) :=
+  Expr.app (Expr.app op l) r
+
+def toACExpr (op l r : Expr) : MetaM (Array Expr × ACExpr) := do
+  let (preExpr, vars) ←
+    toPreExpr (mkApp2 op l r)
+    |>.run ∅
+  let vars := vars.toArray.insertionSort Expr.lt
+  let varMap := vars.foldl (fun xs x => xs.insert x xs.size) (∅ : Std.HashMap Expr Nat) |>.get!
+
+  return (vars, toACExpr varMap preExpr)
+  where
+    toPreExpr : Expr → StateT ExprSet MetaM PreExpr
+    | e@(bin op₂ l r) => do
+      if ←isDefEq op op₂ then
+        return PreExpr.op (←toPreExpr l) (←toPreExpr r)
+      modify fun vars => vars.insert e
+      return PreExpr.var e
+    | e => do
+      modify fun vars => vars.insert e
+      return PreExpr.var e
+
+    toACExpr (varMap : Expr → Nat) : PreExpr → ACExpr
+    | PreExpr.op l r => Data.AC.Expr.op (toACExpr varMap l) (toACExpr varMap r)
+    | PreExpr.var x => Data.AC.Expr.var (varMap x)
+
+/--
+In order to prevent the kernel trying to reduce the atoms of the expression, we abstract the proof
+over them. But `ac_rfl` proofs are not completely abstract in the value of the atoms – it recognizes
+neutral elements. So we have to abstract over these proofs as well.
+-/
+def abstractAtoms (preContext : PreContext) (atoms : Array Expr)
+    (k : Array (Expr × Option Expr) → MetaM Expr) : MetaM Expr := do
+  let α ← inferType atoms[0]!
+  let u ← getLevel α
+  let rec go i (acc : Array (Expr × Option Expr)) (vars : Array Expr) (args : Array Expr) := do
+    if h : i < atoms.size then
+      withLocalDeclD `x α fun v => do
+        match (← getInstance ``LawfulIdentity #[preContext.op, atoms[i]]) with
+        | none =>
+          go (i+1) (acc.push (v, .none)) (vars.push v) (args.push atoms[i])
+        | some inst =>
+          withLocalDeclD `inst (mkApp3 (mkConst ``LawfulIdentity [u]) α preContext.op v) fun iv =>
+            go (i+1) (acc.push (v, .some iv)) (vars ++ #[v,iv]) (args ++ #[atoms[i], inst])
+    else
+      let proof ← k acc
+      let proof ← mkLambdaFVars vars proof
+      let proof := mkAppN proof args
+      return proof
+  go 0 #[] #[] #[]
+
+def buildNormProof (preContext : PreContext) (l r : Expr) : MetaM (Lean.Expr × Lean.Expr) := do
+  let (atoms, acExpr) ← toACExpr preContext.op l r
+  let proof ← abstractAtoms preContext atoms fun varsData => do
+    let α ← inferType atoms[0]!
+    let u ← getLevel α
+    let context ← mkContext α u varsData
+    let isNeutrals := varsData.map (·.2.isSome)
+    let vars := varsData.map (·.1)
+    let acExprNormed := Data.AC.evalList ACExpr preContext $ Data.AC.norm (preContext, isNeutrals) acExpr
+    let lhs := convert acExpr
+    let rhs := convert acExprNormed
+    let proof := mkAppN (mkConst ``Context.eq_of_norm [u]) #[α, context, lhs, rhs, ←mkEqRefl (mkConst ``Bool.true)]
+    let proofType ← mkEq (convertTarget vars acExpr) (convertTarget vars acExprNormed)
+    let proof := mkExpectedPropHint proof proofType
+    return proof
+  let some (_, _, tgt) := (← inferType proof).eq? | panic! "unexpected proof type"
+  return (proof, tgt)
+where
+  mkContext (α : Expr) (u : Level) (vars : Array (Expr × Option Expr)) : MetaM Expr := do
+    let arbitrary := vars[0]!.1
+    let plift := mkApp (mkConst ``PLift [.zero])
+    let pliftUp := mkApp2 (mkConst ``PLift.up [.zero])
+    let noneE tp   := mkApp  (mkConst ``Option.none [.zero]) (plift tp)
+    let someE tp v := mkApp2 (mkConst ``Option.some [.zero]) (plift tp) (pliftUp tp v)
+    let vars ← vars.mapM fun ⟨x, inst?⟩ =>
+      let isNeutral :=
+        let isNeutralClass := mkApp3 (mkConst ``LawfulIdentity [u]) α preContext.op x
+        match inst? with
+        | none => noneE isNeutralClass
+        | some isNeutral => someE isNeutralClass isNeutral
+      return mkApp4 (mkConst ``Variable.mk [u]) α preContext.op x isNeutral
+
+    let vars := vars.toList
+    let vars ← mkListLit (mkApp2 (mkConst ``Variable [u]) α preContext.op) vars
+
+    let comm :=
+      let commClass := mkApp2 (mkConst ``Commutative [u]) α preContext.op
+      match preContext.comm with
+      | none => noneE commClass
+      | some comm => someE commClass comm
+
+    let idem :=
+      let idemClass := mkApp2 (mkConst ``IdempotentOp [u]) α preContext.op
+      match preContext.idem with
+      | none => noneE idemClass
+      | some idem => someE idemClass idem
+
+    return mkApp7 (mkConst ``Lean.Data.AC.Context.mk [u]) α preContext.op preContext.assoc comm idem vars arbitrary
+
+  convert : ACExpr → Expr
+    | .op l r => mkApp2 (mkConst ``Data.AC.Expr.op) (convert l) (convert r)
+    | .var x => mkApp (mkConst ``Data.AC.Expr.var) $ mkNatLit x
+
+  convertTarget (vars : Array Expr) : ACExpr → Expr
+    | .op l r => mkApp2 preContext.op (convertTarget vars l) (convertTarget vars r)
+    | .var x => vars[x]!
+
+def post (e : Expr) : SimpM Simp.Step := do
+  let ctx ← Simp.getContext
+  match e, ctx.parent? with
+  | bin op₁ l r, some (bin op₂ _ _) =>
+    if ←isDefEq op₁ op₂ then
+      return Simp.Step.done { expr := e }
+    match ←preContext op₁ with
+    | some pc =>
+      let (proof, newTgt) ← buildNormProof pc l r
+      return Simp.Step.done { expr := newTgt, proof? := proof }
+    | none => return Simp.Step.done { expr := e }
+  | bin op l r, _ =>
+    match ←preContext op with
+    | some pc =>
+      let (proof, newTgt) ← buildNormProof pc l r
+      return Simp.Step.done { expr := newTgt, proof? := proof }
+    | none => return Simp.Step.done { expr := e }
+  | e, _ => return Simp.Step.done { expr := e }
+
+def rewriteUnnormalized (mvarId : MVarId) : MetaM MVarId := do
+  let simpCtx ← Simp.mkContext
+      (simpTheorems  := {})
+      (congrTheorems := (← getSimpCongrTheorems))
+      (config        := Simp.neutralConfig)
+  let tgt ← instantiateMVars (← mvarId.getType)
+  let (res, _) ← Simp.main tgt simpCtx (methods := { post })
+  applySimpResultToTarget mvarId tgt res
+
+def rewriteUnnormalizedRefl (goal : MVarId) : MetaM Unit := do
+  (← rewriteUnnormalized goal).refl
+
+@[builtin_tactic acRfl] def acRflTactic : Lean.Elab.Tactic.Tactic := fun _ => do
+  let goal ← getMainGoal
+  goal.withContext <| rewriteUnnormalizedRefl goal
+
+def acNfHypMeta (goal : MVarId) (fvarId : FVarId) : MetaM (Option MVarId) := do
+  goal.withContext do
+    let simpCtx ← Simp.mkContext
+      (simpTheorems  := {})
+      (congrTheorems := (← getSimpCongrTheorems))
+      (config        := Simp.neutralConfig)
+    let tgt ← instantiateMVars (← fvarId.getType)
+    let (res, _) ← Simp.main tgt simpCtx (methods := { post })
+    return (← applySimpResultToLocalDecl goal fvarId res false).map (·.snd)
+
+/-- Implementation of the `ac_nf` tactic when operating on the main goal. -/
+def acNfTargetTactic : TacticM Unit :=
+  liftMetaTactic1 fun goal => rewriteUnnormalized goal
+
+/-- Implementation of the `ac_nf` tactic when operating on a hypothesis. -/
+def acNfHypTactic (fvarId : FVarId) : TacticM Unit :=
+  liftMetaTactic1 fun goal => acNfHypMeta goal fvarId
+
+@[builtin_tactic acNf0]
+def evalNf0 : Tactic := fun stx => do
+  match stx with
+  | `(tactic| ac_nf0 $[$loc?]?) =>
+    let loc := if let some loc := loc? then expandLocation loc else Location.targets #[] true
+    withMainContext do
+      match loc with
+      | Location.targets hyps target =>
+        if target then acNfTargetTactic
+        (← getFVarIds hyps).forM acNfHypTactic
+      | Location.wildcard =>
+        acNfTargetTactic
+        (← (← getMainGoal).getNondepPropHyps).forM acNfHypTactic
+  | _ => Lean.Elab.throwUnsupportedSyntax
+
+builtin_initialize
+  registerTraceClass `Meta.AC
+
+end Lean.Meta.AC

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Acyclic.lean

@@ -0,0 +1,60 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.MatchUtil
+import Lean.Meta.Tactic.Simp.Main
+
+namespace Lean.MVarId
+open Meta
+
+private def isTarget (lhs rhs : Expr) : MetaM Bool := do
+  if !lhs.isFVar || !lhs.occurs rhs then
+    return false
+  else
+    isConstructorApp' rhs
+
+/--
+  Close the given goal if `h` is a proof for an equality such as `as = a :: as`.
+  Inductive datatypes in Lean are acyclic.
+-/
+def acyclic (mvarId : MVarId) (h : Expr) : MetaM Bool := mvarId.withContext do
+  let type ← whnfD (← inferType h)
+  trace[Meta.Tactic.acyclic] "type: {type}"
+  let some (_, lhs, rhs) := type.eq? | return false
+  if (← isTarget lhs rhs) then
+    go h lhs rhs
+  else if (← isTarget rhs lhs) then
+    go (← mkEqSymm h) rhs lhs
+  else
+    return false
+where
+  go (h lhs rhs : Expr) : MetaM Bool := do
+    try
+      let sizeOf_lhs ← mkAppM ``sizeOf #[lhs]
+      let sizeOf_rhs ← mkAppM ``sizeOf #[rhs]
+      let sizeOfEq ← mkLT sizeOf_lhs sizeOf_rhs
+      let hlt ← mkFreshExprSyntheticOpaqueMVar sizeOfEq
+      -- TODO: we only need the `sizeOf` simp theorems
+      let ctx ← Simp.mkContext
+         (config := { arith := true })
+         (simpTheorems := #[ (← getSimpTheorems) ])
+      match (← simpTarget hlt.mvarId! ctx {}).1 with
+      | some _ => return false
+      | none   =>
+        let heq ← mkCongrArg sizeOf_lhs.appFn! (← mkEqSymm h)
+        let hlt_self ← mkAppM ``Nat.lt_of_lt_of_eq #[hlt, heq]
+        let hlt_irrelf ← mkAppM ``Nat.lt_irrefl #[sizeOf_lhs]
+        mvarId.assign (← mkFalseElim (← mvarId.getType) (mkApp hlt_irrelf hlt_self))
+        trace[Meta.Tactic.acyclic] "succeeded"
+        return true
+    catch ex =>
+      trace[Meta.Tactic.acyclic] "failed with\n{ex.toMessageData}"
+      return false
+
+builtin_initialize
+  registerTraceClass `Meta.Tactic.acyclic
+
+end Lean.MVarId

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Apply.lean

@@ -0,0 +1,377 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Siddhartha Gadgil
+-/
+prelude
+import Lean.Util.FindMVar
+import Lean.Meta.SynthInstance
+import Lean.Meta.CollectMVars
+import Lean.Meta.Tactic.Util
+import Lean.PrettyPrinter
+
+namespace Lean.Meta
+/--
+  Compute the number of expected arguments and whether the result type is of the form
+  (?m ...) where ?m is an unassigned metavariable.
+-/
+def getExpectedNumArgsAux (e : Expr) : MetaM (Nat × Bool) :=
+  withDefault <| forallTelescopeReducing e fun xs body =>
+    pure (xs.size, body.getAppFn.isMVar)
+
+def getExpectedNumArgs (e : Expr) : MetaM Nat := do
+  let (numArgs, _) ← getExpectedNumArgsAux e
+  pure numArgs
+
+private def throwApplyError {α} (mvarId : MVarId)
+    (eType : Expr) (conclusionType? : Option Expr) (targetType : Expr)
+    (term? : Option MessageData) : MetaM α := do
+  throwTacticEx `apply mvarId <| MessageData.ofLazyM (es := #[eType, targetType]) do
+    let conclusionType := conclusionType?.getD eType
+    let note := if conclusionType?.isSome then .note m!"The full type of {term?.getD "the term"} is{indentExpr eType}" else m!""
+    let (conclusionType, targetType) ← addPPExplicitToExposeDiff conclusionType targetType
+    let conclusion := if conclusionType?.isNone then "type" else "conclusion"
+    return m!"could not unify the {conclusion} of {term?.getD "the term"}{indentExpr conclusionType}\n\
+      with the goal{indentExpr targetType}{note}"
+
+def synthAppInstances (tacticName : Name) (mvarId : MVarId) (mvarsNew : Array Expr) (binderInfos : Array BinderInfo)
+    (synthAssignedInstances : Bool) (allowSynthFailures : Bool) : MetaM Unit := do
+  let mut todo := #[]
+  -- Collect metavariables to synthesize
+  for mvar in mvarsNew, binderInfo in binderInfos do
+    if binderInfo.isInstImplicit then
+      if synthAssignedInstances || !(← mvar.mvarId!.isAssigned) then
+        todo := todo.push mvar
+  while !todo.isEmpty do
+    todo ← step todo
+where
+  /--
+  Try to synthesize instances for the metavariables `mvars`.
+  Returns metavariables that still need to be synthesized.
+  We can view the resulting array as the set of metavariables that we should try again.
+  This is needed when applying or rewriting with functions with complex instances.
+  For example, consider `rw [@map_smul]` where `map_smul` is
+  ```
+  map_smul {F : Type u_1} {M : Type u_2} {N : Type u_3} {φ : M → N}
+           {X : Type u_4} {Y : Type u_5}
+           [SMul M X] [SMul N Y] [FunLike F X Y] [MulActionSemiHomClass F φ X Y]
+           (f : F) (c : M) (x : X) : DFunLike.coe f (c • x) = φ c • DFunLike.coe f x
+  ```
+  and `MulActionSemiHomClass` is defined as
+  ```
+  class MulActionSemiHomClass (F : Type _)
+     {M N : outParam (Type _)} (φ : outParam (M → N))
+     (X Y : outParam (Type _)) [SMul M X] [SMul N Y] [FunLike F X Y] : Prop where
+  ```
+  The left-hand-side of the equation does not bind `N`. Thus, `SMul N Y` cannot
+  be synthesized until we synthesize `MulActionSemiHomClass F φ X Y`. Note that
+  `N` is an output parameter for `MulActionSemiHomClass`.
+  -/
+  step (mvars : Array Expr) : MetaM (Array Expr) := do
+    -- `ex?` stores the exception for this first synthesis failure in this step.
+    let mut ex? := none
+    -- `true` if we managed to synthesize an instance after we hit a failure.
+    -- That is, there is a chance we may succeed if we try again.
+    let mut progressAfterEx := false
+    -- Metavariables that we failed to synthesize.
+    let mut postponed := #[]
+    for mvar in mvars do
+      let mvarType ← inferType mvar
+      let mvarVal? ← try
+        let mvarVal ← synthInstance mvarType
+        unless postponed.isEmpty do
+          progressAfterEx := true
+        pure (some mvarVal)
+      catch ex =>
+        ex? := some ex
+        postponed := postponed.push mvar
+        pure none
+      if let some mvarVal := mvarVal? then
+        unless (← isDefEq mvar mvarVal) do
+          -- There is no point in trying again for this kind of failure
+          unless allowSynthFailures do
+            throwTacticEx tacticName mvarId "failed to assign synthesized instance"
+    if let some ex := ex? then
+      if progressAfterEx then
+        return postponed
+      else
+        -- There is no point in running `step` again. We should give up (`allowSynthFailures`),
+        -- or throw the first exception we found in this `step`.
+        if allowSynthFailures then return #[] else throw ex
+    else
+      -- Done. We successfully synthesized all metavariables.
+      return #[]
+
+def appendParentTag (mvarId : MVarId) (newMVars : Array Expr) (binderInfos : Array BinderInfo) : MetaM Unit := do
+  let parentTag ← mvarId.getTag
+  if newMVars.size == 1 then
+    -- if there is only one subgoal, we inherit the parent tag
+    newMVars[0]!.mvarId!.setTag parentTag
+  else
+    unless parentTag.isAnonymous do
+      newMVars.size.forM fun i _ => do
+        let mvarIdNew := newMVars[i].mvarId!
+        unless (← mvarIdNew.isAssigned) do
+          unless binderInfos[i]!.isInstImplicit do
+            let currTag ← mvarIdNew.getTag
+            mvarIdNew.setTag (appendTag parentTag currTag)
+
+/--
+If `synthAssignedInstances` is `true`, then `apply` will synthesize instance implicit arguments
+even if they have assigned by `isDefEq`, and then check whether the synthesized value matches the
+one inferred. The `congr` tactic sets this flag to false.
+-/
+def postprocessAppMVars (tacticName : Name) (mvarId : MVarId) (newMVars : Array Expr) (binderInfos : Array BinderInfo)
+    (synthAssignedInstances := true) (allowSynthFailures := false) : MetaM Unit := do
+  synthAppInstances tacticName mvarId newMVars binderInfos synthAssignedInstances allowSynthFailures
+  -- TODO: default and auto params
+  appendParentTag mvarId newMVars binderInfos
+
+private def dependsOnOthers (mvar : Expr) (otherMVars : Array Expr) : MetaM Bool :=
+  otherMVars.anyM fun otherMVar => do
+    if mvar == otherMVar then
+      return false
+    else
+      let otherMVarType ← inferType otherMVar
+      return (otherMVarType.findMVar? fun mvarId => mvarId == mvar.mvarId!).isSome
+
+/-- Partitions the given mvars in to two arrays (non-deps, deps)
+according to whether the given mvar depends on other mvars in the array.-/
+private def partitionDependentMVars (mvars : Array Expr) : MetaM (Array MVarId × Array MVarId) :=
+  mvars.foldlM (init := (#[], #[])) fun (nonDeps, deps) mvar => do
+    let currMVarId := mvar.mvarId!
+    if (← dependsOnOthers mvar mvars) then
+      return (nonDeps, deps.push currMVarId)
+    else
+      return (nonDeps.push currMVarId, deps)
+
+private def reorderGoals (mvars : Array Expr) : ApplyNewGoals → MetaM (List MVarId)
+  | ApplyNewGoals.nonDependentFirst => do
+      let (nonDeps, deps) ← partitionDependentMVars mvars
+      return nonDeps.toList ++ deps.toList
+  | ApplyNewGoals.nonDependentOnly => do
+      let (nonDeps, _) ← partitionDependentMVars mvars
+      return nonDeps.toList
+  | ApplyNewGoals.all => return mvars.toList.map Lean.Expr.mvarId!
+
+/-- Custom `isDefEq` for the `apply` tactic -/
+private def isDefEqApply (approx : Bool) (a b : Expr) : MetaM Bool := do
+  if approx then
+    approxDefEq <| isDefEqGuarded a b
+  else
+    isDefEqGuarded a b
+
+/--
+Close the given goal using `apply e`.
+-/
+def _root_.Lean.MVarId.apply (mvarId : MVarId) (e : Expr) (cfg : ApplyConfig := {})
+    (term? : Option MessageData := none) : MetaM (List MVarId) :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `apply
+    let targetType ← mvarId.getType
+    let eType      ← inferType e
+    let (numArgs, hasMVarHead) ← getExpectedNumArgsAux eType
+    /-
+    The `apply` tactic adds `_`s to `e`, and some of these `_`s become new goals.
+    When `hasMVarHead` is `false` we try different numbers, until we find a type compatible with `targetType`.
+    We used to try only `numArgs-targetTypeNumArgs` when `hasMVarHead = false`, but this is not always correct.
+    For example, consider the following example
+    ```
+    example {α β} [LE_trans β] (x y z : α → β) (h₀ : x ≤ y) (h₁ : y ≤ z) : x ≤ z := by
+      apply le_trans
+      assumption
+      assumption
+    ```
+    In this example, `targetTypeNumArgs = 1` because `LE` for functions is defined as
+    ```
+    instance {α : Type u} {β : Type v} [LE β] : LE (α → β) where
+      le f g := ∀ i, f i ≤ g i
+    ```
+    -/
+    let rangeNumArgs ← if hasMVarHead then
+      pure [numArgs : numArgs+1]
+    else
+      let targetTypeNumArgs ← getExpectedNumArgs targetType
+      pure [numArgs - targetTypeNumArgs : numArgs+1]
+    /-
+    Auxiliary function for trying to add `n` underscores where `n ∈ [i: rangeNumArgs.stop)`
+    See comment above
+    -/
+    let rec go (i : Nat) : MetaM (Array Expr × Array BinderInfo) := do
+      if i < rangeNumArgs.stop then
+        let s ← saveState
+        let (newMVars, binderInfos, eType) ← forallMetaTelescopeReducing eType i
+        if (← isDefEqApply cfg.approx eType targetType) then
+          return (newMVars, binderInfos)
+        else
+          s.restore
+          go (i+1)
+      else
+
+        let conclusionType? ← if rangeNumArgs.start = 0 then
+          pure none
+        else
+          let (_, _, r) ← forallMetaTelescopeReducing eType (some rangeNumArgs.start)
+          pure (some r)
+        throwApplyError mvarId eType conclusionType? targetType term?
+      termination_by rangeNumArgs.stop - i
+    let (newMVars, binderInfos) ← go rangeNumArgs.start
+    postprocessAppMVars `apply mvarId newMVars binderInfos cfg.synthAssignedInstances cfg.allowSynthFailures
+    let e ← instantiateMVars e
+    mvarId.assign (mkAppN e newMVars)
+    let newMVars ← newMVars.filterM fun mvar => not <$> mvar.mvarId!.isAssigned
+    let otherMVarIds ← getMVarsNoDelayed e
+    let newMVarIds ← reorderGoals newMVars cfg.newGoals
+    let otherMVarIds := otherMVarIds.filter fun mvarId => !newMVarIds.contains mvarId
+    let result := newMVarIds ++ otherMVarIds.toList
+    result.forM (·.headBetaType)
+    return result
+
+/-- Short-hand for applying a constant to the goal. -/
+def _root_.Lean.MVarId.applyConst (mvar : MVarId) (c : Name) (cfg : ApplyConfig := {}) : MetaM (List MVarId) := do
+  mvar.apply (← mkConstWithFreshMVarLevels c) cfg (term? := m!"'{.ofConstName c}'")
+
+/-- Close the given goal using `e`, instantiated with `n` metavariables. -/
+def _root_.Lean.MVarId.applyN (mvarId : MVarId) (e : Expr) (n : Nat) (useApproxDefEq := true) : MetaM (List MVarId) :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `apply
+    let targetType ← mvarId.getType
+    let eType      ← inferType e
+    let (mvarIds, _, eType) ← forallMetaBoundedTelescope eType n
+    unless mvarIds.size == n do
+      throwError "Applied type takes fewer than {n} arguments:\n{indentExpr eType}"
+    unless (← isDefEqApply useApproxDefEq eType targetType) do
+      throwError "Type mismatch: target is{indentExpr targetType}\nbut applied expression has \
+        type{indentExpr eType}\nafter applying {n} arguments."
+    mvarId.assign (e.beta mvarIds)
+    return (mvarIds.map (·.mvarId!)).toList
+
+end Meta
+
+open Meta
+namespace MVarId
+
+partial def splitAndCore (mvarId : MVarId) : MetaM (List MVarId) :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `splitAnd
+    let type ← mvarId.getType'
+    if !type.isAppOfArity ``And 2 then
+      return [mvarId]
+    else
+      let tag ← mvarId.getTag
+      let rec go (type : Expr) : StateRefT (Array MVarId) MetaM Expr := do
+        let type ← whnf type
+        if type.isAppOfArity ``And 2 then
+          let p₁ := type.appFn!.appArg!
+          let p₂ := type.appArg!
+          return mkApp4 (mkConst ``And.intro) p₁ p₂ (← go p₁) (← go p₂)
+        else
+          let idx := (← get).size + 1
+          let mvar ← mkFreshExprSyntheticOpaqueMVar type (tag ++ (`h).appendIndexAfter idx)
+          modify fun s => s.push mvar.mvarId!
+          return mvar
+      let (val, s) ← go type |>.run #[]
+      mvarId.assign val
+      return s.toList
+
+/--
+Apply `And.intro` as much as possible to goal `mvarId`.
+-/
+abbrev splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
+  splitAndCore mvarId
+
+def exfalso (mvarId : MVarId) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `exfalso
+    let target ← instantiateMVars (← mvarId.getType)
+    let u ← getLevel target
+    let mvarIdNew ← mkFreshExprSyntheticOpaqueMVar (mkConst ``False) (tag := (← mvarId.getTag))
+    mvarId.assign (mkApp2 (mkConst ``False.elim [u]) target mvarIdNew)
+    return mvarIdNew.mvarId!
+
+/--
+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 nthConstructor
+    (name : Name) (idx : Nat) (expected? : Option Nat := none) (goal : MVarId) :
+    MetaM (List MVarId) := do
+  goal.withContext do
+    goal.checkNotAssigned name
+    matchConstInduct (← goal.getType').getAppFn
+      (fun _ => throwTacticEx name goal "target is not an inductive datatype")
+      fun ival us => do
+        if let some e := expected? then unless ival.ctors.length == e do
+          throwTacticEx name goal
+            s!"{name} tactic works for inductive types with exactly {e} constructors"
+        if h : idx < ival.ctors.length then
+          goal.apply <| mkConst ival.ctors[idx] us
+        else
+          throwTacticEx name goal s!"index {idx} out of bounds, only {ival.ctors.length} constructors"
+
+/--
+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

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Assert.lean

@@ -0,0 +1,145 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.FVarSubst
+import Lean.Meta.Tactic.Intro
+import Lean.Meta.Tactic.Revert
+import Lean.Util.ForEachExpr
+
+namespace Lean.Meta
+
+/--
+  Convert the given goal `Ctx |- target` into `Ctx |- type -> target`.
+  It assumes `val` has type `type` -/
+def _root_.Lean.MVarId.assert (mvarId : MVarId) (name : Name) (type : Expr) (val : Expr) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `assert
+    let tag    ← mvarId.getTag
+    let target ← mvarId.getType
+    let newType := Lean.mkForall name BinderInfo.default type target
+    let newMVar ← mkFreshExprSyntheticOpaqueMVar newType tag
+    mvarId.assign (mkApp newMVar val)
+    return newMVar.mvarId!
+
+/-- Add the hypothesis `h : t`, given `v : t`, and return the new `FVarId`. -/
+def _root_.Lean.MVarId.note (g : MVarId) (h : Name) (v : Expr) (t? : Option Expr := .none) :
+    MetaM (FVarId × MVarId) := do
+  (← g.assert h (← match t? with | some t => pure t | none => inferType v) v).intro1P
+
+/--
+  Convert the given goal `Ctx |- target` into `Ctx |- let name : type := val; target`.
+  It assumes `val` has type `type` -/
+def _root_.Lean.MVarId.define (mvarId : MVarId) (name : Name) (type : Expr) (val : Expr) : MetaM MVarId := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `define
+    let tag    ← mvarId.getTag
+    let target ← mvarId.getType
+    let newType := Lean.mkLet name type val target
+    let newMVar ← mkFreshExprSyntheticOpaqueMVar newType tag
+    mvarId.assign newMVar
+    return newMVar.mvarId!
+
+/--
+  Convert the given goal `Ctx |- target` into `Ctx |- (hName : type) -> hName = val -> target`.
+  It assumes `val` has type `type` -/
+def _root_.Lean.MVarId.assertExt (mvarId : MVarId) (name : Name) (type : Expr) (val : Expr) (hName : Name := `h) : MetaM MVarId := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `assert
+    let tag    ← mvarId.getTag
+    let target ← mvarId.getType
+    let u ← getLevel type
+    let hType := mkApp3 (mkConst `Eq [u]) type (mkBVar 0) val
+    let newType := Lean.mkForall name BinderInfo.default type $ Lean.mkForall hName BinderInfo.default hType target
+    let newMVar ← mkFreshExprSyntheticOpaqueMVar newType tag
+    let rflPrf ← mkEqRefl val
+    mvarId.assign (mkApp2 newMVar val rflPrf)
+    return newMVar.mvarId!
+
+structure AssertAfterResult where
+  fvarId : FVarId
+  mvarId : MVarId
+  subst  : FVarSubst
+
+/--
+  Convert the given goal `Ctx |- target` into a goal containing `(userName : type)` after the local declaration with if `fvarId`.
+  It assumes `val` has type `type`, and that `type` is well-formed after `fvarId`.
+  Note that `val` does not need to be well-formed after `fvarId`. That is, it may contain variables that are defined after `fvarId`. -/
+def _root_.Lean.MVarId.assertAfter (mvarId : MVarId) (fvarId : FVarId) (userName : Name) (type : Expr) (val : Expr) : MetaM AssertAfterResult := do
+  mvarId.checkNotAssigned `assertAfter
+  let (fvarIds, mvarId) ← mvarId.revertAfter fvarId
+  let mvarId ← mvarId.assert userName type val
+  let (fvarIdNew, mvarId) ← mvarId.intro1P
+  let (fvarIdsNew, mvarId) ← mvarId.introNP fvarIds.size
+  let mut subst := {}
+  for f in fvarIds, fNew in fvarIdsNew do
+    subst := subst.insert f (mkFVar fNew)
+  return { fvarId := fvarIdNew, mvarId, subst }
+
+structure Hypothesis where
+  userName : Name
+  type     : Expr
+  value    : Expr
+  /-- The hypothesis' `BinderInfo` -/
+  binderInfo : BinderInfo := .default
+  /-- The hypothesis' `LocalDeclKind` -/
+  kind : LocalDeclKind := .default
+
+/--
+  Convert the given goal `Ctx |- target` into `Ctx, (hs[0].userName : hs[0].type) ... |-target`.
+  It assumes `hs[i].val` has type `hs[i].type`. -/
+def _root_.Lean.MVarId.assertHypotheses (mvarId : MVarId) (hs : Array Hypothesis) : MetaM (Array FVarId × MVarId) := do
+  if hs.isEmpty then
+    return (#[], mvarId)
+  else mvarId.withContext do
+    mvarId.checkNotAssigned `assertHypotheses
+    let tag    ← mvarId.getTag
+    let target ← mvarId.getType
+    let targetNew := hs.foldr (init := target) fun h targetNew =>
+      .forallE h.userName h.type targetNew h.binderInfo
+    let mvarNew ← mkFreshExprSyntheticOpaqueMVar targetNew tag
+    let val := hs.foldl (init := mvarNew) fun val h => .app val h.value
+    mvarId.assign val
+    let (fvarIds, mvarId) ← mvarNew.mvarId!.introNP hs.size
+    mvarId.modifyLCtx fun lctx => Id.run do
+      let mut lctx := lctx
+      for h : i in [:hs.size] do
+        let h := hs[i]
+        if h.kind != .default then
+          lctx := lctx.setKind fvarIds[i]! h.kind
+      pure lctx
+    return (fvarIds, mvarId)
+
+/--
+Replace hypothesis `hyp` in goal `g` with `proof : typeNew`.
+The new hypothesis is given the same user name as the original,
+it attempts to avoid reordering hypotheses, and the original is cleared if possible.
+-/
+-- adapted from Lean.Meta.replaceLocalDeclCore
+def _root_.Lean.MVarId.replace (g : MVarId) (hyp : FVarId) (proof : Expr) (typeNew : Option Expr := none) :
+    MetaM AssertAfterResult :=
+  g.withContext do
+    let typeNew ← match typeNew with
+    | some t => pure t
+    | none => inferType proof
+    let ldecl ← hyp.getDecl
+    -- `typeNew` may contain variables that occur after `hyp`.
+    -- Thus, we use the auxiliary function `findMaxFVar` to ensure `typeNew` is well-formed
+    -- at the position we are inserting it.
+    let (_, ldecl') ← findMaxFVar typeNew |>.run ldecl
+    let result ← g.assertAfter ldecl'.fvarId ldecl.userName typeNew proof
+    (return { result with mvarId := ← result.mvarId.clear hyp }) <|> pure result
+where
+  /-- Finds the `LocalDecl` for the FVar in `e` with the highest index. -/
+  findMaxFVar (e : Expr) : StateRefT LocalDecl MetaM Unit :=
+    e.forEach' fun e => do
+      if e.isFVar then
+        let ldecl' ← e.fvarId!.getDecl
+        modify fun ldecl => if ldecl'.index > ldecl.index then ldecl' else ldecl
+        return false
+      else
+        return e.hasFVar
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Assumption.lean

@@ -0,0 +1,34 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Util
+
+namespace Lean.Meta
+
+/-- Return a local declaration whose type is definitionally equal to `type`. -/
+def findLocalDeclWithType? (type : Expr) : MetaM (Option FVarId) := do
+  (← getLCtx).findDeclRevM? fun localDecl => do
+    if localDecl.isImplementationDetail then
+      return none
+    else if (← isDefEq type localDecl.type) then
+      return some localDecl.fvarId
+    else
+      return none
+
+/-- Return `true` if managed to close goal `mvarId` using an assumption. -/
+def _root_.Lean.MVarId.assumptionCore (mvarId : MVarId) : MetaM Bool :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `assumption
+    match (← findLocalDeclWithType? (← mvarId.getType)) with
+    | none => return false
+    | some fvarId => mvarId.assign (mkFVar fvarId); return true
+
+/-- Close goal `mvarId` using an assumption. Throw error message if failed. -/
+def _root_.Lean.MVarId.assumption (mvarId : MVarId) : MetaM Unit :=
+  unless (← mvarId.assumptionCore) do
+    throwTacticEx `assumption mvarId
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/AuxLemma.lean

@@ -0,0 +1,62 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.AddDecl
+import Lean.Meta.Basic
+import Lean.DefEqAttrib
+
+namespace Lean.Meta
+
+structure AuxLemmas where
+  lemmas : PHashMap Expr (Name × List Name) := {}
+  deriving Inhabited
+
+builtin_initialize auxLemmasExt : EnvExtension AuxLemmas ←
+  registerEnvExtension (pure {}) (asyncMode := .local)  -- a mere cache, keep local
+
+/--
+  Helper method for creating auxiliary lemmas in the environment.
+
+  It uses a cache that maps `type` to declaration name. The cache is not stored in `.olean` files.
+  It is useful to make sure the same auxiliary lemma is not created over and over again in the same
+  environment branch. For expensive auxiliary lemmas that should be deduplicated even across
+  different environment branches, consider using `realizeConst` instead.
+
+  This method is useful for tactics (e.g., `simp`) that may perform preprocessing steps to lemmas provided by
+  users. For example, `simp` preprocessor may convert a lemma into multiple ones.
+-/
+def mkAuxLemma (levelParams : List Name) (type : Expr) (value : Expr) (kind? : Option Name := none)
+    (cache := true) (inferRfl := false) : MetaM Name := do
+  let env ← getEnv
+  let s := auxLemmasExt.getState env
+  let mkNewAuxLemma := do
+    let auxName ← mkAuxDeclName (kind := kind?.getD `_proof)
+    let decl :=
+      if env.hasUnsafe type || env.hasUnsafe value then
+        -- `result` contains unsafe code, thus we cannot use a theorem.
+        Declaration.defnDecl {
+          name        := auxName
+          hints       := ReducibilityHints.opaque
+          safety      := DefinitionSafety.unsafe
+          levelParams, type, value
+        }
+      else
+        Declaration.thmDecl {
+          name := auxName
+          levelParams, type, value
+        }
+    addDecl decl
+    if inferRfl then
+      inferDefEqAttr auxName
+    modifyEnv fun env => auxLemmasExt.modifyState env fun ⟨lemmas⟩ => ⟨lemmas.insert type (auxName, levelParams)⟩
+    return auxName
+  if cache then
+    if let some (name, levelParams') := s.lemmas.find? type then
+      if levelParams == levelParams' then
+        return name
+  mkNewAuxLemma
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Backtrack.lean

@@ -0,0 +1,205 @@
+/-
+Copyright (c) 2023 Kim Morrison. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kim Morrison
+-/
+prelude
+import Init.Data.List.BasicAux
+import Lean.Meta.Iterator
+import Lean.Meta.Tactic.IndependentOf
+
+/-!
+# `backtrack`
+
+A meta-tactic for running backtracking search, given a non-deterministic tactic
+`alternatives : MVarId → Nondet MetaM (List MVarId)`.
+
+`backtrack alternatives goals` will recursively try to solve all goals in `goals`,
+and the subgoals generated, backtracking as necessary.
+
+In its default behaviour, it will either solve all goals, or fail.
+A customisable `suspend` hook in `BacktrackConfig` allows suspend a goal (or subgoal),
+so that it will be returned instead of processed further.
+Other hooks `proc` and `discharge` (described in `BacktrackConfig`) allow running other
+tactics before `alternatives`, or if all search branches from a given goal fail.
+
+Currently only `solveByElim` is implemented in terms of `backtrack`.
+-/
+
+namespace Lean.Meta.Tactic.Backtrack
+
+open Lean Meta
+
+/--
+Configuration structure to control the behaviour of `backtrack`:
+* control the maximum depth and behaviour (fail or return subgoals) at the maximum depth,
+* and hooks allowing
+  * modifying intermediate goals before running the external tactic,
+  * 'suspending' goals, returning them in the result, and
+  * discharging subgoals if the external tactic fails.
+-/
+structure BacktrackConfig where
+  /-- Maximum recursion depth. -/
+  maxDepth : Nat := 6
+  /-- An arbitrary procedure which can be used to modify the list of goals
+  before each attempt to generate alternatives.
+  Called as `proc goals curr`, where `goals` are the original goals for `backtracking`,
+  and `curr` are the current goals.
+  Returning `some l` will replace the current goals with `l` and recurse
+  (consuming one step of maximum depth).
+  Returning `none` will proceed to generating alternative without changing goals.
+  Failure will cause backtracking.
+  (defaults to `none`) -/
+  proc : List MVarId → List MVarId → MetaM (Option (List MVarId)) := fun _ _ => pure none
+  /-- If `suspend g`, then we do not consider alternatives for `g`,
+  but return `g` as a new subgoal. (defaults to `false`) -/
+  suspend : MVarId → MetaM Bool := fun _ => pure false
+  /-- `discharge g` is called on goals for which there were no alternatives.
+  If `none` we return `g` as a new subgoal.
+  If `some l`, we replace `g` by `l` in the list of active goals, and recurse.
+  If failure, we backtrack. (defaults to failure) -/
+  discharge : MVarId → MetaM (Option (List MVarId)) := fun _ => failure
+  /--
+  If we solve any "independent" goals, don't fail.
+  See `Lean.MVarId.independent?` for the definition of independence.
+  -/
+  commitIndependentGoals : Bool := false
+
+namespace Backtrack
+
+/--
+Pretty print a list of goals.
+-/
+private def ppMVarId (g : MVarId) : MetaM Format := ppExpr =<< g.getType
+
+/--
+Pretty print a list of goals.
+-/
+private def ppMVarIds (gs : List MVarId) : MetaM (List Format) := gs.mapM ppMVarId
+
+/-- Run a monadic function on every element of a list,
+returning the list of elements on which the function fails, and the list of successful results. -/
+def tryAllM [Monad m] [Alternative m] (L : List α) (f : α → m β) : m (List α × List β) := do
+  let R ← L.mapM (fun a => (Sum.inr <$> f a) <|> (pure (Sum.inl a)))
+  return (R.filterMap (fun s => match s with | .inl a => a | _ => none),
+    R.filterMap (fun s => match s with | .inr b => b | _ => none))
+
+variable (cfg : BacktrackConfig)
+variable (trace : Name := .anonymous)
+variable (next : MVarId → (List MVarId → MetaM (Option (List MVarId))) → MetaM (List MVarId))
+
+/--
+* `n : Nat` steps remaining.
+* `curr : List MVarId` the current list of unsolved goals.
+* `acc : List MVarId` a list of "suspended" goals, which will be returned as subgoals.
+-/
+  -- `acc` is intentionally a `List` rather than an `Array` so we can share across branches.
+private def run (goals : List MVarId) (n : Nat) (curr acc : List MVarId) : MetaM (List MVarId) := do
+  match n with
+  | 0 => do
+    -- We're out of fuel.
+    throwError "backtrack exceeded the recursion limit"
+  | n + 1 => do
+  -- First, run `cfg.proc`, to see if it wants to modify the goals.
+  let procResult? ← try
+    cfg.proc goals curr
+  catch e =>
+    withTraceNode trace
+      (return m!"{exceptEmoji ·} BacktrackConfig.proc failed: {e.toMessageData}") do
+    throw e
+  match procResult? with
+  | some curr' => run goals n curr' acc
+  | none =>
+  match curr with
+  -- If there are no active goals, return the accumulated goals.
+  | [] => withTraceNode trace (return m!"{exceptEmoji ·} success!") do
+      return acc.reverse
+  | g :: gs =>
+  -- Discard any goals which have already been assigned.
+  if ← g.isAssigned then
+    withTraceNode trace (return m!"{exceptEmoji ·} discarding already assigned goal {g}") do
+      run goals (n+1) gs acc
+  else
+  withTraceNode trace
+    -- Note: the `addMessageContextFull` ensures we show the goal using the mvar context before
+    -- the `do` block below runs, potentially unifying mvars in the goal.
+    (return m!"{exceptEmoji ·} working on: {← addMessageContextFull g}")
+    do
+      -- Check if we should suspend the search here:
+      if (← cfg.suspend g) then
+        withTraceNode trace
+          (fun _ => return m!"⏸️ suspending search and returning as subgoal") do
+        run goals (n+1) gs (g :: acc)
+      else
+        try
+          -- We attempt to find an alternative,
+          -- for which all resulting sub-goals can be discharged using `run n`.
+          next g (fun r => observing? do run goals n (r ++ gs) acc)
+        catch _ =>
+          -- No lemmas could be applied:
+          match (← cfg.discharge g) with
+          | none => (withTraceNode trace
+              (fun _ => return m!"⏭️ deemed acceptable, returning as subgoal") do
+            run goals (n+1) gs (g :: acc))
+          | some l => (withTraceNode trace
+              (fun _ => return m!"⏬ discharger generated new subgoals") do
+            run goals n (l ++ gs) acc)
+
+/--
+A wrapper around `run`, which works on "independent" goals separately first,
+to reduce backtracking.
+-/
+private partial def processIndependentGoals (orig : List MVarId) (goals remaining : List MVarId) :
+    MetaM (List MVarId) := do
+  -- Partition the remaining goals into "independent" goals
+  -- (which should be solvable without affecting the solvability of other goals)
+  -- and all the others.
+  let (igs, ogs) ← remaining.partitionM (MVarId.isIndependentOf goals)
+  if igs.isEmpty then
+    -- If there are no independent goals, we solve all the goals together via backtracking search.
+    return (← run cfg trace next orig cfg.maxDepth remaining [])
+  else
+    withTraceNode trace
+      (fun _ => return m!"independent goals {← ppMVarIds igs},"
+        ++ m!" working on them before {← ppMVarIds ogs}") do
+    -- Invoke `run` on each of the independent goals separately,
+    -- gathering the subgoals on which `run` fails,
+    -- and the new subgoals generated from goals on which it is successful.
+    let (failed, newSubgoals') ← tryAllM igs fun g =>
+      run cfg trace next orig cfg.maxDepth [g] []
+    let newSubgoals := newSubgoals'.flatten
+    withTraceNode trace
+      (fun _ => return m!"failed: {← ppMVarIds failed}, new: {← ppMVarIds newSubgoals}") do
+    -- Update the list of goals with respect to which we need to check independence.
+    let goals' := (← goals.filterM (fun g => do pure !(← g.isAssigned))) ++ newSubgoals
+    -- If `commitIndependentGoals` is `true`, we will return the new goals
+    -- regardless of whether we can make further progress on the other goals.
+    if cfg.commitIndependentGoals && !newSubgoals.isEmpty then
+      return newSubgoals ++ failed ++ (← (processIndependentGoals orig goals' ogs <|> pure ogs))
+    else if !failed.isEmpty then
+      -- If `commitIndependentGoals` is `false`, and we failed on any of the independent goals,
+      -- then overall failure is inevitable so we can stop here.
+      failure
+    else
+      -- Finally, having solved this batch of independent goals,
+      -- recurse (potentially now finding new independent goals).
+      return newSubgoals ++ (← processIndependentGoals orig goals' ogs)
+
+end Backtrack
+
+
+/--
+Attempts to solve the `goals`, by recursively calling `next` on each
+subgoal that appears with a callback to reenter backtracking search.
+
+Further flow control options are available via the `Config` argument.
+
+Returns a list of subgoals which were "suspended" via the `suspend` or
+`discharge` hooks in `Config`. In the default configuration, `backtrack`
+will either return an empty list or fail.
+-/
+def backtrack (cfg : BacktrackConfig := {}) (trace : Name := .anonymous)
+    (next : MVarId → MetaM (Meta.Iterator (List MVarId)))
+    (goals : List MVarId) : MetaM (List MVarId) := do
+  let resolve g f := do (←next g).firstM f
+  Backtrack.processIndependentGoals cfg trace resolve goals goals goals

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Cases.lean

@@ -0,0 +1,361 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.AppBuilder
+import Lean.Meta.Tactic.Induction
+import Lean.Meta.Tactic.Injection
+import Lean.Meta.Tactic.Assert
+import Lean.Meta.Tactic.Subst
+import Lean.Meta.Tactic.Acyclic
+import Lean.Meta.Tactic.UnifyEq
+
+namespace Lean.Meta
+
+private def throwInductiveTypeExpected (type : Expr) : MetaM α := do
+  throwError "failed to compile pattern matching, inductive type expected{indentExpr type}"
+
+def getInductiveUniverseAndParams (type : Expr) : MetaM (List Level × Array Expr) := do
+  let type ← whnfD type
+  matchConstInduct type.getAppFn (fun _ => throwInductiveTypeExpected type) fun val us =>
+    let Iargs  := type.getAppArgs
+    let params := Iargs.extract 0 val.numParams
+    pure (us, params)
+
+private def mkEqAndProof (lhs rhs : Expr) : MetaM (Expr × Expr) := do
+  let lhsType ← inferType lhs
+  let rhsType ← inferType rhs
+  let u       ← getLevel lhsType
+  if (← isDefEq lhsType rhsType) then
+    pure (mkApp3 (mkConst ``Eq [u]) lhsType lhs rhs, mkApp2 (mkConst ``Eq.refl [u]) lhsType lhs)
+  else
+    pure (mkApp4 (mkConst ``HEq [u]) lhsType lhs rhsType rhs, mkApp2 (mkConst ``HEq.refl [u]) lhsType lhs)
+
+partial def withNewEqs (targets targetsNew : Array Expr) (k : Array Expr → Array Expr → MetaM α) : MetaM α :=
+  let rec loop (i : Nat) (newEqs : Array Expr) (newRefls : Array Expr) := do
+    if i < targets.size then
+      let (newEqType, newRefl) ← mkEqAndProof targets[i]! targetsNew[i]!
+      withLocalDeclD `h newEqType fun newEq => do
+        loop (i+1) (newEqs.push newEq) (newRefls.push newRefl)
+    else
+      k newEqs newRefls
+  loop 0 #[] #[]
+
+def generalizeTargetsEq (mvarId : MVarId) (motiveType : Expr) (targets : Array Expr) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `generalizeTargets
+    let (typeNew, eqRefls) ←
+      forallTelescopeReducing motiveType fun targetsNew _ => do
+        unless targetsNew.size ≥ targets.size do
+          throwError "invalid number of targets #{targets.size}, motive only takes #{targetsNew.size}"
+        let targetsNewAtomic := targetsNew[*...targets.size]
+        withNewEqs targets targetsNewAtomic fun eqs eqRefls => do
+          let typeNew ← mvarId.getType
+          let typeNew ← mkForallFVars eqs typeNew
+          let typeNew ← mkForallFVars targetsNewAtomic typeNew
+          pure (typeNew, eqRefls)
+    let mvarNew ← mkFreshExprSyntheticOpaqueMVar typeNew (← mvarId.getTag)
+    mvarId.assign (mkAppN (mkAppN mvarNew targets) eqRefls)
+    pure mvarNew.mvarId!
+
+structure GeneralizeIndicesSubgoal where
+  mvarId         : MVarId
+  indicesFVarIds : Array FVarId
+  fvarId         : FVarId
+  numEqs         : Nat
+
+/--
+Given a metavariable `mvarId` representing the goal
+```
+Ctx |- T
+```
+and an expression `e : I A j`, where `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, j' : J, h' : I A j' |- j == j' -> e == h' -> T
+```
+Remark: `(j == j' -> e == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target
+
+If `varName?` is not none, it is used to name `h'`.
+-/
+def generalizeIndices' (mvarId : MVarId) (e : Expr) (varName? : Option Name := none) : MetaM GeneralizeIndicesSubgoal :=
+  mvarId.withContext do
+    let lctx       ← getLCtx
+    let localInsts ← getLocalInstances
+    mvarId.checkNotAssigned `generalizeIndices
+    let type ← whnfD (← inferType e)
+    type.withApp fun f args => matchConstInduct f (fun _ => throwTacticEx `generalizeIndices mvarId "inductive type expected") fun val _ => do
+      unless val.numIndices > 0 do throwTacticEx `generalizeIndices mvarId "indexed inductive type expected"
+      unless args.size == val.numIndices + val.numParams do throwTacticEx `generalizeIndices mvarId "ill-formed inductive datatype"
+      let indices := args.extract (args.size - val.numIndices) args.size
+      let IA := mkAppN f (args.extract 0 val.numParams) -- `I A`
+      let IAType ← inferType IA
+      forallTelescopeReducing IAType fun newIndices _ => do
+      let newType := mkAppN IA newIndices
+      let varName ← if let some varName := varName? then pure varName else mkFreshUserName `x
+      withLocalDeclD varName newType fun h' =>
+      withNewEqs indices newIndices fun newEqs newRefls => do
+      let (newEqType, newRefl) ← mkEqAndProof e h'
+      let newRefls := newRefls.push newRefl
+      withLocalDeclD `h newEqType fun newEq => do
+      let newEqs := newEqs.push newEq
+      /- auxType `forall (j' : J) (h' : I A j'), j == j' -> h == h' -> target -/
+      let target  ← mvarId.getType
+      let tag     ← mvarId.getTag
+      let auxType ← mkForallFVars newEqs target
+      let auxType ← mkForallFVars #[h'] auxType
+      let auxType ← mkForallFVars newIndices auxType
+      let newMVar ← mkFreshExprMVarAt lctx localInsts auxType MetavarKind.syntheticOpaque tag
+      /- assign mvarId := newMVar indices h refls -/
+      mvarId.assign (mkAppN (mkApp (mkAppN newMVar indices) e) newRefls)
+      let (indicesFVarIds, newMVarId) ← newMVar.mvarId!.introNP newIndices.size
+      let (fvarId, newMVarId) ← newMVarId.intro1P
+      return {
+        mvarId         := newMVarId,
+        indicesFVarIds := indicesFVarIds,
+        fvarId         := fvarId,
+        numEqs         := newEqs.size
+      }
+
+/--
+Similar to `generalizeTargets` but customized for the `casesOn` motive.
+Given a metavariable `mvarId` representing the
+```
+Ctx, h : I A j, D |- T
+```
+where `fvarId` is `h`s id, and the type `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, h : I A j, D, j' : J, h' : I A j' |- j == j' -> h == h' -> T
+```
+Remark: `(j == j' -> h == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target -/
+def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndicesSubgoal :=
+  mvarId.withContext do
+    let fvarDecl ← fvarId.getDecl
+    generalizeIndices' mvarId fvarDecl.toExpr fvarDecl.userName
+
+structure CasesSubgoal extends InductionSubgoal where
+  ctorName : Name
+
+namespace Cases
+
+structure Context where
+  inductiveVal     : InductiveVal
+  casesOnVal       : DefinitionVal
+  nminors          : Nat := inductiveVal.ctors.length
+  majorDecl        : LocalDecl
+  majorTypeFn      : Expr
+  majorTypeArgs    : Array Expr
+  majorTypeIndices : Array Expr := majorTypeArgs.extract (majorTypeArgs.size - inductiveVal.numIndices) majorTypeArgs.size
+
+private def mkCasesContext? (majorFVarId : FVarId) : MetaM (Option Context) := do
+  let env ← getEnv
+  if !env.contains `Eq || !env.contains `HEq then
+    pure none
+  else
+    let majorDecl ← majorFVarId.getDecl
+    let majorType ← whnf majorDecl.type
+    majorType.withApp fun f args => matchConstInduct f (fun _ => pure none) fun ival _ =>
+      if args.size != ival.numIndices + ival.numParams then pure none
+      else match env.find? (Name.mkStr ival.name "casesOn") with
+        | ConstantInfo.defnInfo cval =>
+          return some {
+            inductiveVal  := ival,
+            casesOnVal    := cval,
+            majorDecl     := majorDecl,
+            majorTypeFn   := f,
+            majorTypeArgs := args
+          }
+        | _ => pure none
+
+/--
+We say the major premise has independent indices IF
+1- its type is *not* an indexed inductive family, OR
+2- its type is an indexed inductive family, but all indices are distinct free variables, and
+   all local declarations different from the major and its indices do not depend on the indices.
+-/
+private def hasIndepIndices (ctx : Context) : MetaM Bool := do
+  if ctx.majorTypeIndices.isEmpty then
+    return true
+  else if ctx.majorTypeIndices.any fun idx => !idx.isFVar then
+    /- One of the indices is not a free variable. -/
+    return false
+  else if ctx.majorTypeIndices.size.any fun i _ => i.any fun j _ => ctx.majorTypeIndices[i] == ctx.majorTypeIndices[j] then
+    /- An index occurs more than once -/
+    return false
+  else
+    (← getLCtx).allM fun decl =>
+      pure (decl.fvarId == ctx.majorDecl.fvarId) <||> -- decl is the major
+      pure (ctx.majorTypeIndices.any (fun index => decl.fvarId == index.fvarId!)) <||> -- decl is one of the indices
+     findLocalDeclDependsOn decl (fun fvarId => ctx.majorTypeIndices.all fun idx => idx.fvarId! != fvarId) -- or does not depend on any index
+
+private def elimAuxIndices (s₁ : GeneralizeIndicesSubgoal) (s₂ : Array CasesSubgoal) : MetaM (Array CasesSubgoal) :=
+  let indicesFVarIds := s₁.indicesFVarIds
+  s₂.mapM fun s => do
+    indicesFVarIds.foldlM (init := s) fun s indexFVarId =>
+      match s.subst.get indexFVarId with
+      | Expr.fvar indexFVarId' =>
+        (do let mvarId ← s.mvarId.clear indexFVarId'; pure { s with mvarId := mvarId, subst := s.subst.erase indexFVarId })
+        <|>
+        (pure s)
+      | _ => pure s
+
+/--
+  Convert `s` into an array of `CasesSubgoal`, by attaching the corresponding constructor name,
+  and adding the substitution `majorFVarId -> ctor_i us params fields` into each subgoal. -/
+private def toCasesSubgoals (s : Array InductionSubgoal) (ctorNames : Array Name) (majorFVarId : FVarId) (us : List Level) (params : Array Expr)
+    : Array CasesSubgoal :=
+  s.mapIdx fun i s =>
+    let ctorName := ctorNames[i]!
+    let ctorApp  := mkAppN (mkAppN (mkConst ctorName us) params) s.fields
+    let s        := { s with subst := s.subst.insert majorFVarId ctorApp }
+    { ctorName           := ctorName,
+      toInductionSubgoal := s }
+
+partial def unifyEqs? (numEqs : Nat) (mvarId : MVarId) (subst : FVarSubst) (caseName? : Option Name := none): MetaM (Option (MVarId × FVarSubst)) := withIncRecDepth do
+  if numEqs == 0 then
+    return some (mvarId, subst)
+  else
+    let (eqFVarId, mvarId) ← mvarId.intro1
+    if let some { mvarId, subst, numNewEqs } ← unifyEq? mvarId eqFVarId subst MVarId.acyclic caseName? then
+      unifyEqs? (numEqs - 1 + numNewEqs) mvarId subst caseName?
+    else
+      return none
+
+private def unifyCasesEqs (numEqs : Nat) (subgoals : Array CasesSubgoal) : MetaM (Array CasesSubgoal) :=
+  subgoals.foldlM (init := #[]) fun subgoals s => do
+    match (← unifyEqs? numEqs s.mvarId s.subst s.ctorName) with
+    | none                 => pure subgoals
+    | some (mvarId, subst) =>
+      return subgoals.push { s with
+        mvarId := mvarId,
+        subst  := subst,
+        fields := s.fields.map (subst.apply ·)
+      }
+
+private def inductionCasesOn (mvarId : MVarId) (majorFVarId : FVarId) (givenNames : Array AltVarNames) (ctx : Context)
+    (useNatCasesAuxOn : Bool := false) : MetaM (Array CasesSubgoal) := mvarId.withContext do
+  let majorType ← inferType (mkFVar majorFVarId)
+  let (us, params) ← getInductiveUniverseAndParams majorType
+  let mut casesOn := mkCasesOnName ctx.inductiveVal.name
+  if useNatCasesAuxOn && ctx.inductiveVal.name == ``Nat && (← getEnv).contains ``Nat.casesAuxOn then
+    casesOn := ``Nat.casesAuxOn
+  let ctors   := ctx.inductiveVal.ctors.toArray
+  let s ← mvarId.induction majorFVarId casesOn givenNames
+  return toCasesSubgoals s ctors majorFVarId us params
+
+def cases (mvarId : MVarId) (majorFVarId : FVarId) (givenNames : Array AltVarNames := #[]) (useNatCasesAuxOn : Bool := false) : MetaM (Array CasesSubgoal) := do
+  try
+    mvarId.withContext do
+      mvarId.checkNotAssigned `cases
+      let context? ← mkCasesContext? majorFVarId
+      match context? with
+      | none     => throwTacticEx `cases mvarId "not applicable to the given hypothesis"
+      | some ctx =>
+        /- Remark: if caller does not need a `FVarSubst` (variable substitution), and `hasIndepIndices ctx` is true,
+           then we can also use the simple case. This is a minor optimization, and we currently do not even
+           allow callers to specify whether they want the `FVarSubst` or not. -/
+        if ctx.inductiveVal.numIndices == 0 then
+          -- Simple case
+          inductionCasesOn mvarId majorFVarId givenNames ctx (useNatCasesAuxOn := useNatCasesAuxOn)
+        else
+          let s₁ ← generalizeIndices mvarId majorFVarId
+          trace[Meta.Tactic.cases] "after generalizeIndices\n{MessageData.ofGoal s₁.mvarId}"
+          let s₂ ← inductionCasesOn s₁.mvarId s₁.fvarId givenNames ctx
+          let s₂ ← elimAuxIndices s₁ s₂
+          unifyCasesEqs s₁.numEqs s₂
+  catch ex =>
+    throwNestedTacticEx `cases ex
+
+end Cases
+
+/--
+Apply `casesOn` using the free variable `majorFVarId` as the major premise (aka discriminant).
+`givenNames` contains user-facing names for each alternative.
+
+- `useNatCasesAuxOn` is a temporary hack for the `rcases` family of tactics.
+  Do not use it, as it is subject to removal.
+  It enables using `Nat.casesAuxOn` instead of `Nat.casesOn`,
+  which causes case splits on `n : Nat` to be represented as `0` and `n' + 1` rather than as `Nat.zero` and `Nat.succ n'`.
+-/
+def _root_.Lean.MVarId.cases (mvarId : MVarId) (majorFVarId : FVarId) (givenNames : Array AltVarNames := #[]) (useNatCasesAuxOn : Bool := false) : MetaM (Array CasesSubgoal) :=
+  Cases.cases mvarId majorFVarId givenNames (useNatCasesAuxOn := useNatCasesAuxOn)
+
+/--
+Keep applying `cases` on any hypothesis that satisfies `p`.
+-/
+def _root_.Lean.MVarId.casesRec (mvarId : MVarId) (p : LocalDecl → MetaM Bool) : MetaM (List MVarId) :=
+  saturate mvarId fun mvarId =>
+    mvarId.withContext do
+      for localDecl in (← getLCtx) do
+        if (← p localDecl) then
+          let r? ← observing? do
+            let r ← mvarId.cases localDecl.fvarId
+            return r.toList.map (·.mvarId)
+          if r?.isSome then
+            return r?
+      return none
+
+/--
+Applies `cases` (recursively) to any hypothesis of the form `h : p ∧ q`.
+-/
+def _root_.Lean.MVarId.casesAnd (mvarId : MVarId) : MetaM MVarId := do
+  let mvarIds ← mvarId.casesRec fun localDecl => return (← instantiateMVars localDecl.type).isAppOfArity ``And 2
+  exactlyOne mvarIds
+
+/--
+Applies `cases` to any hypothesis of the form `h : r = s`.
+-/
+def _root_.Lean.MVarId.substEqs (mvarId : MVarId) : MetaM (Option MVarId) := do
+  let mvarIds ← mvarId.casesRec fun localDecl => do
+    let type ← instantiateMVars localDecl.type
+    return type.isEq || type.isHEq
+  ensureAtMostOne mvarIds
+
+/-- Auxiliary structure for storing `byCases` tactic result. -/
+structure ByCasesSubgoal where
+  mvarId : MVarId
+  fvarId : FVarId
+
+private def toByCasesSubgoal (s : CasesSubgoal) : MetaM ByCasesSubgoal :=  do
+    let #[Expr.fvar fvarId ..] ← pure s.fields | throwError "'byCases' tactic failed, unexpected new hypothesis"
+    return { mvarId := s.mvarId, fvarId }
+
+/--
+Split the goal in two subgoals: one containing the hypothesis `h : p` and another containing `h : ¬ p`.
+-/
+def _root_.Lean.MVarId.byCases (mvarId : MVarId) (p : Expr) (hName : Name := `h) : MetaM (ByCasesSubgoal × ByCasesSubgoal) := do
+  let mvarId ← mvarId.assert `hByCases (mkOr p (mkNot p)) (mkEM p)
+  let (fvarId, mvarId) ← mvarId.intro1
+  let #[s₁, s₂] ← mvarId.cases fvarId #[{ varNames := [hName] }, { varNames := [hName] }] |
+    throwError "'byCases' tactic failed, unexpected number of subgoals"
+  return ((← toByCasesSubgoal s₁), (← toByCasesSubgoal s₂))
+
+/--
+Given `dec : Decidable p`, split the goal in two subgoals: one containing the hypothesis `h : p` and another containing `h : ¬ p`.
+-/
+def _root_.Lean.MVarId.byCasesDec (mvarId : MVarId) (p : Expr) (dec : Expr) (hName : Name := `h) : MetaM (ByCasesSubgoal × ByCasesSubgoal) := do
+  let mvarId ← mvarId.assert `hByCases (mkApp (mkConst ``Decidable) p) dec
+  let (fvarId, mvarId) ← mvarId.intro1
+  let #[s₁, s₂] ← mvarId.cases fvarId #[{ varNames := [hName] }, { varNames := [hName] }] |
+    throwError "'byCasesDec' tactic failed, unexpected number of subgoals"
+  -- We flip `s₁` and `s₂` because `isFalse` is the first constructor.
+  return ((← toByCasesSubgoal s₂), (← toByCasesSubgoal s₁))
+
+builtin_initialize registerTraceClass `Meta.Tactic.cases
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Cleanup.lean

@@ -0,0 +1,75 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.CollectFVars
+import Lean.Meta.Tactic.Clear
+
+namespace Lean.Meta
+
+private partial def cleanupCore (mvarId : MVarId) (toPreserve : Array FVarId) (indirectProps : Bool) : MetaM MVarId := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `cleanup
+    let used ← collectUsed |>.run' (false, {})
+    let mut lctx ← getLCtx
+    for localDecl in lctx do
+      unless used.contains localDecl.fvarId do
+        lctx := lctx.erase localDecl.fvarId
+    let localInsts := (← getLocalInstances).filter fun inst => used.contains inst.fvar.fvarId!
+    let mvarNew ← mkFreshExprMVarAt lctx localInsts (← instantiateMVars (← mvarId.getType)) .syntheticOpaque (← mvarId.getTag)
+    mvarId.assign mvarNew
+    return mvarNew.mvarId!
+where
+  addUsedFVars (e : Expr) : StateRefT (Bool × FVarIdSet) MetaM Unit := do
+    let (_, s) ← (← instantiateMVars e).collectFVars |>.run {}
+    for fvarId in s.fvarSet do
+      addUsedFVar fvarId
+
+  addDeps (fvarId : FVarId) : StateRefT (Bool × FVarIdSet) MetaM Unit := do
+    let localDecl ← fvarId.getDecl
+    addUsedFVars localDecl.type
+    if let some val := localDecl.value? then
+      addUsedFVars val
+
+  addUsedFVar (fvarId : FVarId) : StateRefT (Bool × FVarIdSet) MetaM Unit := do
+    unless (← get).2.contains fvarId do
+      modify fun (_, s) => (true, s.insert fvarId)
+      addDeps fvarId
+
+  /-- We include `p` in the used-set, if `p` is a proposition that contains a `x` that is in the used-set. -/
+  collectPropsStep : StateRefT (Bool × FVarIdSet) MetaM Unit := do
+    let usedSet := (← get).2
+    for localDecl in (← getLCtx) do
+      if (← isProp localDecl.type) then
+        if (← dependsOnPred localDecl.type usedSet.contains) then
+          addUsedFVar localDecl.fvarId
+
+  collectProps : StateRefT (Bool × FVarIdSet) MetaM Unit := do
+    modify fun s => (false, s.2)
+    collectPropsStep
+    if (← get).1 then
+      collectProps
+
+  collectUsed : StateRefT (Bool × FVarIdSet) MetaM FVarIdSet := do
+    addUsedFVars (← instantiateMVars (← mvarId.getType))
+    toPreserve.forM addUsedFVar
+    if indirectProps then collectProps
+    return (← get).2
+
+/--
+  Auxiliary tactic for cleaning the local context. It removes local declarations (aka hypotheses) that are *not* relevant.
+  We say a variable `x` is "relevant" if
+  - It occurs in the `toPreserve` array, or
+  - It occurs in the target type, or
+  - There is a relevant variable `y` that depends on `x`, or
+  - If `indirectProps` is true, the type of `x` is a proposition and it depends on a relevant variable `y`.
+
+  By default, `toPreserve := #[]` and `indirectProps := true`. These settings are used in the mathlib tactic `extract_goal`
+  to give the user more control over which variables to include.
+-/
+abbrev _root_.Lean.MVarId.cleanup (mvarId : MVarId) (toPreserve : Array FVarId := #[]) (indirectProps : Bool := true) : MetaM MVarId := do
+  cleanupCore mvarId toPreserve indirectProps
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Clear.lean

@@ -0,0 +1,73 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Util
+
+namespace Lean.Meta
+
+/--
+Erase the given free variable from the goal `mvarId`.
+-/
+def _root_.Lean.MVarId.clear (mvarId : MVarId) (fvarId : FVarId) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `clear
+    let lctx ← getLCtx
+    unless lctx.contains fvarId do
+      throwTacticEx `clear mvarId m!"unknown variable '{mkFVar fvarId}'"
+    let tag ← mvarId.getTag
+    lctx.forM fun localDecl => do
+      unless localDecl.fvarId == fvarId do
+        if (← localDeclDependsOn localDecl fvarId) then
+          throwTacticEx `clear mvarId m!"variable '{localDecl.toExpr}' depends on '{mkFVar fvarId}'"
+    let mvarDecl ← mvarId.getDecl
+    if (← exprDependsOn mvarDecl.type fvarId) then
+      throwTacticEx `clear mvarId m!"target depends on '{mkFVar fvarId}'"
+    let lctx := lctx.erase fvarId
+    let localInsts ← getLocalInstances
+    let localInsts := match localInsts.findFinIdx? fun localInst => localInst.fvar.fvarId! == fvarId with
+      | none => localInsts
+      | some idx => localInsts.eraseIdx idx
+    let newMVar ← mkFreshExprMVarAt lctx localInsts mvarDecl.type MetavarKind.syntheticOpaque tag
+    mvarId.assign newMVar
+    pure newMVar.mvarId!
+
+
+/--
+Try to erase the given free variable from the goal `mvarId`. It is no-op if the free variable
+cannot be erased due to forward dependencies.
+-/
+def _root_.Lean.MVarId.tryClear (mvarId : MVarId) (fvarId : FVarId) : MetaM MVarId :=
+  mvarId.clear fvarId <|> pure mvarId
+
+/--
+Try to clear the given fvars from the local context.
+
+The fvars must be given in the order they appear in the local context.
+
+See also `tryClearMany'` which takes care of reordering internally,
+and returns the cleared hypotheses along with the new goal.
+-/
+def _root_.Lean.MVarId.tryClearMany (mvarId : MVarId) (fvarIds : Array FVarId) : MetaM MVarId := do
+  fvarIds.foldrM (init := mvarId) fun fvarId mvarId => mvarId.tryClear fvarId
+
+/--
+Try to clear the given fvars from the local context. Returns the new goal and
+the hypotheses that were cleared.
+
+Does not require the `hyps` to be given in the order in which they
+appear in the local context.
+-/
+def _root_.Lean.MVarId.tryClearMany' (goal : MVarId) (fvarIds : Array FVarId) :
+    MetaM (MVarId × Array FVarId) :=
+  goal.withContext do
+    let fvarIds := (← getLCtx).sortFVarsByContextOrder fvarIds
+    fvarIds.foldrM (init := (goal, Array.mkEmpty fvarIds.size))
+      fun h (goal, cleared) => do
+        let goal' ← goal.tryClear h
+        let cleared := if goal == goal' then cleared else cleared.push h
+        return (goal', cleared)
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Congr.lean

@@ -0,0 +1,118 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.CongrTheorems
+import Lean.Meta.Tactic.Assert
+import Lean.Meta.Tactic.Apply
+import Lean.Meta.Tactic.Clear
+import Lean.Meta.Tactic.Refl
+import Lean.Meta.Tactic.Assumption
+
+namespace Lean
+open Meta
+
+/--
+Preprocessor before applying congruence theorem.
+Tries to close new goals using `Eq.refl`, `HEq.refl`, and `assumption`.
+It also tries to apply `heq_of_eq`.
+-/
+def MVarId.congrPre (mvarId : MVarId) : MetaM (Option MVarId) := do
+  let mvarId ← mvarId.heqOfEq
+  try mvarId.refl; return none catch _ => pure ()
+  try mvarId.hrefl; return none catch _ => pure ()
+  if (← mvarId.assumptionCore) then return none
+  return some mvarId
+
+/--
+Asserts the given congruence theorem as fresh hypothesis, and then applies it.
+Return the `fvarId` for the new hypothesis and the new subgoals.
+-/
+private def applyCongrThm? (mvarId : MVarId) (congrThm : CongrTheorem) : MetaM (List MVarId) := do
+  let mvarId ← mvarId.assert (← mkFreshUserName `h_congr_thm) congrThm.type congrThm.proof
+  let (fvarId, mvarId) ← mvarId.intro1P
+  let mvarIds ← mvarId.apply (mkFVar fvarId) { synthAssignedInstances := false }
+  mvarIds.mapM fun mvarId => mvarId.tryClear fvarId
+
+/--
+Try to apply a `simp` congruence theorem.
+-/
+def MVarId.congr? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
+  mvarId.withContext do commitWhenSomeNoEx? do
+    mvarId.checkNotAssigned `congr
+    let target ← mvarId.getType'
+    let some (_, lhs, _) := target.eq? | return none
+    let lhs := lhs.cleanupAnnotations
+    unless lhs.isApp do return none
+    let some congrThm ← mkCongrSimp? lhs.getAppFn (subsingletonInstImplicitRhs := false) | return none
+    applyCongrThm? mvarId congrThm
+
+/--
+Try to apply a `hcongr` congruence theorem, and then tries to close resulting goals
+using `Eq.refl`, `HEq.refl`, and assumption.
+-/
+def MVarId.hcongr? (mvarId : MVarId) : MetaM (Option (List MVarId)) := do
+  commitWhenSomeNoEx? do
+    mvarId.checkNotAssigned `congr
+    let mvarId ← mvarId.eqOfHEq
+    mvarId.withContext do
+      let target ← mvarId.getType'
+      let some (_, lhs, _, _) := target.heq? | return none
+      let lhs := lhs.cleanupAnnotations
+      unless lhs.isApp do return none
+      let congrThm ← mkHCongr lhs.getAppFn
+      applyCongrThm? mvarId congrThm
+
+/--
+Try to apply `implies_congr`.
+-/
+def MVarId.congrImplies? (mvarId : MVarId) : MetaM (Option (List MVarId)) :=
+  observing? do
+    let mvarId₁ :: mvarId₂ :: _ ← mvarId.apply (← mkConstWithFreshMVarLevels ``implies_congr) | throwError "unexpected number of goals"
+    return [mvarId₁, mvarId₂]
+
+/--
+Given a goal of the form `⊢ f as = f bs`, `⊢ (p → q) = (p' → q')`, or `⊢ f as ≍ f bs`, try to apply congruence.
+It takes proof irrelevance into account, and the fact that `Decidable p` is a subsingleton.
+-/
+def MVarId.congrCore (mvarId : MVarId) : MetaM (List MVarId) := do
+  if let some mvarIds ← mvarId.congr? then
+    pure mvarIds
+  else if let some mvarIds ← mvarId.hcongr? then
+    pure mvarIds
+  else if let some mvarIds ← mvarId.congrImplies? then
+    pure mvarIds
+  else
+    throwTacticEx `congr mvarId "failed to apply congruence"
+
+/--
+Given a goal of the form `⊢ f as = f bs`, `⊢ (p → q) = (p' → q')`, or `⊢ f as ≍ f bs`, try to apply congruence.
+It takes proof irrelevance into account, and the fact that `Decidable p` is a subsingleton.
+
+* Applies `congr` recursively up to depth `depth`.
+* If `closePre := true`, it will attempt to close new goals
+  using `Eq.refl`, `HEq.refl`, and `assumption` with reducible transparency.
+* If `closePost := true`, it will try again on goals on which `congr` failed to make progress
+  with default transparency.
+-/
+def MVarId.congrN (mvarId : MVarId) (depth : Nat := 1000000) (closePre := true) (closePost := true) : MetaM (List MVarId) := do
+  let (_, s) ← go depth mvarId |>.run #[]
+  return s.toList
+where
+  post (mvarId : MVarId) : StateRefT (Array MVarId) MetaM Unit := do
+    if closePost && (← getTransparency) != .reducible then
+      if let some mvarId ← mvarId.congrPre then
+        modify (·.push mvarId)
+    else
+      modify (·.push mvarId)
+
+  go (n : Nat) (mvarId : MVarId) : StateRefT (Array MVarId) MetaM Unit := do
+    if let some mvarId ← if closePre then withReducible mvarId.congrPre else pure mvarId then
+      match n with
+      | 0 => post mvarId
+      | n+1 =>
+        let some mvarIds ← observing? (m := MetaM) mvarId.congrCore
+          | post mvarId
+        mvarIds.forM (go n)

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Constructor.lean

@@ -0,0 +1,49 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Check
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Apply
+
+namespace Lean.Meta
+
+/--
+When the goal `mvarId` type is an inductive datatype,
+`constructor` calls `apply` with the first matching constructor.
+-/
+def _root_.Lean.MVarId.constructor (mvarId : MVarId) (cfg : ApplyConfig := {}) : MetaM (List MVarId) := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `constructor
+    let target ← mvarId.getType'
+    matchConstInduct target.getAppFn
+      (fun _ => throwTacticEx `constructor mvarId "target is not an inductive datatype")
+      fun ival us => do
+        for ctor in ival.ctors do
+          try
+            return ← mvarId.apply (Lean.mkConst ctor us) cfg
+          catch _ =>
+            pure ()
+        throwTacticEx `constructor mvarId "no applicable constructor found"
+
+def _root_.Lean.MVarId.existsIntro (mvarId : MVarId) (w : Expr) : MetaM MVarId := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `exists
+    let target ← mvarId.getType'
+    matchConstStructure target.getAppFn
+      (fun _ => throwTacticEx `exists mvarId "target is not an inductive datatype with one constructor")
+      fun _ us cval => do
+        if cval.numFields < 2 then
+          throwTacticEx `exists mvarId "constructor must have at least two fields"
+        let ctor := mkAppN (Lean.mkConst cval.name us) target.getAppArgs[*...cval.numParams]
+        let ctorType ← inferType ctor
+        let (mvars, _, _) ← forallMetaTelescopeReducing ctorType (some (cval.numFields-2))
+        let f := mkAppN ctor mvars
+        checkApp f w
+        let [mvarId] ← mvarId.apply <| mkApp f w
+          | throwTacticEx `exists mvarId "unexpected number of subgoals"
+        pure mvarId
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Contradiction.lean

@@ -0,0 +1,232 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.MatchUtil
+import Lean.Meta.Tactic.Assumption
+import Lean.Meta.Tactic.Cases
+import Lean.Meta.Tactic.Apply
+
+namespace Lean.Meta
+
+structure Contradiction.Config where
+  useDecide  : Bool := true
+  /-- Check whether any of the hypotheses is an empty type. -/
+  emptyType  : Bool := true
+  /-- When checking for empty types, `searchFuel` specifies the number of goals visited. -/
+  searchFuel : Nat  := 16
+  /-- Support for hypotheses such as
+     ```
+     h : (x y : Nat) (ys : List Nat) → x = 0 → y::ys = [a, b, c] → False
+     ```
+     This kind of hypotheses appear when proving conditional equation theorems for match expressions. -/
+  genDiseq : Bool := false
+
+/--
+  Try to close the current goal by looking for a proof of `False` nested in a `False.Elim` application in the target.
+  Return `true` iff the goal has been closed.
+-/
+private def nestedFalseElim (mvarId : MVarId) : MetaM Bool := do
+  let target ← mvarId.getType
+  if let some falseElim := target.find? fun e => e.isAppOfArity ``False.elim 2 && !e.appArg!.hasLooseBVars then
+    let falseProof := falseElim.appArg!
+    mvarId.assign (← mkFalseElim (← mvarId.getType) falseProof)
+    return true
+  else
+    return false
+
+-- We only consider inductives with no constructors and indexed families
+private def isElimEmptyInductiveCandidate (fvarId : FVarId) : MetaM Bool := do
+  let type ← whnfD (← fvarId.getType)
+  matchConstInduct type.getAppFn (fun _ => pure false) fun info _ => do
+    return info.ctors.length == 0 || info.numIndices > 0
+
+namespace ElimEmptyInductive
+
+abbrev M := StateRefT Nat MetaM
+
+instance : MonadBacktrack SavedState M where
+  saveState      := Meta.saveState
+  restoreState s := s.restore
+
+partial def elim (mvarId : MVarId) (fvarId : FVarId) : M Bool := do
+  if (← get) == 0 then
+    trace[Meta.Tactic.contradiction] "elimEmptyInductive out-of-fuel"
+    return false
+  modify (· - 1)
+  -- We only consider inductives with no constructors and indexed families
+  commitWhen do
+    let subgoals ← try mvarId.cases fvarId catch ex => trace[Meta.Tactic.contradiction] "{ex.toMessageData}"; return false
+    trace[Meta.Tactic.contradiction] "elimEmptyInductive, number subgoals: {subgoals.size}"
+    for subgoal in subgoals do
+      -- If one of the fields is uninhabited, then we are done
+      let found ← subgoal.mvarId.withContext do
+        for field in subgoal.fields do
+          let field := subgoal.subst.apply field
+          if field.isFVar then
+            if (← isElimEmptyInductiveCandidate field.fvarId!) then
+              if (← elim subgoal.mvarId field.fvarId!) then
+                return true
+        return false
+      unless found do
+        return false
+    return true
+
+end ElimEmptyInductive
+
+private def elimEmptyInductive (mvarId : MVarId) (fvarId : FVarId) (fuel : Nat) : MetaM Bool := do
+  mvarId.withContext do
+    if (← isElimEmptyInductiveCandidate fvarId) then
+      commitWhen do
+        ElimEmptyInductive.elim (← mvarId.exfalso) fvarId |>.run' fuel
+    else
+      return false
+
+/--
+  See `Simp.isEqnThmHypothesis`
+-/
+private abbrev isGenDiseq (e : Expr) : Bool :=
+  Simp.isEqnThmHypothesis e
+
+/--
+  Given `e` s.t. `isGenDiseq e`, generate a bit-mask `mask` s.t. `mask[i] = true` iff
+  the `i`-th binder is an equality without forward dependencies.
+
+  See `processGenDiseq`
+-/
+def mkGenDiseqMask (e : Expr) : Array Bool :=
+  go e #[]
+where
+  go (e : Expr) (acc : Array Bool) : Array Bool :=
+    match e with
+    | .forallE _ d b _ => go b (acc.push (!b.hasLooseBVar 0 && (d.isEq || d.isHEq)))
+    | _ => acc
+
+/--
+  Close goal if `localDecl` is a "generalized disequality". Example:
+  ```
+  h : (x y : Nat) (ys : List Nat) → x = 0 → y::ys = [a, b, c] → False
+  ```
+  This kind of hypotheses is created when we generate conditional equations for match expressions.
+-/
+private def processGenDiseq (mvarId : MVarId) (localDecl : LocalDecl) : MetaM Bool := do
+  assert! isGenDiseq localDecl.type
+  let val? ← withNewMCtxDepth do
+    let (args, _, _) ← forallMetaTelescope localDecl.type
+    let mask  := mkGenDiseqMask localDecl.type
+    for arg in args, useRefl in mask do
+      if useRefl then
+        /- Remark: we should not try to use `refl` for equalities that have forward dependencies because
+           they correspond to constructor fields. We did not use to have this extra test, and this method failed
+           to close the following goal.
+           ```
+            ...
+            ns' : NEList String
+            h' : NEList.notUno ns' = true
+            : ∀ (ns : NEList String) (h : NEList.notUno ns = true), Value.lam (Lambda.mk ns' h') = Value.lam (Lambda.mk ns h) → False
+            ⊢ h_1 l a = h_2 v
+
+           ```
+         -/
+        if let some (_, lhs, _) ← matchEq? (← inferType arg) then
+          unless (← isDefEq arg (← mkEqRefl lhs)) do
+            return none
+        if let some (_, lhs, _,  _) ← matchHEq? (← inferType arg) then
+          unless (← isDefEq arg (← mkHEqRefl lhs)) do
+            return none
+    let falseProof ← instantiateMVars (mkAppN localDecl.toExpr args)
+    if (← hasAssignableMVar falseProof) then
+      return none
+    return some (← mkFalseElim (← mvarId.getType) falseProof)
+  if let some val := val? then
+    mvarId.assign val
+    return true
+  else
+    return false
+
+/--
+Return `true` if goal `mvarId` has contradictory hypotheses.
+See `MVarId.contradiction` for the list of tests performed by this method.
+-/
+def _root_.Lean.MVarId.contradictionCore (mvarId : MVarId) (config : Contradiction.Config) : MetaM Bool := do
+  mvarId.withContext do
+    mvarId.checkNotAssigned `contradiction
+    if (← nestedFalseElim mvarId) then
+      return true
+    for localDecl in (← getLCtx) do
+      unless localDecl.isImplementationDetail do
+        -- (h : ¬ p) (h' : p)
+        if let some p ← matchNot? localDecl.type then
+          if let some pFVarId ← findLocalDeclWithType? p then
+            -- We use `False.elim` because `p`'s type may be Type
+            mvarId.assign (← mkFalseElim (← mvarId.getType) (mkApp localDecl.toExpr (mkFVar pFVarId)))
+            return true
+        -- (h : x ≠ x)
+        if let some (_, lhs, rhs) ← matchNe? localDecl.type then
+          if (← isDefEq lhs rhs) then
+            mvarId.assign (← mkAbsurd (←  mvarId.getType) (← mkEqRefl lhs) localDecl.toExpr)
+            return true
+        let mut isEq := false
+        -- (h : ctor₁ ... = ctor₂ ...)
+        if let some (_, lhs, rhs) ← matchEq? localDecl.type then
+          isEq := true
+          if let some lhsCtor ← matchConstructorApp? lhs then
+          if let some rhsCtor ← matchConstructorApp? rhs then
+          if lhsCtor.name != rhsCtor.name then
+            mvarId.assign (← mkNoConfusion (← mvarId.getType) localDecl.toExpr)
+            return true
+        let mut isHEq := false
+        -- (h : ctor₁ ... ≍ ctor₂ ...)
+        if let some (α, lhs, β, rhs) ← matchHEq? localDecl.type then
+          isHEq := true
+          if let some lhsCtor ← matchConstructorApp? lhs then
+          if let some rhsCtor ← matchConstructorApp? rhs then
+          if lhsCtor.name != rhsCtor.name then
+            if (← isDefEq α β) then
+              mvarId.assign (← mkNoConfusion (← mvarId.getType) (← mkEqOfHEq localDecl.toExpr))
+              return true
+        -- (h : p) s.t. `decide p` evaluates to `false`
+        if config.useDecide && !localDecl.type.hasFVar then
+          let type ← instantiateMVars localDecl.type
+          if !type.hasMVar && !type.hasFVar then
+            try
+              let d ← mkDecide localDecl.type
+              let r ← withDefault <| whnf d
+              if r.isConstOf ``false then
+                let hn := mkAppN (mkConst ``of_decide_eq_false) <| d.getAppArgs.push (← mkEqRefl d)
+                mvarId.assign (← mkAbsurd (← mvarId.getType) localDecl.toExpr hn)
+                return true
+            catch _ =>
+              pure ()
+        -- "generalized" diseq
+        if config.genDiseq && isGenDiseq localDecl.type then
+          if (← processGenDiseq mvarId localDecl) then
+            return true
+        -- (h : <empty-inductive-type>)
+        if config.emptyType && !isEq && !isHEq then
+          -- We do not use `elimEmptyInductive` for equality, since `cases h` produces a huge proof
+          -- when `(h : 10000 = 10001)`. TODO: `cases` add a threshold at `cases`
+          if (← elimEmptyInductive mvarId localDecl.fvarId config.searchFuel) then
+            return true
+    return false
+
+/--
+Try to close the goal using "contradictions" such as
+- Contradictory hypotheses `h₁ : p` and `h₂ : ¬ p`.
+- Contradictory disequality `h : x ≠ x`.
+- Contradictory equality between different constructors, e.g., `h : List.nil = List.cons x xs`.
+- Empty inductive types, e.g., `x : Fin 0`.
+- Decidable propositions that evaluate to false, i.e., a hypothesis `h : p` s.t. `decide p` reduces to `false`.
+  This is only tried if `Config.useDecide = true`.
+
+Throw exception if goal failed to be closed.
+-/
+def _root_.Lean.MVarId.contradiction (mvarId : MVarId) (config : Contradiction.Config := {}) : MetaM Unit :=
+  unless (← mvarId.contradictionCore config) do
+    throwTacticEx `contradiction mvarId
+
+builtin_initialize registerTraceClass `Meta.Tactic.contradiction
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Delta.lean

@@ -0,0 +1,43 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Transform
+import Lean.Meta.Tactic.Replace
+
+namespace Lean.Meta
+
+def delta? (e : Expr) (p : Name → Bool := fun _ => true) : CoreM (Option Expr) :=
+  matchConst e.getAppFn (fun _ => return none) fun fInfo fLvls => do
+    if p fInfo.name && fInfo.hasValue && fInfo.levelParams.length == fLvls.length then
+      let f ← instantiateValueLevelParams fInfo fLvls
+      return some (f.betaRev e.getAppRevArgs (useZeta := true))
+    else
+      return none
+
+/-- Low-level delta expansion. It is used to implement equation lemmas and elimination principles for recursive definitions. -/
+def deltaExpand (e : Expr) (p : Name → Bool) : CoreM Expr :=
+  Core.transform e fun e => do
+    match (← delta? e p) with
+    | some e' => return .visit e'
+    | none    => return .continue
+
+/--
+Delta expand declarations that satisfy `p` at `mvarId` type.
+-/
+def _root_.Lean.MVarId.deltaTarget (mvarId : MVarId) (p : Name → Bool) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `delta
+    mvarId.change (← deltaExpand (← mvarId.getType) p) (checkDefEq := false)
+
+/--
+Delta expand declarations that satisfy `p` at `fvarId` type.
+-/
+def _root_.Lean.MVarId.deltaLocalDecl (mvarId : MVarId) (fvarId : FVarId) (p : Name → Bool) : MetaM MVarId :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `delta
+    mvarId.changeLocalDecl fvarId (← deltaExpand (← fvarId.getType) p) (checkDefEq := false)
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/ElimInfo.lean

@@ -0,0 +1,281 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Basic
+import Lean.Meta.Check
+import Lean.ScopedEnvExtension
+
+namespace Lean.Meta
+
+structure ElimAltInfo where
+  name      : Name
+  /-- A declaration corresponding to the inductive constructor.
+  (For custom recursors, the alternatives correspond to parameter names in the
+  recursor, so we may not have a declaration to point to.)
+  This is used for go-to-definition on the alternative name. -/
+  declName? : Option Name
+  numFields : Nat
+  /-- If `provesMotive := true`, then this alternative has `motive` as its conclusion.
+  Only for those alternatives the `induction` tactic should introduce reverted hypotheses.  -/
+  provesMotive : Bool
+  deriving Repr, Inhabited
+
+/--
+Information about an eliminator as used by `induction` or `cases`.
+
+Created from an expression by `getElimInfo`. This typically contains level metavariables that
+are instantiated as we go (e.g. in `addImplicitTargets`), so this is single use.
+-/
+structure ElimInfo where
+  elimExpr   : Expr
+  elimType   : Expr
+  motivePos  : Nat
+  targetsPos : Array Nat := #[]
+  altsInfo   : Array ElimAltInfo := #[]
+  /--
+  Extra arguments to the motive, after the targets, that are instantiated with
+  non-atomic expressions in the goal
+  -/
+  numComplexMotiveArgs : Nat
+  deriving Repr, Inhabited
+
+
+/-- Given the type `t` of an alternative, determines the number of parameters
+(.forall and .let)-bound, and whether the conclusion is a `motive`-application.  -/
+def altArity (motive : Expr) (n : Nat) : Expr → Nat × Bool
+  | .forallE _ _ b _ => altArity motive (n+1) b
+  | .letE _ _ _ b _ => altArity motive (n+1) b
+  | conclusion => (n, conclusion.getAppFn == motive)
+
+
+def getElimExprInfo (elimExpr : Expr) (baseDeclName? : Option Name := none) : MetaM ElimInfo := do
+  let elimType ← inferType elimExpr
+  trace[Elab.induction] "eliminator {indentExpr elimExpr}\nhas type{indentExpr elimType}"
+  forallTelescopeReducing elimType fun xs type => type.withApp fun motive motiveArgs => do
+    unless motive.isFVar do
+      throwError "expected resulting type of eliminator to be an application of one of its parameters (the motive):{indentExpr type}"
+    let targets  := motiveArgs.takeWhile (·.isFVar)
+    let complexMotiveArgs := motiveArgs[targets.size...*]
+    let motiveType ← inferType motive
+    forallTelescopeReducing motiveType fun motiveParams motiveResultType => do
+      unless motiveParams.size == motiveArgs.size do
+        throwError "expected {motiveArgs.size} parameters at motive type, got {motiveParams.size}:{indentExpr motiveType}"
+      unless motiveResultType.isSort do
+        throwError "motive result type must be a sort{indentExpr motiveType}"
+    let some motivePos ← pure (xs.idxOf? motive) |
+      throwError "unexpected eliminator type{indentExpr elimType}"
+    let targetsPos ← targets.mapM fun target => do
+      match xs.idxOf? target with
+      | none => throwError "unexpected eliminator type{indentExpr elimType}"
+      | some targetPos => pure targetPos
+    let mut altsInfo := #[]
+    let env ← getEnv
+    for h : i in [:xs.size] do
+      let x := xs[i]
+      if x != motive && !targets.contains x then
+        let xDecl ← x.fvarId!.getDecl
+        if xDecl.binderInfo.isExplicit then
+          let (numFields, provesMotive) := altArity motive 0 xDecl.type
+          let name := xDecl.userName
+          let declName? := do
+            let base ← baseDeclName?
+            let altDeclName := base ++ name
+            if env.contains altDeclName then some altDeclName else none
+          altsInfo := altsInfo.push { name, declName?, numFields, provesMotive }
+    pure { elimExpr, elimType,  motivePos, targetsPos, altsInfo, numComplexMotiveArgs := complexMotiveArgs.size }
+
+def getElimInfo (elimName : Name) (baseDeclName? : Option Name := none) : MetaM ElimInfo := do
+  getElimExprInfo (← mkConstWithFreshMVarLevels elimName) baseDeclName?
+
+/--
+  Eliminators/recursors may have implicit targets. For builtin recursors, all indices are implicit targets.
+  Given an eliminator and the sequence of explicit targets, this methods returns a new sequence containing
+  implicit and explicit targets.
+-/
+partial def addImplicitTargets (elimInfo : ElimInfo) (targets : Array Expr) : MetaM (Array Expr) := do
+  let (implicitMVars, targets) ← collect elimInfo.elimType 0 0 #[] #[]
+  for mvar in implicitMVars do
+    unless ← mvar.isAssigned do
+      let name := (←mvar.getDecl).userName
+      if name.isAnonymous || name.hasMacroScopes then
+        throwError "failed to infer implicit target"
+      else
+        throwError "failed to infer implicit target {(←mvar.getDecl).userName}"
+  targets.mapM instantiateMVars
+where
+  collect (type : Expr) (argIdx targetIdx : Nat) (implicits : Array MVarId) (targets' : Array Expr) :
+      MetaM (Array MVarId × Array Expr) := do
+    match (�� whnfD type) with
+    | Expr.forallE n d b bi =>
+      if elimInfo.targetsPos.contains argIdx then
+        if bi.isExplicit then
+          unless targetIdx < targets.size do
+            throwError "insufficient number of targets for '{elimInfo.elimExpr}'"
+          let target := targets[targetIdx]!
+          let targetType ← inferType target
+          unless (← isDefEq d targetType) do
+            throwError "target{indentExpr target}\n{← mkHasTypeButIsExpectedMsg targetType d}"
+          collect (b.instantiate1 target) (argIdx+1) (targetIdx+1) implicits (targets'.push target)
+        else
+          let implicitTarget ← mkFreshExprMVar (type? := d) (userName := n)
+          collect (b.instantiate1 implicitTarget) (argIdx+1) targetIdx (implicits.push implicitTarget.mvarId!) (targets'.push implicitTarget)
+      else
+        collect (b.instantiate1 (← mkFreshExprMVar d)) (argIdx+1) targetIdx implicits targets'
+    | _ =>
+      unless targetIdx = targets.size do
+        throwError "extra targets for '{elimInfo.elimExpr}'"
+      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 (Bool × Array Name) Name := {}
+  deriving Inhabited, Repr
+
+def addCustomEliminatorEntry (es : CustomEliminators) (e : CustomEliminator) : CustomEliminators :=
+  match es with
+  | { map := map } => { map := map.insert (e.induction, e.typeNames) e.elimName }
+
+builtin_initialize customEliminatorExt : SimpleScopedEnvExtension CustomEliminator CustomEliminators ←
+  registerSimpleScopedEnvExtension {
+    initial        := {}
+    addEntry       := addCustomEliminatorEntry
+    finalizeImport := fun { map := map } => { map := map.switch }
+  }
+
+def mkCustomEliminator (elimName : Name) (induction : Bool) : MetaM CustomEliminator := do
+  let elimInfo ← getElimInfo elimName
+  let info ← getConstInfo elimName
+  forallTelescopeReducing info.type fun xs _ => do
+    let mut typeNames := #[]
+    for hi : i in [:elimInfo.targetsPos.size] do
+      let targetPos := elimInfo.targetsPos[i]
+      let x := xs[targetPos]!
+      /- Return true if there is another target that depends on `x`. -/
+      let isImplicitTarget : MetaM Bool := do
+        for hj : j in [i+1:elimInfo.targetsPos.size] do
+          let y := xs[elimInfo.targetsPos[j]]!
+          let yType ← inferType y
+          if (← dependsOn yType x.fvarId!) then
+            return true
+        return false
+      /- We should only use explicit targets when creating the key for the `CustomEliminators` map.
+         See test `tests/lean/run/eliminatorImplicitTargets.lean`. -/
+      unless (← isImplicitTarget) do
+        let xType ← inferType x
+        let .const typeName .. := xType.getAppFn | throwError "unexpected eliminator target type{indentExpr xType}"
+        typeNames := typeNames.push typeName
+    return { induction, typeNames, elimName }
+
+def addCustomEliminator (declName : Name) (attrKind : AttributeKind) (induction : Bool) : MetaM Unit := do
+  let e ← mkCustomEliminator declName induction
+  customEliminatorExt.add e attrKind
+
+/--
+Registers a custom eliminator for the `induction` tactic.
+
+Whenever the types of the targets in an `induction` call matches a custom eliminator, it is used
+instead of the recursor. This can be useful for redefining the default eliminator to a more useful
+one.
+
+Example:
+```lean example
+structure Three where
+  val : Fin 3
+
+example (x : Three) (p : Three → Prop) : p x := by
+  induction x
+  -- val : Fin 3 ⊢ p ⟨val⟩
+
+@[induction_eliminator, elab_as_elim]
+def Three.myRec {motive : Three → Sort u}
+    (zero : motive ⟨0⟩) (one : motive ⟨1⟩) (two : motive ⟨2⟩) :
+    ∀ x, motive x
+  | ⟨0⟩ => zero | ⟨1⟩ => one | ⟨2⟩ => two
+
+example (x : Three) (p : Three → Prop) : p x := by
+  induction x
+  -- ⊢ p ⟨0⟩
+  -- ⊢ p ⟨1⟩
+  -- ⊢ p ⟨2⟩
+```
+
+`@[cases_eliminator]` works similarly for the `cases` tactic.
+-/
+@[builtin_doc]
+builtin_initialize
+  registerBuiltinAttribute {
+    name  := `induction_eliminator
+    descr := "custom `rec`-like eliminator for the `induction` tactic"
+    add   := fun declName _ attrKind => do
+      discard <| addCustomEliminator declName attrKind (induction := true) |>.run {} {}
+  }
+
+/--
+Registers a custom eliminator for the `cases` tactic.
+
+Whenever the types of the targets in an `cases` call matches a custom eliminator, it is used
+instead of the `casesOn` eliminator. This can be useful for redefining the default eliminator to a
+more useful one.
+
+Example:
+```lean example
+structure Three where
+  val : Fin 3
+
+example (x : Three) (p : Three → Prop) : p x := by
+  cases x
+  -- val : Fin 3 ⊢ p ⟨val⟩
+
+@[cases_eliminator, elab_as_elim]
+def Three.myRec {motive : Three → Sort u}
+    (zero : motive ⟨0⟩) (one : motive ⟨1⟩) (two : motive ⟨2⟩) :
+    ∀ x, motive x
+  | ��0⟩ => zero | ⟨1⟩ => one | ⟨2⟩ => two
+
+example (x : Three) (p : Three → Prop) : p x := by
+  cases x
+  -- ⊢ p ⟨0⟩
+  -- ⊢ p ⟨1⟩
+  -- ⊢ p ⟨2⟩
+```
+
+`@[induction_eliminator]` works similarly for the `induction` tactic.
+-/
+@[builtin_doc]
+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)
+
+/--
+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? (induction, key)
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/ExposeNames.lean

@@ -0,0 +1,66 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Util
+
+namespace Lean.Meta
+
+/-- Returns a copy of the local context in which all declarations have clear, accessible names. -/
+private def getLCtxWithExposedNames : MetaM LocalContext := do
+  let mut map : Std.HashMap Name FVarId := {}
+  let mut toRename := #[]
+  let mut lctx ← getLCtx
+  for localDecl in lctx do
+    let userName := localDecl.userName
+    if userName.hasMacroScopes then
+      toRename := toRename.push localDecl.fvarId
+    else
+      if let some fvarId := map[userName]? then
+        -- Variable has been shadowed
+        toRename := toRename.push fvarId
+      map := map.insert userName localDecl.fvarId
+  if toRename.isEmpty then
+    return lctx
+  let mut next : Std.HashMap Name Nat := {}
+  -- Remark: Shadowed variables may be inserted later.
+  toRename := toRename.qsort fun fvarId₁ fvarId₂ =>
+    (lctx.get! fvarId₁).index < (lctx.get! fvarId₂).index
+  for fvarId in toRename do
+    let localDecl := lctx.get! fvarId
+    let mut baseName := localDecl.userName
+    if baseName.hasMacroScopes then
+      baseName := baseName.eraseMacroScopes
+      if baseName == `x || baseName == `a then
+        if (← isProp localDecl.type) then
+          baseName := `h
+    let mut userName := baseName
+    let mut i := next[baseName]?.getD 0
+    repeat
+      if !map.contains userName then
+        break
+      i := i + 1
+      userName := baseName.appendIndexAfter i
+    next := next.insert baseName i
+    map := map.insert userName fvarId
+    lctx := lctx.modifyLocalDecl fvarId (·.setUserName userName)
+  return lctx
+
+/--
+Creates a new goal whose local context has been "exposed" so that every local declaration has a clear, accessible name.
+If no local declarations require renaming, the original goal is returned unchanged.
+-/
+def _root_.Lean.MVarId.exposeNames (mvarId : MVarId) : MetaM MVarId := mvarId.withContext do
+  mvarId.checkNotAssigned `expose_names
+  let lctx ← getLCtxWithExposedNames
+  let mvarNew ← mkFreshExprMVarAt lctx (← getLocalInstances) (← mvarId.getType) .syntheticOpaque (← mvarId.getTag)
+  mvarId.assign mvarNew
+  return mvarNew.mvarId!
+
+/-- Creates a temporary local context where all names are exposed, and executes `k` -/
+def withExposedNames (k : MetaM α) : MetaM α := do
+  withNewMCtxDepth <| withLCtx (← getLCtxWithExposedNames) (← getLocalInstances) k
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Ext.lean

@@ -0,0 +1,85 @@
+/-
+Copyright (c) 2021 Gabriel Ebner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Gabriel Ebner, Mario Carneiro
+-/
+prelude
+import Init.Data.Array.InsertionSort
+import Lean.Meta.DiscrTree
+
+namespace Lean.Meta.Ext
+
+/-!
+### Environment extension for `ext` theorems
+-/
+
+/-- Information about an extensionality theorem, stored in the environment extension. -/
+structure ExtTheorem where
+  /-- Declaration name of the extensionality theorem. -/
+  declName : Name
+  /-- Priority of the extensionality theorem. -/
+  priority : Nat
+  /--
+  Key in the discrimination tree,
+  for the type in which the extensionality theorem holds.
+  -/
+  keys : Array DiscrTree.Key
+  deriving Inhabited, Repr, BEq, Hashable
+
+/-- The state of the `ext` extension environment -/
+structure ExtTheorems where
+  /-- The tree of `ext` extensions. -/
+  tree   : DiscrTree ExtTheorem := {}
+  /-- Erased `ext`s via `attribute [-ext]`. -/
+  erased  : PHashSet Name := {}
+  deriving Inhabited
+
+/-- The environment extension to track `@[ext]` theorems. -/
+builtin_initialize extExtension :
+    SimpleScopedEnvExtension ExtTheorem ExtTheorems ←
+  registerSimpleScopedEnvExtension {
+    addEntry := fun { tree, erased } thm =>
+      { tree := tree.insertCore thm.keys thm, erased := erased.erase thm.declName }
+    initial := {}
+  }
+
+/-- Gets the list of `@[ext]` theorems corresponding to the key `ty`,
+ordered from high priority to low. -/
+@[inline] def getExtTheorems (ty : Expr) : MetaM (Array ExtTheorem) := do
+  let extTheorems := extExtension.getState (← getEnv)
+  let arr ← extTheorems.tree.getMatch ty
+  let erasedArr := arr.filter fun thm => !extTheorems.erased.contains thm.declName
+  -- Using insertion sort because it is stable and the list of matches should be mostly sorted.
+  -- Most ext theorems have default priority.
+  return erasedArr.insertionSort (·.priority < ·.priority) |>.reverse
+
+/--
+Erases a name marked `ext` by adding it to the state's `erased` field and
+removing it from the state's list of `Entry`s.
+
+This is triggered by `attribute [-ext] name`.
+-/
+def ExtTheorems.eraseCore (d : ExtTheorems) (declName : Name) : ExtTheorems :=
+ { d with erased := d.erased.insert declName }
+
+/-- Returns `true` if `d` contains theorem with name `declName`. -/
+def ExtTheorems.contains (d : ExtTheorems) (declName : Name) : Bool :=
+  d.tree.containsValueP (·.declName == declName) && !d.erased.contains declName
+
+/-- Returns `true` if `declName` is tagged with `[ext]` attribute. -/
+def isExtTheorem (declName : Name) : CoreM Bool := do
+  let extTheorems := extExtension.getState (← getEnv)
+  return extTheorems.contains declName
+
+/--
+Erases a name marked as a `ext` attribute.
+Check that it does in fact have the `ext` attribute by making sure it names a `ExtTheorem`
+found somewhere in the state's tree, and is not erased.
+-/
+def ExtTheorems.erase [Monad m] [MonadError m] (d : ExtTheorems) (declName : Name) :
+    m ExtTheorems := do
+  unless d.contains declName do
+    throwError "'{declName}' does not have [ext] attribute"
+  return d.eraseCore declName
+
+end Lean.Meta.Ext

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/FVarSubst.lean

@@ -0,0 +1,84 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Mario Carneiro
+-/
+prelude
+import Lean.Data.AssocList
+import Lean.Expr
+import Lean.LocalContext
+import Lean.Util.ReplaceExpr
+
+namespace Lean.Meta
+/--
+  Some tactics substitute hypotheses with expressions.
+  We track these substitutions using `FVarSubst`.
+  It is just a mapping from the original FVarId (internal) name
+  to an expression. The free variables occurring in the expression must
+  be defined in the new goal. -/
+structure FVarSubst where
+  map : AssocList FVarId Expr := {}
+  deriving Inhabited
+
+namespace FVarSubst
+
+def empty : FVarSubst := {}
+
+def isEmpty (s : FVarSubst) : Bool :=
+  s.map.isEmpty
+
+def contains (s : FVarSubst) (fvarId : FVarId) : Bool :=
+  s.map.contains fvarId
+
+/-- Add entry `fvarId |-> v` to `s` if `s` does not contain an entry for `fvarId`. -/
+def insert (s : FVarSubst) (fvarId : FVarId) (v : Expr) : FVarSubst :=
+  if s.contains fvarId then s
+  else
+    let map := s.map.mapVal fun e => e.replaceFVarId fvarId v;
+    { map := map.insertNew fvarId v }
+
+def erase (s : FVarSubst) (fvarId : FVarId) : FVarSubst :=
+  { map := s.map.erase fvarId }
+
+def find? (s : FVarSubst) (fvarId : FVarId) : Option Expr :=
+  s.map.find? fvarId
+
+def get (s : FVarSubst) (fvarId : FVarId) : Expr :=
+  match s.map.find? fvarId with
+  | none   => mkFVar fvarId -- it has not been replaced
+  | some v => v
+
+/-- Given `e`, for each `(x => v)` in `s` replace `x` with `v` in `e` -/
+def apply (s : FVarSubst) (e : Expr) : Expr :=
+  if s.map.isEmpty then e
+  else if !e.hasFVar then e
+  else e.replace fun e => match e with
+    | Expr.fvar fvarId => match s.map.find? fvarId with
+      | none   => e
+      | some v => v
+    | _ => none
+
+def domain (s : FVarSubst) : List FVarId :=
+  s.map.foldl (init := []) fun r k _ => k :: r
+
+def any (p : FVarId → Expr → Bool) (s : FVarSubst) : Bool :=
+  s.map.any p
+
+/--
+Constructs a substitution consisting of `s` followed by `t`.
+This satisfies `(s.append t).apply e = t.apply (s.apply e)`
+-/
+def append (s t : FVarSubst) : FVarSubst :=
+  s.1.foldl (fun s' k v => s'.insert k (t.apply v)) t
+
+end FVarSubst
+end Meta
+
+def LocalDecl.applyFVarSubst (s : Meta.FVarSubst) : LocalDecl → LocalDecl
+  | LocalDecl.cdecl i id n t bi k   => LocalDecl.cdecl i id n (s.apply t) bi k
+  | LocalDecl.ldecl i id n t v nd k => LocalDecl.ldecl i id n (s.apply t) (s.apply v) nd k
+
+abbrev Expr.applyFVarSubst (s : Meta.FVarSubst) (e : Expr) : Expr :=
+  s.apply e
+
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/FunInd.lean

@@ -0,0 +1,1715 @@
+/-
+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.Subst
+import Lean.Meta.Injective -- for elimOptParam
+import Lean.Meta.ArgsPacker
+import Lean.Meta.PProdN
+import Lean.Elab.PreDefinition.WF.Eqns
+import Lean.Elab.PreDefinition.Structural.Eqns
+import Lean.Elab.PreDefinition.Structural.IndGroupInfo
+import Lean.Elab.PreDefinition.Structural.FindRecArg
+import Lean.Elab.Command
+import Lean.Meta.Tactic.ElimInfo
+import Lean.Meta.Tactic.FunIndInfo
+
+/-!
+This module contains code to derive, from the definition of a recursive function (structural or
+well-founded, possibly mutual), 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)
+```
+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 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 (well-founded recursion)
+
+For a non-mutual, unary function `foo` (or else for the `_unary` function), we
+
+1. expect its definition 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 (using `matcherApp.transform (useSplitter := true)`)
+   * simple discriminants that are mentioned in the goal (i.e plain parameters) are instantiated
+     in the goal.
+   * 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 …`)
+   * also, simple discriminants (`FVars`) are remembered as `toClear`, as they are unlikely to
+     provide useful context, and are redundant given the context that comes from the pattern match.
+
+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 `foldAndCollect`,
+   which are then asserted as inductive hyptheses in the `MVar`.
+
+5. The function `foldAndCollect` walks the term and performs two operations:
+
+   * collects the induction hypotheses for the current case (with proofs).
+   * recovering the recursive calls
+
+   So when it encounters a saturated application of `oldIH arg proof`, it
+   * returns `f arg` and
+   * remembers the expression `newIH arg proof : motive x` as an inductive hypothesis.
+
+   Since `arg` and `proof` can contain further recursive calls, they are folded there as well.
+   This assumes that the termination proof `proof` works nevertheless.
+
+   Again, `foldAndCollect` 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 auxiliary lemmas are unfolded if needed.
+
+7. After this construction, the MVars introduced by `buildInductionCase` are turned into parameters.
+
+The resulting term then becomes `foo.induct` at its inferred type.
+
+## Implementation overview (mutual/non-unary well-founded recursion)
+
+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 functions 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
+```
+
+## Implementation overview (structural recursion)
+
+When handling structural recursion, the overall approach is the same, with the following
+differences:
+
+* Instead of `WellFounded.fix` we look for a `.brecOn` application, using `isBRecOnRecursor`
+
+  Despite its name, this function does *not* recognize the `.brecOn` of inductive *predicates*,
+  which we also do not support at this point.
+
+* The elaboration of structurally recursive function can handle extra arguments. We keep the
+  `motive` parameters in the original order.
+
+## Unfolding principles
+
+The code can also create a variant of the induction/cases principles that automatically unfolds
+the function application. It's motive abstracts over the function call, so for the ackermann
+function one gets
+
+```
+ackermann.fun_cases_unfolding
+  (motive : Nat → Nat → Nat → Prop)
+  (case1 : ∀ (m : Nat), motive 0 m (m + 1))
+  (case2 : ∀ (n : Nat), motive n.succ 0 (ackermann n 1))
+  (case3 : ∀ (n m : Nat), motive n.succ m.succ (ackermann n (ackermann (n + 1) m)))
+  (x✝ x✝¹ : Nat) : motive x✝ x✝¹ (ackermann x✝ x✝¹)
+```
+
+To implement this, in the initial goal `motive x (ackermann x)` of `buildInductionBody` we unfold the
+function definition, and then reduce is as we go into match, ite or let expressions, using the
+`withRewrittenMotive` function.
+
+This gives us great control over the reduction, for example to move `let` expressions to the context
+simultaneously.
+
+The combinators passed to `withRewrittenMotive` are forgiving, so when `unfolding := false`, or when
+something goes wrong, one still gets a useful induction principle, just maybe with the function
+not fully simplified.
+-/
+
+namespace Lean.Tactic.FunInd
+
+open Lean Elab Meta
+
+def lambdaTelescope1 {n} [MonadControlT MetaM n] [MonadError n] [MonadNameGenerator n] [Monad n] {α} (e : Expr) (k : FVarId → Expr → n α) : n α := do
+  lambdaBoundedTelescope e 1 fun xs body => do
+    unless xs.size == 1 do
+      throwError "lambdaTelescope1: expected lambda, got {e}"
+    k xs[0]!.fvarId! body
+
+/-- There are multiple variants of this function around in the code base, maybe unify at some point. -/
+private def elimTypeAnnotations (type : Expr) : CoreM Expr := do
+  Core.transform type fun e =>
+    if e.isOptParam || e.isAutoParam then
+      return .visit e.appFn!.appArg!
+    else if e.isOutParam || e.isSemiOutParam then
+      return .visit e.appArg!
+    else
+      return .continue
+
+/--
+A monad to help collecting inductive hypothesis.
+
+In `foldAndCollect` it's a writer monad (with variants of the `local` combinator),
+and in `buildInductionBody` it is more of a reader monad, with inductive hypotheses
+being passed down (hence the `ask` and `branch` combinator).
+-/
+abbrev M := StateT (Array Expr) MetaM
+
+namespace M
+
+variable {α : Type}
+
+def run (act : M α) : MetaM (α × Array Expr) := StateT.run act #[]
+def eval (act : M α) : MetaM α := do return (← run act).1
+def exec (act : M α) : MetaM (Array Expr) := do return (← run act).2
+
+def tell (x : Expr) : M Unit := fun xs => pure ((), xs.push x)
+
+def localM (f : Array Expr → MetaM (Array Expr)) (act : M α) : M α := fun xs => do
+  let n := xs.size
+  let (b, xs') ← act xs
+  pure (b, xs'[*...n] ++ (← f xs'[n...*]))
+
+def localMapM (f : Expr → MetaM Expr) (act : M α) : M α :=
+  localM (·.mapM f) act
+
+def ask : M (Array Expr) := get
+
+def branch (act : M α) : M α :=
+  localM (fun _ => pure #[]) act
+
+end M
+
+/--
+The `foldAndCollect` function performs two operations together:
+
+ * it fold recursive calls: applications (and projectsions) of `oldIH` in `e` correspond to
+   recursive calls, so this function rewrites that back to recursive calls
+ * it collects induction hypotheses: after replacing `oldIH` with `newIH`, applications thereof
+   are valuable as induction hypotheses for the cases.
+
+For well-founded recursion (unary, non-mutual by construction) the terms are rather simple: they
+are `oldIH arg proof`, and can be rewritten to `f arg` resp. `newIH arg proof`. But for
+structural recursion this can be a more complicted mix of function applications (due to reflexive
+data types or extra function arguments) and `PProd` projections (due to the below construction and
+mutual function packing), and the main function argument isn't even present.
+
+To avoid having to think about this, we apply a nice trick:
+
+We compositionally replace `oldIH` with `newIH`. This likely changes the result type, so when
+re-assembling we have to be supple (mainly around `PProd.fst`/`PProd.snd`). As we re-assemble
+the term we check if it has type `motive xs..`. If it has, then know we have just found and
+rewritten a recursive call, and this type nicely provides us the arguments `xs`. So at this point
+we store the rewritten expression as a new induction hypothesis (using `M.tell`) and rewrite to
+`f xs..`, which now again has the same type as the original term, and the further re-assembly should
+work. Half this logic is in the `isRecCall` parameter.
+
+If this process fails we’ll get weird type errors (caught later on). We'll see if we need to
+improve the errors, for example by passing down a flag whether we expect the same type (and no
+occurrences of `newIH`), or whether we are in “supple mode”, and catch it earlier if the rewriting
+fails.
+-/
+partial def foldAndCollect (oldIH newIH : FVarId) (isRecCall : Expr → Option Expr) (e : Expr) : M Expr := do
+  unless e.containsFVar oldIH do
+    return e
+  withTraceNode `Meta.FunInd (pure m!"{exceptEmoji ·} foldAndCollect ({mkFVar oldIH} → {mkFVar newIH})::{indentExpr e}") do
+
+  let e' ← id do
+    if let some matcherApp ← matchMatcherApp? e (alsoCasesOn := true) then
+      if matcherApp.remaining.size == 1 && matcherApp.remaining[0]!.isFVarOf oldIH then
+        -- We do different things to the matcher when folding recursive calls and when
+        -- collecting inductive hypotheses. Therefore we do it separately,
+        -- dropping to `MetaM` in between, and using `M.eval`/`M.exec` as appropriate
+        -- We could try to do it in one pass by breaking up the `matcherApp.transform`
+        -- abstraction.
+
+        -- To collect the IHs, we collect them in each branch, and combine
+        -- them to a type-leve match
+        let ihMatcherApp' ← liftM <| matcherApp.transform
+          (onParams := fun e => M.eval <| foldAndCollect oldIH newIH isRecCall e)
+          (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 overridden with a type that’s itself a match
+            -- statement and the inferred alt types
+            let dummyGoal := mkConst ``True []
+            mkArrow eTypeAbst dummyGoal)
+          (onAlt := fun _altIdx altType alt => do
+            lambdaTelescope1 alt fun oldIH' alt => do
+              forallBoundedTelescope altType (some 1) fun newIH' _goal' => do
+                let #[newIH'] := newIH' | unreachable!
+                let altIHs ← M.exec <| foldAndCollect oldIH' newIH'.fvarId! isRecCall alt
+                let altIH ← PProdN.mk 0 altIHs
+                mkLambdaFVars #[newIH'] altIH)
+          (onRemaining := fun _ => pure #[mkFVar newIH])
+        let ihMatcherApp'' ← ihMatcherApp'.inferMatchType
+        M.tell ihMatcherApp''.toExpr
+
+        -- When folding the calls we don't want to remove the extra arg to the matcher
+        -- that was introduced in the translation
+        let matcherApp' ← liftM <| matcherApp.transform
+          (onParams := fun e => M.eval <| foldAndCollect oldIH newIH isRecCall e)
+          (onMotive := fun _motiveArgs motiveBody => do
+            let some (_extra, body) := motiveBody.arrow? | throwError "motive not an arrow"
+            M.eval (foldAndCollect oldIH newIH isRecCall body))
+          (onAlt := fun _altIdx altType alt => do
+            lambdaTelescope1 alt fun oldIH' alt => do
+            -- We don't have suitable newIH around here, but we don't care since
+            -- we just want to fold calls. So lets create a fake one.
+            -- (We cannot use oldIH as that would run into the sanity checks that we could
+            -- replace all of them)
+            withLocalDeclD `fakeNewIH (← inferType (mkFVar oldIH')) fun fakeNewIH =>
+              M.eval (foldAndCollect oldIH' fakeNewIH.fvarId! isRecCall 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. We need to look through theorems here!
+      if let some e' ← withTransparency .all do unfoldDefinition? e then
+        return ← foldAndCollect oldIH newIH isRecCall e'
+      else
+        throwError "foldAndCollect: cannot reduce application of {e.getAppFn} in:{indentExpr e} "
+
+    match e with
+    | .app e1 e2 =>
+      pure <|.app (← foldAndCollect oldIH newIH isRecCall e1) (← foldAndCollect oldIH newIH isRecCall e2)
+
+    | .lam n t body bi =>
+      let t' ← foldAndCollect oldIH newIH isRecCall t
+      withLocalDecl n bi t' fun x => do
+        M.localMapM (mkLambdaFVars (usedOnly := true) #[x] ·) do
+          let body' ← foldAndCollect oldIH newIH isRecCall (body.instantiate1 x)
+          mkLambdaFVars #[x] body'
+
+    | .forallE n t body bi =>
+      let t' ← foldAndCollect oldIH newIH isRecCall t
+      withLocalDecl n bi t' fun x => do
+        M.localMapM (mkLambdaFVars (usedOnly := true) #[x] ·) do
+          let body' ← foldAndCollect oldIH newIH isRecCall (body.instantiate1 x)
+          mkForallFVars #[x] body'
+
+    | .letE n t v b nondep =>
+      let t' ← foldAndCollect oldIH newIH isRecCall t
+      let v' ← foldAndCollect oldIH newIH isRecCall v
+      withLetDecl n t' v' (nondep := nondep) fun x => do
+        M.localMapM (mkLetFVars (usedLetOnly := true) (generalizeNondepLet := false) #[x] ·) do
+          let b' ← foldAndCollect oldIH newIH isRecCall (b.instantiate1 x)
+          mkLetFVars (generalizeNondepLet := false) #[x] b'
+
+    | .mdata m b =>
+      pure <| .mdata m (← foldAndCollect oldIH newIH isRecCall b)
+
+    -- These projections can be type changing (to And), so re-infer their type arguments
+    | .proj ``PProd 0 e => mkPProdFstM (← foldAndCollect oldIH newIH isRecCall e)
+    | .proj ``PProd 1 e => mkPProdSndM (← foldAndCollect oldIH newIH isRecCall e)
+
+    | .proj t i e =>
+      pure <| .proj t i (← foldAndCollect oldIH newIH isRecCall e)
+
+    | .sort .. | .lit .. | .const .. | .mvar .. | .bvar .. =>
+      unreachable! -- cannot contain free variables, so early exit above kicks in
+
+    | .fvar fvar =>
+      assert! fvar == oldIH
+      pure <| mkFVar newIH
+
+    -- Now see if the type of the expression we are building is a motive application.
+    -- If it is we want to replace it with the corresponding function application,
+    -- and remember the expression as a IH to be used in an inductive case.
+
+  if e'.containsFVar oldIH then
+    throwError "Failed to eliminate {mkFVar oldIH} from:{indentExpr e'}"
+
+  let eType ← whnf (← inferType e')
+  if let .some call := isRecCall eType then
+    M.tell (← mkExpectedTypeHint e' eType)
+    return call
+
+  return e'
+
+-- 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 (.mkSimple s!"ih{i+1}") (← inferType v) v
+  return mvarid
+
+/--
+Goal cleanup:
+Substitutes equations (with `substVar`) to remove superfluous variables, and clears unused
+let bindings.
+
+Substitutes from the outside in so that the inner-bound variable name wins, but does a first pass
+looking only at variables with names with macro scope, so that preferably they disappear.
+
+Careful to only touch the context after the motives (given by the index) as the motive could depend
+on anything before, and `substVar` would happily drop equations about these fixed parameters.
+-/
+partial def cleanupAfter (mvarId : MVarId) (index : Nat) : MetaM MVarId := do
+  let mvarId ← go mvarId index true
+  let mvarId ← go mvarId index false
+  return mvarId
+where
+  go (mvarId : MVarId) (index : Nat) (firstPass : Bool) : MetaM MVarId := do
+    if let some mvarId ← cleanupAfter? mvarId index firstPass then
+      go mvarId index firstPass
+    else
+      return mvarId
+
+  allHeqToEq (mvarId : MVarId) (index : Nat) : MetaM MVarId :=
+    mvarId.withContext do
+      let mut mvarId := mvarId
+      for localDecl in (← getLCtx) do
+        if localDecl.index > index then
+          let (_, mvarId') ← heqToEq mvarId localDecl.fvarId
+          mvarId := mvarId'
+      return mvarId
+
+  cleanupAfter? (mvarId : MVarId) (index : Nat) (firstPass : Bool)  : MetaM (Option MVarId) := do
+    mvarId.withContext do
+      for localDecl in (← getLCtx) do
+        if localDecl.index > index && (!firstPass || localDecl.userName.hasMacroScopes) then
+          if localDecl.isLet then
+            if ← Meta.isProp localDecl.type then
+              if let some mvarId' ← observing? <| mvarId.clearValue localDecl.fvarId then
+                return some mvarId'
+              else
+                continue
+            if let some mvarId' ← observing? <| mvarId.clear localDecl.fvarId then
+              return some mvarId'
+          if let some mvarId' ← substVar? mvarId localDecl.fvarId then
+            -- After substituting, some HEq might turn into Eqs, and we want to be able to substitute
+            -- them as well
+            let mvarId' ← allHeqToEq mvarId' index
+            return some mvarId'
+      return none
+
+
+/--
+Second helper monad collecting the cases as mvars
+-/
+abbrev M2 α := StateT (Array MVarId) M α
+
+def M2.run {α} (act : M2 α) : MetaM (α × Array MVarId) :=
+  M.eval (StateT.run (s := #[]) act)
+
+def M2.branch {α} (act : M2 α) : M2 α :=
+  controlAt M fun runInBase => M.branch (runInBase act)
+
+
+/-- Base case of `buildInductionBody`: Construct a case for the final induction hypthesis.  -/
+def buildInductionCase (oldIH newIH : FVarId) (isRecCall : Expr → Option Expr) (toErase toClear : Array FVarId)
+    (goal : Expr)  (e : Expr) : M2 Expr := do
+  withTraceNode `Meta.FunInd (pure m!"{exceptEmoji ·} buildInductionCase:{indentExpr e}") do
+  let _e' ← foldAndCollect oldIH newIH isRecCall e
+  let IHs : Array Expr ← M.ask
+  let IHs ← deduplicateIHs IHs
+
+  withErasedFVars toErase do
+    let mvar ← mkFreshExprSyntheticOpaqueMVar goal (tag := `hyp)
+    let mvarId := mvar.mvarId!
+    let mvarId ← assertIHs IHs mvarId
+    trace[Meta.FunInd] "Goal before cleanup:{mvarId}"
+    let (mvarId, _) ← mvarId.tryClearMany' toClear
+    modify (·.push 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 discriminants 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
+
+/--
+Inverse of `maskArray`:
+```
+zipMaskedArray mask (maskArray (mask.map not) xs) (maskArray mask xs) == xs
+```
+-/
+def zipMaskedArray {α} (mask : Array Bool) (xs ys : Array α) : Array α := Id.run do
+  let mut i := 0
+  let mut j := 0
+  let mut zs := #[]
+  for b in mask do
+    if b then
+      if h : j < ys.size then
+        zs := zs.push ys[j]
+        j := j + 1
+      else
+        panic! "zipMaskedArray: not enough elements in ys"
+    else
+      if h : i < xs.size then
+        zs := zs.push xs[i]
+        i := i + 1
+      else
+        panic! "zipMaskedArray: not enough elements in xs"
+  return zs
+
+
+/--
+Applies `rw` to `goal`, passes the rewritten `goal'` to `k` (which should return an expression of
+type `goal'`), and wraps that using the proof from `rw`.
+-/
+def withRewrittenMotive (goal : Expr) (rw : Expr → MetaM Simp.Result) (k : Expr → M2 Expr) : M2 Expr := do
+  let r ← rw goal
+  let e ← k r.expr
+  r.mkEqMPR e
+
+def inLastArg (rw : Expr → MetaM Simp.Result) (goal : Expr) : MetaM Simp.Result := do
+  match goal with
+  | .app goalFn arg =>
+    let r ← rw arg
+    Simp.mkCongrArg goalFn r
+  | _ =>
+    return { expr := goal }
+
+/--
+If `goal` is of the form `motive a b e`, applies `rw` to `e`, passes the simplified
+`goal'` to `k` (which should return an expression of type `goal'`), and rewrites that term
+accordingly.
+-/
+def withRewrittenMotiveArg (goal : Expr) (rw : Expr → MetaM Simp.Result) (k : Expr → M2 Expr) : M2 Expr := do
+  withRewrittenMotive goal (inLastArg rw) k
+
+/--
+Use to write inside the packed motives used for mutual structural recursion.
+-/
+partial def inProdLambdaLastArg (rw : Expr → MetaM Simp.Result) (goal : Expr) : MetaM Simp.Result := do
+  match_expr goal with
+  | PProd.mk _ _ goal1 goal2 =>
+    let r1 ← inProdLambdaLastArg rw goal1
+    let r2 ← inProdLambdaLastArg rw goal2
+    let f := goal.appFn!.appFn!
+    Simp.mkCongr (← Simp.mkCongrArg f r1) r2
+  | _ =>
+    lambdaTelescope goal fun xs goal => do
+      let r ← inLastArg rw goal
+      r.addLambdas xs
+
+def rwIfWith (hc : Expr) (e : Expr) : MetaM Simp.Result := do
+  match_expr e with
+  | ite@ite α c h t f =>
+    let us := ite.constLevels!
+    if (← isDefEq c (← inferType hc)) then
+      return {
+        expr := t
+        proof? := (mkAppN (mkConst ``if_pos us) #[c, h, hc, α, t, f])
+      }
+    if (← isDefEq (mkNot c) (← inferType hc)) then
+      return {
+        expr := f
+        proof? := (mkAppN (mkConst ``if_neg us) #[c, h, hc, α, t, f])
+      }
+    return { expr := e}
+  | dite@dite α c h t f =>
+    let us := dite.constLevels!
+    if (← isDefEq c (← inferType hc)) then
+      return {
+        expr := t.beta #[hc]
+        proof? := (mkAppN (mkConst ``dif_pos us) #[c, h, hc, α, t, f])
+      }
+    if (← isDefEq (mkNot c) (← inferType hc)) then
+      return {
+        expr := f.beta #[hc]
+        proof? := (mkAppN (mkConst ``dif_neg us) #[c, h, hc, α, t, f])
+      }
+    return { expr := e }
+  | cond@cond α c t f =>
+    let us := cond.constLevels!
+    if (← isDefEq (← inferType hc) (← mkEq c (mkConst ``Bool.true))) then
+      return {
+        expr := t
+        proof? := (mkAppN (mkConst ``Bool.cond_pos us) #[α, c, t, f, hc])
+      }
+    if (← isDefEq (← inferType hc) (← mkEq c (mkConst ``Bool.false))) then
+      return {
+        expr := f
+        proof? := (mkAppN (mkConst ``Bool.cond_neg us) #[α, c, t, f, hc])
+      }
+    return { expr := e }
+  | _ =>
+    return { expr := e }
+
+def rwLetWith (h : Expr) (e : Expr) : MetaM Simp.Result := do
+  if e.isLet then
+    if (← isDefEq e.letValue! h) then
+      return { expr := e.letBody!.instantiate1 h }
+  return { expr := e }
+
+def rwMData (e : Expr) : MetaM Simp.Result := do
+  return { expr := e.consumeMData }
+
+def rwFun (names : Array Name) (e : Expr) : MetaM Simp.Result := do
+  e.withApp fun f xs => do
+    if let some name := names.find? f.isConstOf then
+      let some unfoldThm ← getUnfoldEqnFor? name (nonRec := true)
+        | return { expr := e }
+      let h := mkAppN (mkConst unfoldThm f.constLevels!) xs
+      let some (_, _, rhs) := (← inferType h).eq?
+        | throwError "Not an equality: {h}"
+      return { expr := rhs, proof? := h }
+    else
+      return { expr := e }
+
+def rwMatcher (altIdx : Nat) (e : Expr) : MetaM Simp.Result := do
+  if e.isAppOf ``PSum.casesOn || e.isAppOf ``PSigma.casesOn then
+    let mut e := e
+    while true do
+      if let some e' ← reduceRecMatcher? e then
+          e := e'.headBeta
+      else
+        let e' := e.headBeta
+        if e != e' then
+          e := e'
+        else
+          break
+    return { expr := e }
+  else
+    unless (← isMatcherApp e) do
+      trace[Meta.FunInd] "Not a matcher application:{indentExpr e}"
+      return { expr := e }
+    let matcherDeclName := e.getAppFn.constName!
+    let eqns ← Match.genMatchCongrEqns matcherDeclName
+    unless altIdx < eqns.size do
+      trace[Meta.FunInd] "When trying to reduce arm {altIdx}, only {eqns.size} equations for {.ofConstName matcherDeclName}"
+      return { expr := e }
+    let eqnThm := eqns[altIdx]!
+    try
+      withTraceNode `Meta.FunInd (pure m!"{exceptEmoji ·} rewriting with {.ofConstName eqnThm} in{indentExpr e}") do
+      let eqProof := mkAppN (mkConst eqnThm e.getAppFn.constLevels!) e.getAppArgs
+      let (hyps, _, eqType) ← forallMetaTelescope (← inferType eqProof)
+      trace[Meta.FunInd] "eqProof has type{indentExpr eqType}"
+      let proof := mkAppN eqProof hyps
+      let hyps := hyps.map (·.mvarId!)
+      let (isHeq, lhs, rhs) ← do
+        if let some (_, lhs, _, rhs) := eqType.heq? then pure (true, lhs, rhs) else
+        if let some (_, lhs, rhs) := eqType.eq? then pure (false, lhs, rhs) else
+        throwError m!"Type of {.ofConstName eqnThm} is not an equality"
+      if !(← isDefEq e lhs) then
+        throwError m!"Left-hand side {lhs} of {.ofConstName eqnThm} does not apply to {e}"
+      /-
+      Here we instantiate the hypotheses of the congruence equation theorem
+      There are two sets of hypotheses to instantiate:
+      - `Eq` or `HEq` that relate the discriminants to the patterns
+        Solving these should instantiate the pattern variables.
+      - Overlap hypotheses (`isEqnThmHypothesis`)
+      With more book keeping we could maybe do this very precisely, knowing exactly
+      which facts provided by the splitter should go where, but it's tedious.
+      So for now let's use heuristics and try `assumption` and `rfl`.
+      -/
+      for h in hyps do
+        unless (← h.isAssigned) do
+          let hType ← h.getType
+          if Simp.isEqnThmHypothesis hType then
+            -- Using unrestricted h.substVars here does not work well; it could
+            -- even introduce a dependency on the `oldIH` we want to eliminate
+            h.assumption <|> throwError "Failed to discharge {h}"
+          else if hType.isEq then
+            h.assumption <|> h.refl <|> throwError m!"Failed to resolve {h}"
+          else if hType.isHEq then
+            h.assumption <|> h.hrefl <|> throwError m!"Failed to resolve {h}"
+      let unassignedHyps ← hyps.filterM fun h => return !(← h.isAssigned)
+      unless unassignedHyps.isEmpty do
+        throwError m!"Not all hypotheses of {.ofConstName eqnThm} could be discharged: {unassignedHyps}"
+      let rhs ← instantiateMVars rhs
+      let proof ← instantiateMVars proof
+      let proof ← if isHeq then
+          try mkEqOfHEq proof
+          catch e => throwError m!"Could not un-HEq {proof}:{indentD e.toMessageData} "
+        else
+          pure proof
+      return {
+        expr := rhs
+        proof? := proof
+      }
+    catch ex =>
+      trace[Meta.FunInd] "Failed to apply {.ofConstName eqnThm}:{indentD ex.toMessageData}"
+      return { expr := e }
+
+/--
+Builds an expression of type `goal` by replicating the expression `e` into its tail-call-positions,
+where it calls `buildInductionCase`. Collects the cases of the final induction hypothesis
+as `MVars` as it goes.
+-/
+partial def buildInductionBody (toErase toClear : Array FVarId) (goal : Expr)
+    (oldIH newIH : FVarId) (isRecCall : Expr → Option Expr) (e : Expr) : M2 Expr := do
+  withTraceNode `Meta.FunInd
+    (pure m!"{exceptEmoji ·} buildInductionBody: {oldIH.name} → {newIH.name}\ngoal: {goal}:{indentExpr e}") do
+
+  -- if-then-else cause case split:
+  match_expr e with
+  | ite _α c h t f =>
+    let c' ← foldAndCollect oldIH newIH isRecCall c
+    let h' ← foldAndCollect oldIH newIH isRecCall h
+    let t' ← withLocalDecl `h .default c' fun h => M2.branch do
+      let t' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall t
+      mkLambdaFVars #[h] t'
+    let f' ← withLocalDecl `h .default (mkNot c') fun h => M2.branch do
+      let f' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall f
+      mkLambdaFVars #[h] f'
+    let u ← getLevel goal
+    return mkApp5 (mkConst ``dite [u]) goal c' h' t' f'
+  | dite _α c h t f =>
+    let c' ← foldAndCollect oldIH newIH isRecCall c
+    let h' ← foldAndCollect oldIH newIH isRecCall h
+    let t' ← withLocalDecl `h .default c' fun h => M2.branch do
+      let t ← instantiateLambda t #[h]
+      let t' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall t
+      mkLambdaFVars #[h] t'
+    let f' ← withLocalDecl `h .default (mkNot c') fun h => M2.branch do
+      let f ← instantiateLambda f #[h]
+      let f' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall f
+      mkLambdaFVars #[h] f'
+    let u ← getLevel goal
+    return mkApp5 (mkConst ``dite [u]) goal c' h' t' f'
+  | cond _α c t f =>
+    let c' ← foldAndCollect oldIH newIH isRecCall c
+    let t' ← withLocalDecl `h .default (← mkEq c' (mkConst ``Bool.true)) fun h => M2.branch do
+      let t' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall t
+      mkLambdaFVars #[h] t'
+    let f' ← withLocalDecl `h .default (← mkEq c' (mkConst ``Bool.false)) fun h => M2.branch do
+      let t' ← withRewrittenMotiveArg goal (rwIfWith h) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall f
+      mkLambdaFVars #[h] t'
+    let u ← getLevel goal
+    return mkApp4 (mkConst ``Bool.dcond [u]) goal c' t' f'
+  | _ =>
+
+
+  -- Check for unreachable cases. We look for the kind of expressions that `by contradiction`
+  -- produces
+  match_expr e with
+  | False.elim _ h => do
+    return ← mkFalseElim goal h
+  | absurd _ _ h₁ h₂ => do
+    return ← mkAbsurd goal h₁ h₂
+  | _ => pure ()
+  if e.isApp && e.getAppFn.isConst && isNoConfusion (← getEnv) e.getAppFn.constName! then
+    let arity := (← inferType e.getAppFn).getNumHeadForalls -- crucially not reducing the noConfusionType in the type
+    let h := e.getArg! (arity - 1)
+    let hType ← inferType h
+    -- The following duplicates a bit of code from the contradiction tactic, maybe worth extracting
+    -- into a common helper at some point
+    if let some (_, lhs, rhs) ← matchEq? hType then
+      if let some lhsCtor ← matchConstructorApp? lhs then
+      if let some rhsCtor ← matchConstructorApp? rhs then
+      if lhsCtor.name != rhsCtor.name then
+        return (← mkNoConfusion goal h)
+
+  -- we look in to `PProd.mk`, as it occurs in the mutual structural recursion construction
+  match_expr goal with
+  | And goal₁ goal₂ => match_expr e with
+    | PProd.mk _α _β e₁ e₂ =>
+      let e₁' ← buildInductionBody toErase toClear goal₁ oldIH newIH isRecCall e₁
+      let e₂' ← buildInductionBody toErase toClear goal₂ oldIH newIH isRecCall e₂
+      return mkApp4 (.const ``And.intro []) goal₁ goal₂ e₁' e₂'
+    | _ =>
+      throwError "Goal is PProd, but expression is:{indentExpr e}"
+  | True =>
+    return .const ``True.intro []
+  | _ =>
+
+  -- match and casesOn application cause case splitting
+  if let some matcherApp ← matchMatcherApp? e (alsoCasesOn := true) then
+    -- 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 := true)
+        (onParams := (foldAndCollect oldIH newIH isRecCall ·))
+        (onMotive := fun xs _body => pure (absMotiveBody.beta (maskArray mask xs)))
+        (onAlt := fun altIdx expAltType alt => M2.branch do
+          lambdaTelescope1 alt fun oldIH' alt => do
+            forallBoundedTelescope expAltType (some 1) fun newIH' goal' => do
+              let #[newIH'] := newIH' | unreachable!
+              let toErase' := toErase ++ #[oldIH', newIH'.fvarId!]
+              let toClear' := toClear ++ matcherApp.discrs.filterMap (·.fvarId?)
+              let alt' ← withRewrittenMotiveArg goal' (rwMatcher altIdx) fun goal'' => do
+                -- logInfo m!"rwMatcher after {matcherApp.matcherName} on{indentExpr goal'}\nyields{indentExpr goal''}"
+                buildInductionBody toErase' toClear' goal'' oldIH' newIH'.fvarId! isRecCall 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 := true)
+        (onParams := (foldAndCollect oldIH newIH isRecCall ·))
+        (onMotive := fun xs _body => pure (absMotiveBody.beta (maskArray mask xs)))
+        (onAlt := fun altIdx expAltType alt => M2.branch do
+          withRewrittenMotiveArg expAltType (rwMatcher altIdx) fun expAltType' =>
+            buildInductionBody toErase toClear expAltType' oldIH newIH isRecCall alt)
+      return matcherApp'.toExpr
+
+  -- we look through mdata
+  if e.isMData then
+    let b ← withRewrittenMotiveArg goal (rwMData) fun goal' =>
+      buildInductionBody toErase toClear goal' oldIH newIH isRecCall e.mdataExpr!
+    return e.updateMData! b
+
+  if let .letE n t v b _ := e then
+    let t' ← foldAndCollect oldIH newIH isRecCall t
+    let v' ← foldAndCollect oldIH newIH isRecCall v
+    return ← withLetDecl n t' v' fun x => M2.branch do
+      let b' ← withRewrittenMotiveArg goal (rwLetWith x) fun goal' =>
+        buildInductionBody toErase toClear goal' oldIH newIH isRecCall (b.instantiate1 x)
+      mkLetFVars #[x] b'
+
+  -- Special case for traversing the PProd’ed bodies in our encoding of structural mutual recursion
+  if let .lam n t b bi := e then
+    if goal.isForall then
+      let t' ← foldAndCollect oldIH newIH isRecCall t
+      return ← withLocalDecl n bi t' fun x => M2.branch do
+        let goal' ← instantiateForall goal #[x]
+        let b' ← buildInductionBody toErase toClear goal' oldIH newIH isRecCall (b.instantiate1 x)
+        mkLambdaFVars #[x] b'
+
+  liftM <| buildInductionCase oldIH newIH isRecCall toErase toClear goal e
+
+/--
+Given an expression `e` with metavariables `mvars`
+* performs more cleanup:
+  * removes unused let-expressions after index `index`
+  * tries to substitute variables after index `index`
+* lifts them to the current context by reverting all local declarations after index `index`
+* introducing a local variable for each of the meta variable
+* assigning that local variable to the mvar
+* and finally lambda-abstracting over these new local variables.
+
+This operation only works if the metavariables are independent from each other.
+
+The resulting meta variable assignment is no longer valid (mentions out-of-scope
+variables), so after this operations, terms that still mention these meta variables must not
+be used anymore.
+
+We are not using `mkLambdaFVars` on mvars directly, nor `abstractMVars`, as these at the moment
+do not handle delayed assignments correctly.
+-/
+def abstractIndependentMVars (mvars : Array MVarId) (index : Nat) (e : Expr) : MetaM Expr := do
+  trace[Meta.FunInd] "abstractIndependentMVars, to revert after {index}, original mvars: {mvars}"
+  let mvars ← mvars.mapM fun mvar => do
+    let mvar ← cleanupAfter mvar index
+    mvar.withContext do
+      let fvarIds := (← getLCtx).foldl (init := #[]) (start := index+1) fun fvarIds decl => fvarIds.push decl.fvarId
+      let (_, mvar) ← mvar.revert fvarIds
+      pure mvar
+  trace[Meta.FunInd] "abstractIndependentMVars, reverted mvars: {mvars}"
+  let names := Array.ofFn (n := mvars.size) fun ⟨i,_⟩ => .mkSimple s!"case{i+1}"
+  let types ← mvars.mapM MVarId.getType
+  Meta.withLocalDeclsDND (names.zip types) fun xs => do
+      for mvar in mvars, x in xs do
+        mvar.assign x
+      mkLambdaFVars xs (← instantiateMVars e)
+
+/--
+Given a unary definition `foo` defined via `WellFounded.fixF`, derive a suitable induction principle
+`foo.induct` for it. See module doc for details.
+ -/
+def deriveUnaryInduction (unfolding : Bool) (name : Name) : MetaM Name := do
+  let inductName := getFunInductName (unfolding := unfolding) name
+  realizeConst name inductName (doRealize inductName)
+  return inductName
+where doRealize (inductName : Name) := do
+  let info ← getConstInfoDefn name
+  let varNames ← forallTelescope info.type fun xs _ => xs.mapM (·.fvarId!.getUserName)
+
+  -- Uses of WellFounded.fix can be partially applied. Here we eta-expand the body
+  -- to make sure that `target` indeed the last parameter
+  let e := info.value
+  let e ← lambdaTelescope e fun params body => do
+    if body.isAppOfArity ``WellFounded.fix 5 then
+      forallBoundedTelescope (← inferType body) (some 1) fun xs _ => do
+        unless xs.size = 1 do
+          throwError "functional induction: Failed to eta-expand{indentExpr e}"
+        mkLambdaFVars (params ++ xs) (mkAppN body xs)
+    else
+      pure e
+  let (e', paramMask) ← lambdaTelescope e fun params funBody => MatcherApp.withUserNames params varNames do
+    match_expr funBody with
+    | fix@WellFounded.fix α _motive rel wf body target =>
+      unless params.back! == target do
+        throwError "functional induction: expected the target as last parameter{indentExpr e}"
+      let fixedParamPerms := params.pop
+      let motiveType ←
+        if unfolding then
+          withLocalDeclD `r (← instantiateForall info.type params) fun r =>
+            mkForallFVars #[target, r] (.sort 0)
+        else
+          mkForallFVars #[target] (.sort 0)
+      withLocalDeclD `motive motiveType fun motive => do
+        let fn := mkAppN (← mkConstWithLevelParams name) fixedParamPerms
+        let isRecCall : Expr → Option Expr := fun e =>
+          e.withApp fun f xs =>
+            if f.isFVarOf motive.fvarId! && xs.size > 0 then
+            mkApp fn xs[0]!
+          else
+            none
+
+        let motiveArg ←
+          if unfolding then
+            let motiveArg := mkApp2 motive target (mkAppN (← mkConstWithLevelParams name) params)
+            mkLambdaFVars #[target] motiveArg
+          else
+            pure motive
+        let e' := .const ``WellFounded.fix [fix.constLevels![0]!, levelZero]
+        let e' := mkApp4 e' α motiveArg rel wf
+        check e'
+        let (body', mvars) ← M2.run do
+          forallTelescope (← inferType e').bindingDomain! fun xs goal => do
+            if xs.size ≠ 2 then
+              throwError "expected recursor argument to take 2 parameters, got {xs}" else
+            let targets : Array Expr := xs[*...1]
+            let genIH := xs[1]!
+            let extraParams := xs[2...*]
+            -- open body with the same arg
+            let body ← instantiateLambda body targets
+            lambdaTelescope1 body fun oldIH body => do
+              let body ← instantiateLambda body extraParams
+              let body' ← withRewrittenMotiveArg goal (rwFun #[name]) fun goal => do
+                buildInductionBody #[oldIH, genIH.fvarId!] #[] goal oldIH genIH.fvarId! isRecCall body
+              if body'.containsFVar oldIH then
+                throwError m!"Did not fully eliminate {mkFVar oldIH} from induction principle body:{indentExpr body}"
+              mkLambdaFVars (targets.push genIH) (← mkLambdaFVars extraParams body')
+        let e' := mkApp2 e' body' target
+        let e' ← mkLambdaFVars #[target] e'
+        let e' ← abstractIndependentMVars mvars (← motive.fvarId!.getDecl).index e'
+        let e' ← mkLambdaFVars #[motive] e'
+
+        -- We used to pass (usedOnly := false) below in the hope that the types of the
+        -- induction principle match the type of the function better.
+        -- But this leads to avoidable parameters that make functional induction strictly less
+        -- useful (e.g. when the unused parameter mentions bound variables in the users' goal)
+        let (paramMask, e') ← mkLambdaFVarsMasked fixedParamPerms e'
+        let e' ← instantiateMVars e'
+        return (e', paramMask)
+    | _ =>
+      if funBody.isAppOf ``WellFounded.fix then
+        throwError "Function {name} defined via WellFounded.fix with unexpected arity {funBody.getAppNumArgs}:{indentExpr funBody}"
+      else
+        throwError "Function {name} not defined via WellFounded.fix:{indentExpr funBody}"
+
+  unless (← isTypeCorrect e') do
+    logError m!"failed to derive a type-correct induction principle:{indentExpr e'}"
+    check e'
+
+  let eTyp ← inferType e'
+  let eTyp ← elimTypeAnnotations eTyp
+  let eTyp ← letToHave eTyp
+  -- logInfo m!"eTyp: {eTyp}"
+  let levelParams := (collectLevelParams {} eTyp).params
+  -- Prune unused level parameters, preserving the original order
+  let funUs := info.levelParams.toArray
+  let usMask := funUs.map (levelParams.contains ·)
+  let us := maskArray usMask funUs |>.toList
+
+  addDecl <| Declaration.thmDecl
+    { name := inductName, levelParams := us, type := eTyp, value := e' }
+
+  setFunIndInfo {
+      funName := name
+      funIndName := inductName
+      levelMask := usMask
+      params := paramMask.map (cond · .param .dropped) ++ #[.target]
+  }
+
+/--
+Given a realizer for `foo.mutual_induct`, defines `foo.induct`, `bar.induct` etc.
+Used for well-founded and structural recursion.
+-/
+def projectMutualInduct (unfolding : Bool) (names : Array Name) (mutualInduct : MetaM Name) (finalizeFirstInd : MetaM Unit) : MetaM Unit := do
+  for name in names, idx in [:names.size] do
+    let inductName := getFunInductName (unfolding := unfolding) name
+    realizeConst names[0]! inductName do
+      let ci ← getConstInfo (← mutualInduct)
+      let levelParams := ci.levelParams
+      let value ← forallTelescope ci.type fun xs _body => do
+        let value := .const ci.name (levelParams.map mkLevelParam)
+        let value := mkAppN value xs
+        let value ← PProdN.projM names.size idx value
+        mkLambdaFVars xs value
+      let type ← inferType value
+      let type ← letToHave type
+      addDecl <| Declaration.thmDecl { name := inductName, levelParams, type, value }
+
+      if idx == 0 then finalizeFirstInd
+
+/--
+For a (non-mutual!) definition of `name`, uses the `FunIndInfo` associated with the `unaryInduct` and
+derives the one for the n-ary function.
+-/
+def setNaryFunIndInfo (unfolding : Bool) (fixedParamPerms : FixedParamPerms) (funName : Name) (unaryInduct : Name) : MetaM Unit := do
+  assert!  fixedParamPerms.perms.size = 1 -- only non-mutual for now
+  let funIndName := getFunInductName (unfolding := unfolding) funName
+  unless funIndName = unaryInduct do
+    let some unaryFunIndInfo ← getFunIndInfoForInduct? unaryInduct
+      | throwError "Expected {unaryInduct} to have FunIndInfo"
+    let fixedParamPerm := fixedParamPerms.perms[0]!
+    let mut params := #[]
+    let mut j := 0
+    for h : i in [:fixedParamPerm.size] do
+      if fixedParamPerm[i].isSome then
+        assert! j + 1 < unaryFunIndInfo.params.size
+        params := params.push unaryFunIndInfo.params[j]!
+        j := j + 1
+      else
+        params := params.push .target
+    assert! j + 1 = unaryFunIndInfo.params.size
+
+    setFunIndInfo { unaryFunIndInfo with funName, funIndName, params }
+
+/--
+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.
+
+(The implementation is repetitive and verbose, and should be cleaned up when convenient.)
+-/
+def cleanPackedArgs (eqnInfo : WF.EqnInfo) (value : Expr) : MetaM Expr := do
+  let type ← inferType value
+  let cleanType ← Meta.transform type (skipConstInApp := true) (post := fun e => do
+    -- Need to beta-reduce first
+    let e' := e.headBeta
+    if e' != e then
+      return .visit e'
+
+    e.withApp fun f args => do
+    -- Look for PSigma redexes
+    if f.isConstOf ``PSigma.casesOn then
+      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 PSigma projection
+    if f.isConstOf ``PSigma.fst then
+      if h : 3 ≤ args.size then
+        let scrut := args[2]
+        let extra := args[3...*]
+        if scrut.isAppOfArity ``PSigma.mk 4 then
+          let #[_, _, x, _y] := scrut.getAppArgs | unreachable!
+          let e' := x.beta extra
+          return .visit e'
+    if f.isConstOf ``PSigma.snd then
+      if h : 3 ≤ args.size then
+        let scrut := args[2]
+        let extra := args[3...*]
+        if scrut.isAppOfArity ``PSigma.mk 4 then
+          let #[_, _, _x, y] := scrut.getAppArgs | unreachable!
+          let e' := y.beta extra
+          return .visit e'
+    if f.isProj then
+      let scrut := e.projExpr!
+      if scrut.isAppOfArity ``PSigma.mk 4 then
+        let #[_, _, x, y] := scrut.getAppArgs | unreachable!
+        let e' := (if e.projIdx! = 0 then x else y).beta args
+        return .visit e'
+
+    -- Look for PSum redexes
+    if f.isConstOf ``PSum.casesOn then
+      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 f.isConstOf eqnInfo.declNameNonRec then
+      if h : args.size ≥ eqnInfo.fixedParamPerms.numFixed + 1 then
+        let xs := args[*...eqnInfo.fixedParamPerms.numFixed]
+        let packedArg := args[eqnInfo.fixedParamPerms.numFixed]
+        let extraArgs := args[eqnInfo.fixedParamPerms.numFixed<...*]
+        let some (funIdx, ys) := eqnInfo.argsPacker.unpack packedArg
+          | throwError "Unexpected packedArg:{indentExpr packedArg}"
+        let args' := eqnInfo.fixedParamPerms.perms[funIdx]!.buildArgs xs ys
+        let e' := .const eqnInfo.declNames[funIdx]! e.getAppFn.constLevels!
+        let e' := mkAppN e' args'
+        let e' := mkAppN e' extraArgs
+        return .continue e'
+
+    return .continue e)
+  mkExpectedTypeHint value cleanType
+
+/--
+Retrieves `foo._unary.induct`, where the motive is a `PSigma`/`PSum` type, and
+unpacks it into a n-ary and (possibly) joint induction principle.
+-/
+def unpackMutualInduction (unfolding : Bool) (eqnInfo : WF.EqnInfo) : MetaM Name := do
+  let inductName := if eqnInfo.declNames.size > 1 then
+    getMutualInductName (unfolding := unfolding) eqnInfo.declNames[0]!
+  else
+    -- If there is no mutual recursion, we generate the `foo.induct` directly.
+    getFunInductName (unfolding := unfolding) eqnInfo.declNames[0]!
+  realizeConst eqnInfo.declNames[0]! inductName (doRealize inductName)
+  return inductName
+where doRealize inductName := do
+  let unaryInductName ← deriveUnaryInduction (unfolding := unfolding) eqnInfo.declNameNonRec
+  prependError m!"Cannot unpack functional cases principle {.ofConstName unaryInductName} (please report this issue)" do
+  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 = (if unfolding then 2 else 1) && targets[0]!.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
+    eqnInfo.argsPacker.curryParam value type fun motives value type =>
+      -- Bring the rest into scope
+      forallTelescope type fun xs _concl => do
+        let alts := xs.pop
+        let value := mkAppN value alts
+        let value ← eqnInfo.argsPacker.curry 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!"final term is type incorrect:{indentExpr value}"
+    check value
+  let type ← inferType value
+  let type ← elimOptParam type
+  let type ← letToHave type
+
+  addDecl <| Declaration.thmDecl
+    { name := inductName, levelParams := ci.levelParams, type, value }
+
+  if eqnInfo.argsPacker.numFuncs = 1 then
+    setNaryFunIndInfo (unfolding := unfolding) eqnInfo.fixedParamPerms eqnInfo.declNames[0]! unaryInductName
+
+def withLetDecls {α} (name : Name) (ts : Array Expr) (es : Array Expr) (k : Array Expr → MetaM α) : MetaM α := do
+  assert! es.size = ts.size
+  go 0 #[]
+where
+  go (i : Nat) (acc : Array Expr) := do
+    if h : i < es.size then
+      let n := if es.size = 1 then name else name.appendIndexAfter (i + 1)
+      withLetDecl n ts[i]! es[i] fun x => go (i+1) (acc.push x)
+    else
+      k acc
+
+/--
+Given a recursive definition `foo` defined via structural recursion, derive `foo.mutual_induct`,
+if needed, and `foo.induct` for all functions in the group.
+See module doc for details.
+ -/
+def deriveInductionStructural (unfolding : Bool) (names : Array Name) (fixedParamPerms : FixedParamPerms) : MetaM Name := do
+  let inductName :=
+    if names.size = 1 then
+      getFunInductName (unfolding := unfolding) names[0]!
+    else
+      getMutualInductName (unfolding := unfolding) names[0]!
+  realizeConst names[0]! inductName (doRealize inductName)
+  return inductName
+where doRealize inductName := do
+  let infos ← names.mapM getConstInfoDefn
+  assert! infos.size > 0
+  -- First open up the fixed parameters everywhere
+  let (e', paramMask, motiveArities) ← fixedParamPerms.perms[0]!.forallTelescope infos[0]!.type fun xs => do
+    -- Now look at the body of an arbitrary of the functions (they are essentially the same
+    -- up to the final projections)
+    let body ← fixedParamPerms.perms[0]!.instantiateLambda infos[0]!.value xs
+    let body := body.eta
+
+    lambdaTelescope body fun ys body => do
+      -- The body is of the form (brecOn … ).2.2.1 extra1 extra2 etc; ignore the
+      -- projection here
+      let f' := body.getAppFn
+      let body' := PProdN.stripProjs f'
+      let f := body'.getAppFn
+      let args := body'.getAppArgs ++ body.getAppArgs
+
+      let body := PProdN.stripProjs body
+      let .const brecOnName us := f |
+        throwError "{infos[0]!.name}: unexpected body:{indentExpr infos[0]!.value}\ninstantiated to{indentExpr body}"
+      unless isBRecOnRecursor (← getEnv) brecOnName do
+        throwError "{infos[0]!.name}: expected .brecOn application, found:{indentExpr body}"
+
+      let .str indName _ := brecOnName | unreachable!
+      let indInfo ← getConstInfoInduct indName
+
+      -- we have a `.brecOn` application, so now figure out the length of the fixed prefix
+      -- we can use the recInfo for `.rec`, since `.brecOn` has a similar structure
+      let recInfo ← getConstInfoRec (mkRecName indName)
+      if args.size < recInfo.numParams + recInfo.numMotives + recInfo.numIndices + 1 + recInfo.numMotives then
+        throwError "insufficient arguments to .brecOn:{indentExpr body}"
+      let brecOnArgs    : Array Expr := args[*...recInfo.numParams]
+      let _brecOnMotives : Array Expr := args[recInfo.numParams...(recInfo.numParams + recInfo.numMotives)]
+      let brecOnTargets : Array Expr := args[(recInfo.numParams + recInfo.numMotives)...
+        (recInfo.numParams + recInfo.numMotives + recInfo.numIndices + 1)]
+      let brecOnMinors  : Array Expr := args[(recInfo.numParams + recInfo.numMotives + recInfo.numIndices + 1)...
+        (recInfo.numParams + recInfo.numMotives + recInfo.numIndices + 1 + recInfo.numMotives)]
+      let brecOnExtras  : Array Expr := args[(recInfo.numParams + recInfo.numMotives + recInfo.numIndices + 1 +
+        recInfo.numMotives)...*]
+      unless brecOnTargets.all (·.isFVar) do
+        throwError "the indices and major argument of the brecOn application are not variables:{indentExpr body}"
+      unless brecOnExtras.all (·.isFVar) do
+        throwError "the extra arguments to the brecOn application are not variables:{indentExpr body}"
+      let _ :: indLevels := us | throwError "Too few universe parameters in .brecOn application:{indentExpr body}"
+
+      let group : Structural.IndGroupInst := { Structural.IndGroupInfo.ofInductiveVal indInfo with
+        levels := indLevels, params := brecOnArgs }
+
+      -- We also need to know the number of indices of each type former, including the auxiliary
+      -- type formers that do not have IndInfo. We can read it off the motives types of the recursor.
+      let numTypeFormerTargetss ← do
+        let aux := mkAppN (.const recInfo.name (0 :: group.levels)) group.params
+        let motives ← inferArgumentTypesN recInfo.numMotives aux
+        motives.mapM fun motive =>
+          forallTelescopeReducing motive fun xs _ => pure xs.size
+
+      -- Recreate the recArgInfos. Maybe more robust and simpler to store relevant parts in the EqnInfos?
+      let recArgInfos ← infos.mapIdxM fun funIdx info => do
+        let some eqnInfo := Structural.eqnInfoExt.find? (← getEnv) info.name | throwError "{info.name} missing eqnInfo"
+        let value ← fixedParamPerms.perms[funIdx]!.instantiateLambda info.value xs
+        let recArgInfo' ← lambdaTelescope value fun ys _ =>
+          let args := fixedParamPerms.perms[funIdx]!.buildArgs xs ys
+          Structural.getRecArgInfo info.name fixedParamPerms.perms[funIdx]! args eqnInfo.recArgPos
+        let #[recArgInfo] ← Structural.argsInGroup group xs value #[recArgInfo']
+          | throwError "Structural.argsInGroup did not return a recArgInfo"
+        pure recArgInfo
+
+      let positions : Structural.Positions := .groupAndSort (·.indIdx) recArgInfos (Array.range indInfo.numTypeFormers)
+
+      -- Below we'll need the types of the motive arguments (brecOn argument order)
+      let brecMotiveTypes ← inferArgumentTypesN recInfo.numMotives (group.brecOn 0 0)
+      trace[Meta.FunInd] m!"brecMotiveTypes: {brecMotiveTypes}"
+      assert! brecMotiveTypes.size = positions.size
+
+      -- Remove the varying parameters from the environment
+      withErasedFVars (ys.map (·.fvarId!)) do
+        -- The brecOnArgs, brecOnMotives and brecOnMinor should still be valid in this
+        -- context, and are the parts relevant for every function in the mutual group
+
+        -- Calculate the types of the induction motives (natural argument order) for each function
+        let motiveTypes ← infos.mapIdxM fun funIdx info => do
+          let funType ← fixedParamPerms.perms[funIdx]!.instantiateForall info.type xs
+          forallBoundedTelescope funType (some (fixedParamPerms.perms[funIdx]!.size - xs.size)) fun ys rType => do
+            if unfolding then
+              withLocalDeclD `r rType fun r =>
+                mkForallFVars (ys.push r) (.sort 0)
+            else
+              mkForallFVars ys (.sort 0)
+        trace[Meta.FunInd] m!"motiveTypes: {motiveTypes}"
+        let motiveArities ← motiveTypes.mapM fun motiveType =>
+          forallTelescope motiveType fun ys _ => pure ys.size
+        let motiveNames := Array.ofFn (n := infos.size) fun ⟨i, _⟩ =>
+          if infos.size = 1 then .mkSimple "motive" else .mkSimple s!"motive_{i+1}"
+
+        withLocalDeclsDND (motiveNames.zip motiveTypes) fun motives => do
+
+          -- Prepare the `isRecCall` that recognizes recursive calls
+          let isRecCall : Expr → Option Expr := fun e => do
+            if let .some funIdx := motives.idxOf? e.getAppFn then
+              if e.getAppNumArgs = motiveArities[funIdx]! then
+                let info := infos[funIdx]!
+                let args := if unfolding then e.getAppArgs.pop else e.getAppArgs
+                let args := fixedParamPerms.perms[funIdx]!.buildArgs xs args
+                return mkAppN (.const info.name (info.levelParams.map mkLevelParam)) args
+            .none
+
+          -- Motives with parameters reordered, to put indices and major first,
+          -- and (when unfolding) the result field instantiated
+          let mut brecMotives := #[]
+          for motive in motives, recArgInfo in recArgInfos, info in infos, funIdx in [:motives.size] do
+            let brecMotive ← forallTelescope (← inferType motive) fun ys _ => do
+              let ys := if unfolding then ys.pop else ys
+              let (indicesMajor, rest) := recArgInfo.pickIndicesMajor ys
+              let motiveArg := mkAppN motive ys
+              let motiveArg ← if unfolding then
+                let args := fixedParamPerms.perms[funIdx]!.buildArgs xs ys
+                let fnCall := mkAppN (.const info.name (info.levelParams.map mkLevelParam)) args
+                pure <| mkApp motiveArg fnCall
+              else
+                pure motiveArg
+              mkLambdaFVars indicesMajor (← mkForallFVars rest motiveArg)
+            brecMotives := brecMotives.push brecMotive
+
+          -- We need to pack these motives according to the `positions` assignment.
+          let packedMotives ← positions.mapMwith PProdN.packLambdas brecMotiveTypes brecMotives
+          trace[Meta.FunInd] m!"packedMotives: {packedMotives}"
+
+          -- Now we can calculate the expected types of the minor arguments
+          let minorTypes ← inferArgumentTypesN recInfo.numMotives <|
+            mkAppN (group.brecOn 0 0) (packedMotives ++ brecOnTargets)
+          trace[Meta.FunInd] m!"minorTypes: {minorTypes}"
+          -- So that we can transform them
+          let (minors', mvars) ← M2.run do
+            let mut minors' := #[]
+            for brecOnMinor in brecOnMinors, goal in minorTypes, numTargets in numTypeFormerTargetss do
+              let minor' ← forallTelescope goal fun xs goal => do
+                unless xs.size ≥ numTargets do
+                  throwError ".brecOn argument has too few parameters, expected at least {numTargets}: {xs}"
+                let targets : Array Expr := xs[*...numTargets]
+                let genIH := xs[numTargets]!
+                let extraParams := xs[numTargets<...*]
+                -- open body with the same arg
+                let body ← instantiateLambda brecOnMinor targets
+                lambdaTelescope1 body fun oldIH body => do
+                  trace[Meta.FunInd] "replacing {Expr.fvar oldIH} with {genIH}"
+                  let body ← instantiateLambda body extraParams
+                  let body' ←
+                    withRewrittenMotive goal (inProdLambdaLastArg (rwFun names)) fun goal' =>
+                      buildInductionBody #[oldIH, genIH.fvarId!] #[] goal' oldIH genIH.fvarId! isRecCall body
+                  if body'.containsFVar oldIH then
+                    throwError m!"Did not fully eliminate {mkFVar oldIH} from induction principle body:{indentExpr body}"
+                  mkLambdaFVars (targets.push genIH) (← mkLambdaFVars extraParams body')
+              minors' := minors'.push minor'
+            pure minors'
+          trace[Meta.FunInd] "processed minors: {minors'}"
+
+          -- Now assemble the mutual_induct theorem
+          -- Let-bind the transformed minors to avoid code duplication of possibly very large
+          -- terms when we have mutual induction.
+          let e' ← withLetDecls `minor minorTypes minors' fun minors' => do
+            let mut brecOnApps := #[]
+            for info in infos, recArgInfo in recArgInfos, idx in [:infos.size] do
+              -- Take care to pick the `ys` from the type, to get the variable names expected
+              -- by the user, but use the value arity
+              let arity ← lambdaTelescope (← fixedParamPerms.perms[idx]!.instantiateLambda info.value xs) fun ys _ => pure ys.size
+              let e ← forallBoundedTelescope (← fixedParamPerms.perms[idx]!.instantiateForall info.type xs) arity fun ys _ => do
+                let (indicesMajor, rest) := recArgInfo.pickIndicesMajor ys
+                -- Find where in the function packing we are (TODO: abstract out)
+                let some indIdx := positions.findIdx? (·.contains idx) | panic! "invalid positions"
+                let some pos := positions.find? (·.contains idx) | panic! "invalid positions"
+                let some packIdx := pos.findIdx? (· == idx) | panic! "invalid positions"
+                let e := group.brecOn 0 indIdx
+                let e := mkAppN e packedMotives
+                let e := mkAppN e indicesMajor
+                let e := mkAppN e minors'
+                let e ← PProdN.projM pos.size packIdx e
+                let e := mkAppN e rest
+                let e ← mkLambdaFVars ys e
+                trace[Meta.FunInd] "assembled call for {info.name}: {e}"
+                pure e
+              brecOnApps := brecOnApps.push e
+            mkLetFVars minors' (← PProdN.mk 0 brecOnApps)
+          let e' ← abstractIndependentMVars mvars (← motives.back!.fvarId!.getDecl).index e'
+          let e' ← mkLambdaFVars motives e'
+
+          -- We used to pass (usedOnly := false) below in the hope that the types of the
+          -- induction principle match the type of the function better.
+          -- But this leads to avoidable parameters that make functional induction strictly less
+          -- useful (e.g. when the unused parameter mentions bound variables in the users' goal)
+          let (paramMask, e') ← mkLambdaFVarsMasked xs e'
+          let e' ← instantiateMVars e'
+          trace[Meta.FunInd] "complete body of mutual induction principle:{indentExpr e'}"
+          pure (e', paramMask, motiveArities)
+
+  unless (← isTypeCorrect e') do
+    logError m!"constructed induction principle is not type correct:{indentExpr e'}"
+    check e'
+
+  let eTyp ← inferType e'
+  let eTyp ← elimTypeAnnotations eTyp
+  let eTyp ← letToHave eTyp
+  -- logInfo m!"eTyp: {eTyp}"
+  let levelParams := (collectLevelParams {} eTyp).params
+  -- Prune unused level parameters, preserving the original order
+  let funUs := infos[0]!.levelParams.toArray
+  let usMask := funUs.map (levelParams.contains ·)
+  let us := maskArray usMask funUs |>.toList
+
+  addDecl <| Declaration.thmDecl
+    { name := inductName, levelParams := us, type := eTyp, value := e' }
+
+  if names.size = 1 then
+    let mut params := #[]
+    for h : i in [:fixedParamPerms.perms[0]!.size] do
+      if let some idx := fixedParamPerms.perms[0]![i] then
+        if paramMask[idx]! then
+          params := params.push .param
+        else
+          params := params.push .dropped
+      else
+        params := params.push .target
+
+    setFunIndInfo {
+      funName := names[0]!
+      funIndName := inductName, levelMask := usMask, params := params
+    }
+
+
+/--
+Given an expression `fun x y z => body`, returns a bit mask of the functinon's arity length
+that has `true` whenever that parameter of the function appears as a scrutinee of a `match` in
+tail position. These are the parameters that are likely useful as targets of the motive
+of the functional cases theorem. All others become parameters or may be dropped.
+
+-/
+partial def refinedArguments (e : Expr) : MetaM (Array Bool) := do
+  let (_, mask) ← lambdaTelescope e fun xs body =>
+    let mask0 := Array.replicate xs.size false
+    go xs body |>.run mask0
+  let mut mask := mask
+  let revDeps ← getParamRevDeps e
+  assert! revDeps.size = mask.size
+  for i in [:mask.size] do
+    if mask[i]! then
+      for j in revDeps[i]! do
+          mask := mask.set! j true
+  pure mask
+where
+  -- NB: we process open terms here.
+  go (xs : Array Expr) (e : Expr) : StateT (Array Bool) MetaM Unit := do
+    let e := e.consumeMData
+
+    if e.isLambda then
+      -- Not strictly tail position, but simplifies the code below and should not make
+      -- a difference in practice
+      go xs e.bindingBody!
+    else if e.isLet then
+      go xs e.letBody!
+    else
+      e.withApp fun f args => do
+        if f.isConst then
+          if let some matchInfo ← getMatcherInfo? f.constName! then
+            for scrut in args[matchInfo.getFirstDiscrPos...matchInfo.getFirstAltPos] do
+              if let some i := xs.idxOf? scrut then
+                modify (·.set! i true)
+            for alt in args[matchInfo.getFirstAltPos...matchInfo.arity] do
+              go xs alt
+        if f.isConstOf ``ite || f.isConstOf ``dite then
+          for arg in args[3...5] do
+            go xs arg
+        if f.isConstOf ``cond then
+          for arg in args[2...4] do
+            go xs arg
+
+/--
+For non-recursive (and recursive functions) functions we derive a “functional case splitting theorem”. This is very similar
+than the functional induction theorem. It splits the goal, but does not give you inductive hyptheses.
+
+For these, it is not really clear which parameters should be “targets” of the motive, as there is
+no “fixed prefix” to guide this decision. All? None? Some?
+
+We tried none, but that did not work well. Right now it's all parameters, and it seems to work well.
+In the future, we might post-process the theorem (or run the code below iteratively) and remove
+targets that are unchanged in each case, so simplify applying the lemma when these “fixed” parameters
+are not variables, to avoid having to generalize them.
+-/
+def deriveCases (unfolding : Bool) (name : Name) : MetaM Unit := do
+  let casesName := getFunCasesName (unfolding := unfolding) name
+  realizeConst name casesName do
+  prependError m!"Cannot derive functional cases principle (please report this issue)" do
+    let info ← getConstInfo name
+    let some unfoldEqnName ← getUnfoldEqnFor? (nonRec := true) name
+      | throwError "'{name}' does not have an unfold theorem nor a value"
+    let value ← do
+      let eqInfo ← getConstInfo unfoldEqnName
+      forallTelescope eqInfo.type fun xs body => do
+        let some (_, _, rhs) := body.eq?
+          | throwError "Type of {unfoldEqnName} not an equality: {body}"
+        mkLambdaFVars xs rhs
+    let targetMask ← refinedArguments value
+    trace[Meta.FunInd] "targetMask: {targetMask}"
+
+    let (paramsMask, e') ← lambdaTelescope value fun xs _ => do
+      let params := maskArray (targetMask.map not) xs
+      let targets := maskArray targetMask xs
+      let motiveType ←
+        if unfolding then
+          withLocalDeclD `r (← instantiateForall info.type xs) fun r =>
+            mkForallFVars (targets.push r) (.sort 0)
+        else
+          mkForallFVars targets (.sort 0)
+      -- Remove targets from local context, we want to bring them into scope after the motive
+      -- so that the index passed to `abstractIndependentMVars` works.
+      withErasedFVars (targets.map (·.fvarId!)) do
+        withLocalDeclD `motive motiveType fun motive => do
+          -- Bring targets freshly into scope again
+          forallBoundedTelescope motiveType targets.size fun targets _ => do
+            let (e', mvars) ← M2.run do
+              let args := zipMaskedArray targetMask params targets
+              let body := value.beta args
+              let goal := mkAppN motive targets
+              let goal ← if unfolding then
+                pure <| mkApp goal (mkAppN (← mkConstWithLevelParams name) args)
+              else
+                pure goal
+              withRewrittenMotiveArg goal (rwFun #[name]) fun goal => do
+                -- We bring an unused FVars into scope to pass as `oldIH` and `newIH`. These do not appear anywhere
+                -- so `buildInductionBody` should just do the right thing
+                withLocalDeclD `fakeIH (mkConst ``Unit) fun fakeIH =>
+                  let isRecCall := fun _ => none
+                  buildInductionBody #[fakeIH.fvarId!] #[] goal fakeIH.fvarId! fakeIH.fvarId! isRecCall body
+            let e' ← mkLambdaFVars targets e'
+            let e' ← abstractIndependentMVars mvars (← motive.fvarId!.getDecl).index e'
+            let e' ← mkLambdaFVars #[motive] e'
+            mkLambdaFVarsMasked params e'
+
+    mapError (f := (m!"constructed functional cases principle is not type correct:{indentExpr e'}\n{indentD ·}")) do
+      check e'
+
+    let eTyp ← inferType e'
+    let eTyp ← elimTypeAnnotations eTyp
+    let eTyp ← letToHave eTyp
+    -- logInfo m!"eTyp: {eTyp}"
+    let levelParams := (collectLevelParams {} eTyp).params
+    -- Prune unused level parameters, preserving the original order
+    let funUs := info.levelParams.toArray
+    let usMask := funUs.map (levelParams.contains ·)
+    let us := maskArray usMask funUs |>.toList
+
+    addDecl <| Declaration.thmDecl
+      { name := casesName, levelParams := us, type := eTyp, value := e' }
+
+    -- Calculate paramsKind from targetMask (length = arity) and paramsMask (length = params)
+    let mut paramKinds := #[]
+    let mut j := 0
+    for isTarget in targetMask do
+      if isTarget then
+        paramKinds := paramKinds.push .target
+      else
+        assert! j < paramsMask.size
+        if paramsMask[j]! then
+          paramKinds := paramKinds.push .param
+        else
+          paramKinds := paramKinds.push .dropped
+        j := j + 1
+
+    setFunIndInfo {
+      funName := name
+      funIndName := casesName
+      levelMask := usMask
+      params := paramKinds
+    }
+
+/--
+Given a recursively defined function `foo`, derives `foo.induct`. See the module doc for details.
+-/
+def deriveInduction (unfolding : Bool) (name : Name) : MetaM Unit := do
+  prependError m!"Cannot derive functional induction principle (please report this issue)" do
+    if let some eqnInfo := WF.eqnInfoExt.find? (← getEnv) name then
+      let unaryInductName ← deriveUnaryInduction unfolding eqnInfo.declNameNonRec
+      if eqnInfo.declNames.size > 1 then
+        projectMutualInduct unfolding eqnInfo.declNames (unpackMutualInduction unfolding eqnInfo) do
+          -- We set the FunIndInfo on the first induction principle, which must happen inside its
+          -- realization.
+          if eqnInfo.argsPacker.numFuncs = 1 then
+            setNaryFunIndInfo (unfolding := unfolding) eqnInfo.fixedParamPerms eqnInfo.declNames[0]! unaryInductName
+      else
+        -- (in this case, `unpackMutualInduction` already does `setNaryFunIndInfo`)
+        let _ ← unpackMutualInduction unfolding eqnInfo
+    else if let some eqnInfo := Structural.eqnInfoExt.find? (← getEnv) name then
+      if eqnInfo.declNames.size > 1 then
+        projectMutualInduct unfolding eqnInfo.declNames (deriveInductionStructural unfolding eqnInfo.declNames eqnInfo.fixedParamPerms) (pure ())
+      else
+        let _ ← deriveInductionStructural unfolding eqnInfo.declNames eqnInfo.fixedParamPerms
+    else
+      throwError "constant '{name}' is not structurally or well-founded recursive"
+
+def isFunInductName (env : Environment) (name : Name) : Bool := Id.run do
+  let .str p s := name | return false
+  match s with
+  | "induct"
+  | "induct_unfolding" =>
+    unless env.isSafeDefinition p do return false
+    if let some eqnInfo := WF.eqnInfoExt.find? env p then
+      return true
+    if (Structural.eqnInfoExt.find? env p).isSome then return true
+    return false
+  | "mutual_induct"
+  | "mutual_induct_unfolding" =>
+    unless env.isSafeDefinition p do return false
+    if let some eqnInfo := WF.eqnInfoExt.find? env p then
+      if h : eqnInfo.declNames.size > 1 then
+        return eqnInfo.declNames[0] = p
+    if let some eqnInfo := Structural.eqnInfoExt.find? env p then
+      if h : eqnInfo.declNames.size > 1 then
+        return eqnInfo.declNames[0] = p
+    return false
+  | _ => return false
+
+
+def isFunCasesName (env : Environment) (name : Name) : Bool := Id.run do
+  let .str p s := name | return false
+  match s with
+  | "fun_cases"
+  | "fun_cases_unfolding" =>
+    unless env.isSafeDefinition p do return false
+    return true
+  | _ => return false
+
+builtin_initialize
+  registerReservedNamePredicate isFunInductName
+  registerReservedNamePredicate isFunCasesName
+
+  registerReservedNameAction fun name => do
+    if isFunInductName (← getEnv) name then
+      let .str p s := name | return false
+      unless (← getEnv).isSafeDefinition p do return false
+      let unfolding := s.endsWith "_unfolding"
+      MetaM.run' <| deriveInduction unfolding p
+      return true
+    if isFunCasesName (← getEnv) name then
+      let .str p s := name | return false
+      unless (← getEnv).isSafeDefinition p do return false
+      let unfolding := s == "fun_cases_unfolding"
+      MetaM.run' <| deriveCases unfolding p
+      return true
+    return false
+
+end Lean.Tactic.FunInd
+
+builtin_initialize
+   Lean.registerTraceClass `Meta.FunInd

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/FunIndCollect.lean

@@ -0,0 +1,115 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+
+prelude
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.FunIndInfo
+
+/-!
+Support for collecting function calls that could be used for `fun_induction` or `fun_cases`.
+Used by `fun_induction foo`, and the `Calls` structure is also used by `try?`.
+-/
+
+namespace Lean.Meta.FunInd
+
+structure Call where
+  /- The full function call -/
+  expr : Expr
+  /- Used to avoid adding calls that differ only in dropped arguments -/
+  relevantArgs : Expr
+  deriving Hashable, BEq
+
+structure SeenCalls where
+  /-- the full calls -/
+  calls : Array Expr
+  /-- only function name and relevant arguments -/
+  seen : Std.HashSet (Name × Array Expr)
+
+instance : EmptyCollection SeenCalls where
+  emptyCollection := ⟨#[], {}⟩
+
+def SeenCalls.isEmpty  (sc : SeenCalls) : Bool :=
+  sc.calls.isEmpty
+
+def SeenCalls.push (e : Expr) (funIndInfo : FunIndInfo) (args : Array Expr) (calls : SeenCalls) :
+    MetaM SeenCalls := do
+  if funIndInfo.params.size != args.size then return calls
+  let mut keys := #[]
+  for arg in args, kind in funIndInfo.params do
+    if kind matches .target then
+      if !arg.isFVar then return calls
+    unless kind matches .dropped do
+      keys := keys.push arg
+  let key := (funIndInfo.funName, keys)
+  if calls.seen.contains key then return calls
+  return { calls := calls.calls.push e, seen := calls.seen.insert key }
+
+/--
+Which functions have exactly one candidate application. Used by `try?` to determine whether
+we can use `fun_induction foo` or need `fun_induction foo x y z`.
+-/
+def SeenCalls.uniques (calls : SeenCalls) : NameSet := Id.run do
+  let mut seen : NameSet := {}
+  let mut seenTwice : NameSet := {}
+  for (n, _) in calls.seen do
+    unless seenTwice.contains n do
+      if seen.contains n then
+        seenTwice := seenTwice.insert n
+      else
+        seen := seen.insert n
+  return seen.filter (! seenTwice.contains ·)
+
+namespace Collector
+
+abbrev M := ReaderT FunIndInfo <| StateRefT SeenCalls MetaM
+
+def saveFunInd (e : Expr) (funIndInfo : FunIndInfo) (args : Array Expr) : M Unit := do
+  set (← (← get).push e funIndInfo args)
+
+def visitApp (e : Expr) (funIndInfo : FunIndInfo) (args : Array Expr) : M Unit := do
+  saveFunInd e funIndInfo args
+
+unsafe abbrev Cache := PtrSet Expr
+
+unsafe def visit (e : Expr) : StateRefT Cache M Unit := do
+  unless (← get).contains e do
+    modify fun s => s.insert e
+    match e with
+      | .const _ _        => pure ()
+      | .forallE _ d b _  => visit d; visit b
+      | .lam _ d b _      => visit d; visit b
+      | .mdata _ b        => visit b
+      | .letE _ t v b _   => visit t; visit v; visit b
+      | .app ..           => e.withApp fun f args => do
+        if let .const declName _ := f then
+          if declName = (← read).funName then
+            unless e.hasLooseBVars do -- TODO: We can allow them in `.dropped` arguments
+              visitApp e (← read) args
+        else
+          visit f
+        args.forM visit
+      | .proj _ _ b       => visit b
+      | _                 => return ()
+
+unsafe def main (needle : FunIndInfo) (mvarId : MVarId) : MetaM (Array Expr) := mvarId.withContext do
+  let (_, s) ← go |>.run mkPtrSet |>.run needle |>.run {}
+  return s.calls
+where
+  go : StateRefT Cache M Unit := do
+    for localDecl in (← getLCtx) do
+      unless localDecl.isAuxDecl do
+        if let some val := localDecl.value? then
+          visit val
+        else
+          visit localDecl.type
+    visit (← mvarId.getType)
+
+end Collector
+
+def collect (needle : FunIndInfo) (mvarId : MVarId) : MetaM (Array Expr) := do
+  unsafe Collector.main needle mvarId
+
+end Lean.Meta.FunInd

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/FunIndInfo.lean

@@ -0,0 +1,86 @@
+/-
+Copyright (c) 2025 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.ScopedEnvExtension
+import Lean.ReservedNameAction
+
+/-!
+This module defines the data structure and environment extension to remember how to map the
+function's arguments to the functional induction principle's arguments.
+Also used for functional cases.
+-/
+
+namespace Lean.Meta
+
+inductive FunIndParamKind where
+  | dropped
+  | param
+  | target
+deriving BEq, Repr, Inhabited
+
+/--
+A `FunIndInfo` indicates how a function's arguments map to the arguments of the functional induction
+(resp. cases) theorem.
+
+The size of `params` also indicates the arity of the function.
+-/
+structure FunIndInfo where
+  funName : Name
+  funIndName : Name
+  /--
+  `true` means that the corresponding level parameter of the function is also a level param
+  of the induction principle.
+  -/
+  levelMask : Array Bool
+  params : Array FunIndParamKind
+deriving Inhabited, Repr
+
+builtin_initialize funIndInfoExt : MapDeclarationExtension FunIndInfo ← mkMapDeclarationExtension
+
+def getFunInductName (declName : Name) (unfolding : Bool := false) : Name :=
+  if unfolding then
+    declName ++ `induct_unfolding
+  else
+    declName ++ `induct
+
+def getFunCasesName (declName : Name) (unfolding : Bool := false) : Name :=
+  if unfolding then
+    declName ++ `fun_cases_unfolding
+  else
+    declName ++ `fun_cases
+
+def getMutualInductName (declName : Name) (unfolding : Bool := false) : Name :=
+  if unfolding then
+    declName ++ `mutual_induct_unfolding
+  else
+    declName ++ `mutual_induct
+
+def getFunInduct? (unfolding : Bool) (cases : Bool) (declName : Name) : CoreM (Option Name) := do
+  let .defnInfo _ ← getConstInfo declName | return none
+  try
+    let thmName := if cases then
+      getFunCasesName (unfolding := unfolding) declName
+    else
+      getFunInductName (unfolding := unfolding) declName
+    let result ← realizeGlobalConstNoOverloadCore thmName
+    return some result
+  catch _ =>
+    return none
+
+def setFunIndInfo (funIndInfo : FunIndInfo) : CoreM Unit := do
+  assert! !(funIndInfoExt.contains (← getEnv) funIndInfo.funIndName)
+  modifyEnv fun env => funIndInfoExt.insert env funIndInfo.funIndName funIndInfo
+
+def getFunIndInfoForInduct?  (inductName : Name) : CoreM (Option FunIndInfo) := do
+  return funIndInfoExt.find? (← getEnv) inductName
+
+def getFunIndInfo? (cases : Bool) (unfolding : Bool) (funName : Name) : CoreM (Option FunIndInfo) := do
+  let some inductName ← getFunInduct? (cases := cases) (unfolding := unfolding) funName | return none
+  getFunIndInfoForInduct? inductName
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Generalize.lean

@@ -0,0 +1,152 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.KAbstract
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Intro
+import Lean.Meta.Tactic.FVarSubst
+import Lean.Meta.Tactic.Revert
+
+namespace Lean.Meta
+
+/-- The `generalize` tactic takes arguments of the form `h : e = x` -/
+structure GeneralizeArg where
+  expr   : Expr
+  xName? : Option Name := none
+  hName? : Option Name := none
+  deriving Inhabited
+
+/--
+Telescopic `generalize` tactic. It can simultaneously generalize many terms.
+It uses `kabstract` to occurrences of the terms that need to be generalized.
+-/
+private partial def generalizeCore (mvarId : MVarId) (args : Array GeneralizeArg)
+    (transparency : TransparencyMode) : MetaM (Array FVarId × MVarId) :=
+  mvarId.withContext do
+    mvarId.checkNotAssigned `generalize
+    let tag ← mvarId.getTag
+    let target ← instantiateMVars (← mvarId.getType)
+    let rec go (i : Nat) : MetaM Expr := do
+      if _h : i < args.size then
+        let arg := args[i]
+        let e ← instantiateMVars arg.expr
+        let eType ← instantiateMVars (← inferType e)
+        let type ← go (i+1)
+        let xName ← if let some xName := arg.xName? then pure xName else mkFreshUserName `x
+        return Lean.mkForall xName BinderInfo.default eType
+          (← withTransparency transparency <| kabstract type e)
+      else
+        return target
+    let targetNew ← go 0
+    unless (← isTypeCorrect targetNew) do
+      throwTacticEx `generalize mvarId m!"result is not type correct{indentExpr targetNew}"
+    let es := args.map (·.expr)
+    if !args.any fun arg => arg.hName?.isSome then
+      let mvarNew ← mkFreshExprSyntheticOpaqueMVar targetNew tag
+      mvarId.assign (mkAppN mvarNew es)
+      mvarNew.mvarId!.introNP args.size
+    else
+      let (rfls, targetNew) ← forallBoundedTelescope targetNew args.size fun xs type => do
+        let rec go' (i : Nat) : MetaM (List Expr × Expr) := do
+          if _h : i < xs.size then
+            let arg := args[i]!
+            if let some hName := arg.hName? then
+              let xType ← inferType xs[i]
+              let e ← instantiateMVars arg.expr
+              let eType ← instantiateMVars (← inferType e)
+              let (hType, r) ← if (← isDefEq xType eType) then
+                pure (← mkEq e xs[i], ← mkEqRefl e)
+              else
+                pure (← mkHEq e xs[i], ← mkHEqRefl e)
+              let (rs, type) ← go' (i+1)
+              return (r :: rs, mkForall hName BinderInfo.default hType type)
+            else
+              go' (i+1)
+          else
+            return ([], type)
+        let (rfls, type) ← go' 0
+        return (rfls, ← mkForallFVars xs type)
+      let mvarNew ← mkFreshExprSyntheticOpaqueMVar targetNew tag
+      mvarId.assign (mkAppN (mkAppN mvarNew es) rfls.toArray)
+      mvarNew.mvarId!.introNP (args.size + rfls.length)
+
+/-
+Remark: we use `TransparencyMode.instances` as the default setting at `generalize`
+and `generalizeHyp` to avoid excessive resource usage.
+
+**Motivation:**
+The `kabstract e p` operation is widely used, for instance, in the `generalize` tactic.
+It operates by taking an expression `e` and a pattern (i.e., an expression containing metavariables)
+and employs keyed-matching to identify and abstract instances of `p` within `e`.
+For example, if `e` is `a + (2 * (b + c))` and `p` is `2 * ?m`, the resultant expression
+would be `a + #0`, where `#0` represents a loose bound variable.
+
+This matching process is not merely syntactic; it also considers reduction. It's impractical
+to attempt matching each sub-term with `p`; therefore, only sub-terms sharing the same "root"
+symbol are evaluated. For instance, with the pattern `2 * ?m`, only sub-terms with the
+root `*` are considered. Matching is executed using the definitionally equality test
+(i.e., `isDefEq`).
+
+The `generalize` tactic employs `kabstract` and defaults to standard reducibility.
+Hence, the `isDefEq` operations invoked by `kabstract` can become highly resource-intensive
+and potentially trigger "max recursion depth reached" errors, as observed in issue #3524.
+This issue was isolated by @**Kim Morrison** with the following example:
+```
+example (a : Nat) : ((2 ^ 7) + a) - 2 ^ 7 = 0 := by
+  generalize 0 - 0 = x
+```
+In this scenario, `kabstract` triggers a "max recursion depth reached" error while
+testing whether `((2 ^ 7) + a) - 2 ^ 7` is definitionally equal to `0 - 0`.
+Note that the term `((2 ^ 7) + a) - 2 ^ 7` is not ground.
+We believe most users find the error message to be uninformative and unexpected.
+To fix this issue, we decided to use `TransparencyMode.instances` as the default setting.
+
+Kyle Miller has performed the following analysis on the potential impact of the
+changes on Mathlib (2024-03-02).
+
+There seem to be just 130 cases of generalize in Mathlib, and after looking through a
+good number of them, they seem to come in just two types:
+
+- Ones where it looks like reducible+instance transparency should work, where in
+  particular there is nothing obvious being reduced, and
+- Ones that don't make use of the `kabstract` feature at all (it's being used like a
+  `have` that introduces an equality for rewriting).
+
+That wasn't a systematic review of generalize though. It's possible changing the
+transparency settings would break things, but in my opinion it would be better
+if generalize weren't used for unfolding things.
+-/
+
+@[inherit_doc generalizeCore]
+def _root_.Lean.MVarId.generalize (mvarId : MVarId) (args : Array GeneralizeArg)
+    (transparency := TransparencyMode.instances) : MetaM (Array FVarId × MVarId) :=
+  generalizeCore mvarId args transparency
+
+/--
+Extension of `generalize` to support generalizing within specified hypotheses.
+The `hyps` array contains the list of hypotheses within which to look for occurrences
+of the generalizing expressions.
+-/
+def _root_.Lean.MVarId.generalizeHyp (mvarId : MVarId) (args : Array GeneralizeArg) (hyps : Array FVarId := #[])
+    (fvarSubst : FVarSubst := {}) (transparency := TransparencyMode.instances) : MetaM (FVarSubst × Array FVarId × MVarId) := do
+  if hyps.isEmpty then
+    -- trivial case
+    return (fvarSubst, ← mvarId.generalize args transparency)
+  let args ← args.mapM fun arg => return { arg with expr := ← instantiateMVars arg.expr }
+  let hyps ← hyps.filterM fun h => do
+    let type ← instantiateMVars (← h.getType)
+    args.anyM fun arg => return (← withTransparency transparency <| kabstract type arg.expr).hasLooseBVars
+  let (reverted, mvarId) ← mvarId.revert hyps true
+  let (newVars, mvarId) ← mvarId.generalize args transparency
+  let (reintros, mvarId) ← mvarId.introNP reverted.size
+  let fvarSubst := Id.run do
+    let mut subst : FVarSubst := fvarSubst
+    for h in reverted, reintro in reintros do
+      subst := subst.insert h (mkFVar reintro)
+    pure subst
+  return (fvarSubst, newVars, mvarId)
+
+end Lean.Meta

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind.lean

@@ -0,0 +1,89 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Attr
+import Lean.Meta.Tactic.Grind.RevertAll
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Util
+import Lean.Meta.Tactic.Grind.Cases
+import Lean.Meta.Tactic.Grind.Injection
+import Lean.Meta.Tactic.Grind.Core
+import Lean.Meta.Tactic.Grind.Canon
+import Lean.Meta.Tactic.Grind.MarkNestedProofs
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.Proof
+import Lean.Meta.Tactic.Grind.Propagate
+import Lean.Meta.Tactic.Grind.PP
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Ctor
+import Lean.Meta.Tactic.Grind.Parser
+import Lean.Meta.Tactic.Grind.EMatchTheorem
+import Lean.Meta.Tactic.Grind.EMatch
+import Lean.Meta.Tactic.Grind.Main
+import Lean.Meta.Tactic.Grind.CasesMatch
+import Lean.Meta.Tactic.Grind.Arith
+import Lean.Meta.Tactic.Grind.Ext
+import Lean.Meta.Tactic.Grind.MatchCond
+import Lean.Meta.Tactic.Grind.MatchDiscrOnly
+import Lean.Meta.Tactic.Grind.Diseq
+import Lean.Meta.Tactic.Grind.MBTC
+import Lean.Meta.Tactic.Grind.Lookahead
+import Lean.Meta.Tactic.Grind.LawfulEqCmp
+import Lean.Meta.Tactic.Grind.ReflCmp
+
+namespace Lean
+
+/-! Trace options for `grind` users -/
+builtin_initialize registerTraceClass `grind
+builtin_initialize registerTraceClass `grind.trace
+builtin_initialize registerTraceClass `grind.assert
+builtin_initialize registerTraceClass `grind.eqc
+builtin_initialize registerTraceClass `grind.internalize
+builtin_initialize registerTraceClass `grind.ematch
+builtin_initialize registerTraceClass `grind.ematch.pattern
+builtin_initialize registerTraceClass `grind.ematch.instance
+builtin_initialize registerTraceClass `grind.ematch.instance.assignment
+builtin_initialize registerTraceClass `grind.eqResolution
+builtin_initialize registerTraceClass `grind.issues
+builtin_initialize registerTraceClass `grind.simp
+builtin_initialize registerTraceClass `grind.split
+builtin_initialize registerTraceClass `grind.split.candidate
+builtin_initialize registerTraceClass `grind.split.resolved
+builtin_initialize registerTraceClass `grind.beta
+builtin_initialize registerTraceClass `grind.mbtc
+builtin_initialize registerTraceClass `grind.ext
+builtin_initialize registerTraceClass `grind.ext.candidate
+builtin_initialize registerTraceClass `grind.lookahead
+builtin_initialize registerTraceClass `grind.lookahead.add (inherited := true)
+builtin_initialize registerTraceClass `grind.lookahead.try (inherited := true)
+builtin_initialize registerTraceClass `grind.lookahead.assert (inherited := true)
+
+/-! Trace options for `grind` developers -/
+builtin_initialize registerTraceClass `grind.debug
+builtin_initialize registerTraceClass `grind.debug.proofs
+builtin_initialize registerTraceClass `grind.debug.congr
+builtin_initialize registerTraceClass `grind.debug.proof
+builtin_initialize registerTraceClass `grind.debug.proj
+builtin_initialize registerTraceClass `grind.debug.parent
+builtin_initialize registerTraceClass `grind.debug.final
+builtin_initialize registerTraceClass `grind.debug.forallPropagator
+builtin_initialize registerTraceClass `grind.debug.split
+builtin_initialize registerTraceClass `grind.debug.canon
+builtin_initialize registerTraceClass `grind.debug.ematch.activate
+builtin_initialize registerTraceClass `grind.debug.ematch.pattern
+builtin_initialize registerTraceClass `grind.debug.beta
+builtin_initialize registerTraceClass `grind.debug.internalize
+builtin_initialize registerTraceClass `grind.debug.matchCond
+builtin_initialize registerTraceClass `grind.debug.matchCond.lambda
+builtin_initialize registerTraceClass `grind.debug.matchCond.proveFalse
+builtin_initialize registerTraceClass `grind.debug.mbtc
+builtin_initialize registerTraceClass `grind.debug.ematch
+builtin_initialize registerTraceClass `grind.debug.proveEq
+builtin_initialize registerTraceClass `grind.debug.pushNewFact
+builtin_initialize registerTraceClass `grind.debug.appMap
+builtin_initialize registerTraceClass `grind.debug.ext
+
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/AlphaShareCommon.lean

@@ -0,0 +1,112 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.ExprPtr
+
+namespace Lean.Meta.Grind
+
+private def hashChild (e : Expr) : UInt64 :=
+  match e with
+  | .bvar .. | .mvar .. | .const .. | .fvar .. | .sort .. | .lit .. =>
+    hash e
+  | .app .. | .letE .. | .forallE .. | .lam .. | .mdata .. | .proj .. =>
+    hashPtrExpr e
+
+private def alphaHash (e : Expr) : UInt64 :=
+  match e with
+  | .bvar .. | .mvar .. | .const .. | .fvar .. | .sort .. | .lit .. =>
+    hash e
+  | .app f a => mixHash (hashChild f) (hashChild a)
+  | .letE _ _ v b _ => mixHash (hashChild v) (hashChild b)
+  | .forallE _ d b _ | .lam _ d b _ => mixHash (hashChild d) (hashChild b)
+  | .mdata _ b => mixHash 13 (hashChild b)
+  | .proj n i b => mixHash (mixHash (hash n) (hash i)) (hashChild b)
+
+private def alphaEq (e₁ e₂ : Expr) : Bool := Id.run do
+  match e₁ with
+  | .bvar .. | .mvar .. | .const .. | .fvar .. | .sort .. | .lit .. =>
+    e₁ == e₂
+  | .app f₁ a₁ =>
+    let .app f₂ a₂ := e₂ | false
+    isSameExpr f₁ f₂ && isSameExpr a₁ a₂
+  | .letE _ _ v₁ b₁ _ =>
+    let .letE _ _ v₂ b₂ _ := e₂ | false
+    isSameExpr v₁ v₂ && isSameExpr b₁ b₂
+  | .forallE _ d₁ b₁ _ =>
+    let .forallE _ d₂ b₂ _ := e₂ | false
+    isSameExpr d₁ d₂ && isSameExpr b₁ b₂
+  | .lam _ d₁ b₁ _ =>
+    let .lam _ d₂ b₂ _ := e₂ | false
+    isSameExpr d₁ d₂ && isSameExpr b₁ b₂
+  | .mdata d₁ b₁ =>
+    let .mdata d₂ b₂ := e₂ | false
+    return isSameExpr b₁ b₂ && d₁ == d₂
+  | .proj n₁ i₁ b₁ =>
+    let .proj n₂ i₂ b₂ := e₂ | false
+    n₁ == n₂ && i₁ == i₂ && isSameExpr b₁ b₂
+
+structure AlphaKey where
+  expr : Expr
+
+instance : Hashable AlphaKey where
+  hash k := alphaHash k.expr
+
+instance : BEq AlphaKey where
+  beq k₁ k₂ := alphaEq k₁.expr k₂.expr
+
+structure AlphaShareCommon.State where
+  map : PHashMap ExprPtr Expr := {}
+  set : PHashSet AlphaKey := {}
+
+abbrev AlphaShareCommonM := StateM AlphaShareCommon.State
+
+private def save (e : Expr) (r : Expr) : AlphaShareCommonM Expr := do
+  if let some r := (← get).set.find? { expr := r } then
+    let r := r.expr
+    modify fun { set, map } => {
+      set
+      map := map.insert { expr := e } r
+    }
+    return r
+  else
+    modify fun { set, map } => {
+      set := set.insert { expr := r }
+      map := map.insert { expr := e } r |>.insert { expr := r } r
+    }
+    return r
+
+private abbrev visit (e : Expr) (k : AlphaShareCommonM Expr) : AlphaShareCommonM Expr := do
+  if let some r := (← get).map.find? { expr := e } then
+    return r
+  else
+    save e (← k)
+
+/-- Similar to `shareCommon`, but handles alpha-equivalence. -/
+def shareCommonAlpha (e : Expr) : AlphaShareCommonM Expr :=
+  go e
+where
+  go (e : Expr) : AlphaShareCommonM Expr := do
+    match e with
+    | .bvar .. | .mvar .. | .const .. | .fvar .. | .sort .. | .lit .. =>
+      if let some r := (← get).set.find? { expr := e } then
+        return r.expr
+      else
+        modify fun { set, map } => { set := set.insert { expr := e }, map }
+        return e
+    | .app f a =>
+      visit e (return mkApp (← go f) (← go a))
+    | .letE n t v b nd =>
+      visit e (return mkLet n t (← go v) (← go b) nd)
+    | .forallE n d b bi =>
+      visit e (return mkForall n bi (← go d) (← go b))
+    | .lam n d b bi =>
+      visit e (return mkLambda n bi (← go d) (← go b))
+    | .mdata d b =>
+      visit e (return mkMData d (← go b))
+    | .proj n i b =>
+      visit e (return mkProj n i (← go b))
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Arith.lean

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

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Attr.lean

@@ -0,0 +1,125 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.EMatchTheorem
+import Lean.Meta.Tactic.Grind.Cases
+import Lean.Meta.Tactic.Grind.ExtAttr
+
+namespace Lean.Meta.Grind
+
+inductive AttrKind where
+  | ematch (k : EMatchTheoremKind)
+  | cases (eager : Bool)
+  | intro
+  | infer
+  | ext
+  | symbol (prio : Nat)
+
+/-- Return theorem kind for `stx` of the form `Attr.grindThmMod` -/
+def getAttrKindCore (stx : Syntax) : CoreM AttrKind := do
+  match stx with
+  | `(Parser.Attr.grindMod|=) => return .ematch (.eqLhs false)
+  | `(Parser.Attr.grindMod|= gen) => return .ematch (.eqLhs true)
+  | `(Parser.Attr.grindMod|→) => return .ematch .fwd
+  | `(Parser.Attr.grindMod|←) => return .ematch (.bwd false)
+  | `(Parser.Attr.grindMod|← gen) => return .ematch (.bwd true)
+  | `(Parser.Attr.grindMod|=_) => return .ematch (.eqRhs false)
+  | `(Parser.Attr.grindMod|=_ gen) => return .ematch (.eqRhs true)
+  | `(Parser.Attr.grindMod|_=_) => return .ematch (.eqBoth false)
+  | `(Parser.Attr.grindMod|_=_ gen) => return .ematch (.eqBoth true)
+  | `(Parser.Attr.grindMod|←=) => return .ematch .eqBwd
+  | `(Parser.Attr.grindMod|=>) => return .ematch .leftRight
+  | `(Parser.Attr.grindMod|<=) => return .ematch .rightLeft
+  | `(Parser.Attr.grindMod|usr) => return .ematch .user
+  | `(Parser.Attr.grindMod|gen) => return .ematch (.default true)
+  | `(Parser.Attr.grindMod|cases) => return .cases false
+  | `(Parser.Attr.grindMod|cases eager) => return .cases true
+  | `(Parser.Attr.grindMod|intro) => return .intro
+  | `(Parser.Attr.grindMod|ext) => return .ext
+  | `(Parser.Attr.grindMod|symbol $prio:prio) =>
+    let some prio := prio.raw.isNatLit? | throwErrorAt prio "priority expected"
+    return .symbol prio
+  | _ => throwError "unexpected `grind` theorem kind: `{stx}`"
+
+/-- Return theorem kind for `stx` of the form `(Attr.grindMod)?` -/
+def getAttrKindFromOpt (stx : Syntax) : CoreM AttrKind := do
+  if stx[1].isNone then
+    return .infer
+  else
+    getAttrKindCore stx[1][0]
+
+def throwInvalidUsrModifier : CoreM α :=
+  throwError "the modifier `usr` is only relevant in parameters for `grind only`"
+
+/--
+Auxiliary function for registering `grind` and `grind?` attributes.
+The `grind?` is an alias for `grind` which displays patterns using `logInfo`.
+It is just a convenience for users.
+-/
+private def registerGrindAttr (showInfo : Bool) : IO Unit :=
+  registerBuiltinAttribute {
+    name := if showInfo then `grind? else `grind
+    descr :=
+      let header := if showInfo then
+        "The `[grind?]` attribute is identical to the `[grind]` attribute, but displays inferred pattern information."
+      else
+        "The `[grind]` attribute is used to annotate declarations."
+      header ++ "\
+      \
+      When applied to an equational theorem, `[grind =]`, `[grind =_]`, or `[grind _=_]`\
+      will mark the theorem for use in heuristic instantiations by the `grind` tactic,
+      using respectively the left-hand side, the right-hand side, or both sides of the theorem.\
+      When applied to a function, `[grind =]` automatically annotates the equational theorems associated with that function.\
+      When applied to a theorem `[grind ←]` will instantiate the theorem whenever it encounters the conclusion of the theorem
+      (that is, it will use the theorem for backwards reasoning).\
+      When applied to a theorem `[grind →]` will instantiate the theorem whenever it encounters sufficiently many of the propositional hypotheses
+      (that is, it will use the theorem for forwards reasoning).\
+      \
+      The attribute `[grind]` by itself will effectively try `[grind ←]` (if the conclusion is sufficient for instantiation) and then `[grind →]`.\
+      \
+      The `grind` tactic utilizes annotated theorems to add instances of matching patterns into the local context during proof search.\
+      For example, if a theorem `@[grind =] theorem foo_idempotent : foo (foo x) = foo x` is annotated,\
+      `grind` will add an instance of this theorem to the local context whenever it encounters the pattern `foo (foo x)`."
+    applicationTime := .afterCompilation
+    add := fun declName stx attrKind => MetaM.run' do
+      match (← getAttrKindFromOpt stx) with
+      | .ematch .user => throwInvalidUsrModifier
+      | .ematch k => addEMatchAttr declName attrKind k (← getGlobalSymbolPriorities) (showInfo := showInfo)
+      | .cases eager => addCasesAttr declName eager attrKind
+      | .intro =>
+        if let some info ← isCasesAttrPredicateCandidate? declName false then
+          for ctor in info.ctors do
+            addEMatchAttr ctor attrKind (.default false) (← getGlobalSymbolPriorities) (showInfo := showInfo)
+        else
+          throwError "invalid `[grind intro]`, `{declName}` is not an inductive predicate"
+      | .ext => addExtAttr declName attrKind
+      | .infer =>
+        if let some declName ← isCasesAttrCandidate? declName false then
+          addCasesAttr declName false attrKind
+          if let some info ← isInductivePredicate? declName then
+            -- If it is an inductive predicate,
+            -- we also add the constructors (intro rules) as E-matching rules
+            for ctor in info.ctors do
+              addEMatchAttr ctor attrKind (.default false) (← getGlobalSymbolPriorities) (showInfo := showInfo)
+        else
+          addEMatchAttr declName attrKind (.default false) (← getGlobalSymbolPriorities) (showInfo := showInfo)
+      | .symbol prio => addSymbolPriorityAttr declName attrKind prio
+    erase := fun declName => MetaM.run' do
+      if showInfo then
+        throwError "`[grind?]` is a helper attribute for displaying inferred patterns, if you want to remove the attribute, consider using `[grind]` instead"
+      if (← isCasesAttrCandidate declName false) then
+        eraseCasesAttr declName
+      else if (← isExtTheorem declName) then
+        eraseExtAttr declName
+      else
+        eraseEMatchAttr declName
+  }
+
+builtin_initialize
+  registerGrindAttr true
+  registerGrindAttr false
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Beta.lean

@@ -0,0 +1,77 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+/-- Returns all lambda expressions in the equivalence class with root `root`. -/
+def getEqcLambdas (root : ENode) : GoalM (Array Expr) := do
+  unless root.hasLambdas do return #[]
+  foldEqc root.self (init := #[]) fun n lams =>
+    if n.self.isLambda then return lams.push n.self else return lams
+
+/--
+Returns the root of the functions in the equivalence class containing `e`.
+That is, if `f a` is in `root`s equivalence class, results contains the root of `f`.
+-/
+def getFnRoots (e : Expr) : GoalM (Array Expr) := do
+  foldEqc e (init := #[]) fun n fns => do
+    let fn := n.self.getAppFn
+    let fnRoot := (← getRoot? fn).getD fn
+    if Option.isNone <| fns.find? (isSameExpr · fnRoot) then
+      return fns.push fnRoot
+    else
+      return fns
+
+/--
+For each `lam` in `lams` s.t. `lam` and `f` are in the same equivalence class,
+propagate `f args = lam args`.
+-/
+def propagateBetaEqs (lams : Array Expr) (f : Expr) (args : Array Expr) : GoalM Unit := do
+  if args.isEmpty then return ()
+  for lam in lams do
+    let rhs := lam.beta args
+    unless rhs.isLambda do
+      let mut gen := Nat.max (← getGeneration lam) (← getGeneration f)
+      let lhs := mkAppN f args
+      if (← hasSameType f lam) then
+        let mut h ← mkEqProof f lam
+        for arg in args do
+          gen := Nat.max gen (← getGeneration arg)
+          h ← mkCongrFun h arg
+        let eq ← mkEq lhs rhs
+        trace_goal[grind.beta] "{eq}, using {lam}"
+        addNewRawFact h eq (gen+1) (.beta lam)
+
+private def isPropagateBetaTarget (e : Expr) : GoalM Bool := do
+  let .app f _ := e | return false
+  go f
+where
+  go (f : Expr) : GoalM Bool := do
+    if let some root ← getRootENode? f then
+      return root.hasLambdas
+    let .app f _ := f | return false
+    go f
+
+/--
+Applies beta-reduction for lambdas in `f`s equivalence class.
+We use this function while internalizing new applications.
+-/
+def propagateBetaForNewApp (e : Expr) : GoalM Unit := do
+  unless (← isPropagateBetaTarget e) do return ()
+  let mut e := e
+  let mut args := #[]
+  repeat
+    unless args.isEmpty do
+      if let some root ← getRootENode? e then
+        if root.hasLambdas then
+          propagateBetaEqs (← getEqcLambdas root) e args.reverse
+    let .app f arg := e | return ()
+    e := f
+    args := args.push arg
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Canon.lean

@@ -0,0 +1,211 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Grind.Util
+import Lean.Meta.Basic
+import Lean.Meta.FunInfo
+import Lean.Util.FVarSubset
+import Lean.Util.PtrSet
+import Lean.Util.FVarSubset
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+namespace Canon
+
+/-!
+A canonicalizer module for the `grind` tactic. The canonicalizer defined in `Meta/Canonicalizer.lean` is
+not suitable for the `grind` tactic. It was designed for tactics such as `omega`, where the goal is
+to detect when two structurally different atoms are definitionally equal.
+
+The `grind` tactic, on the other hand, uses congruence closure. Moreover, types, type formers, proofs, and instances
+are considered supporting elements and are not factored into congruence detection.
+
+This module minimizes the number of `isDefEq` checks by comparing two terms `a` and `b` only if they are instances,
+types, or type formers and are the `i`-th arguments of two different `f`-applications. This approach is
+sufficient for the congruence closure procedure used by the `grind` tactic.
+
+To further optimize `isDefEq` checks, instances are compared using `TransparencyMode.instances`, which reduces
+the number of constants that need to be unfolded. If diagnostics are enabled, instances are compared using
+the default transparency mode too for sanity checking, and discrepancies are reported.
+Types and type formers are always checked using default transparency.
+
+Remark:
+The canonicalizer minimizes issues with non-canonical instances and structurally different but definitionally equal types,
+but it does not solve all problems. For example, consider a situation where we have `(a : BitVec n)`
+and `(b : BitVec m)`, along with instances `inst1 n : Add (BitVec n)` and `inst2 m : Add (BitVec m)` where `inst1`
+and `inst2` are structurally different. Now consider the terms `a + a` and `b + b`. After canonicalization, the two
+additions will still use structurally different (and definitionally different) instances: `inst1 n` and `inst2 m`.
+Furthermore, `grind` will not be able to infer that  `a + a ≍ b + b` even if we add the assumptions `n = m` and `a ≍ b`.
+-/
+
+@[inline] private def get' : GoalM State :=
+  return (← get).canon
+
+@[inline] private def modify' (f : State → State) : GoalM Unit :=
+  modify fun s => { s with canon := f s.canon }
+
+/--
+Helper function for `canonElemCore`. It tries `isDefEq a b` with default transparency, but using
+at most `canonHeartbeats` heartbeats. It reports an issue if the threshold is reached.
+Remark: `parent` is use only to report an issue.
+-/
+private def isDefEqBounded (a b : Expr) (parent : Expr) : GoalM Bool := do
+  withCurrHeartbeats do
+  let curr := (← getConfig).canonHeartbeats
+  tryCatchRuntimeEx
+    (withTheReader Core.Context (fun ctx => { ctx with maxHeartbeats := curr*1000 }) do
+      withDefault <| isDefEq a b)
+    fun ex => do
+      if ex.isRuntime then
+        reportIssue! "failed to show that{indentExpr a}\nis definitionally equal to{indentExpr b}\nwhile canonicalizing{indentExpr parent}\nusing `{curr}*1000` heartbeats, `(canonHeartbeats := {curr})`"
+        return false
+      else
+        throw ex
+
+/--
+Helper function for canonicalizing `e` occurring as the `i`th argument of an `f`-application.
+If `useIsDefEqBounded` is `true`, we try `isDefEqBounded` before returning false
+-/
+def canonElemCore (parent : Expr) (f : Expr) (i : Nat) (e : Expr) (useIsDefEqBounded : Bool) : GoalM Expr := do
+  let s ← get'
+  if let some c := s.canon.find? e then
+    return c
+  let key := (f, i)
+  let eType ← inferType e
+  let cs := s.argMap.find? key |>.getD []
+  for (c, cType) in cs do
+    /-
+    We first check the types
+    The following checks are a performance bottleneck.
+    For example, in the test `grind_ite.lean`, there are many checks of the form:
+    ```
+    w_4 ∈ assign.insert v true → Prop =?= w_1 ∈ assign.insert v false → Prop
+    ```
+    where `grind` unfolds the definition of `DHashMap.insert` and `TreeMap.insert`.
+    -/
+    if (← withDefault <| isDefEq eType cType) then
+      if (← isDefEq e c) then
+        -- We used to check `c.fvarsSubset e` because it is not
+        -- in general safe to replace `e` with `c` if `c` has more free variables than `e`.
+        -- However, we don't revert previously canonicalized elements in the `grind` tactic.
+        -- Moreover, we store the canonicalizer state in the `Goal` because we case-split
+        -- and different locals are added in different branches.
+        modify' fun s => { s with canon := s.canon.insert e c }
+        trace_goal[grind.debugn.canon] "found {e} ===> {c}"
+        return c
+      if useIsDefEqBounded then
+        -- If `e` and `c` are not types, we use `isDefEqBounded`
+        if (← isDefEqBounded e c parent) then
+          modify' fun s => { s with canon := s.canon.insert e c }
+          trace_goal[grind.debugn.canon] "found using `isDefEqBounded`: {e} ===> {c}"
+          return c
+  trace_goal[grind.debug.canon] "({f}, {i}) ↦ {e}"
+  modify' fun s => { s with canon := s.canon.insert e e, argMap := s.argMap.insert key ((e, eType)::cs) }
+  return e
+
+abbrev canonType (parent f : Expr) (i : Nat) (e : Expr) := withDefault <| canonElemCore parent f i e (useIsDefEqBounded := false)
+abbrev canonInst (parent f : Expr) (i : Nat) (e : Expr) := withReducibleAndInstances <| canonElemCore parent f i e (useIsDefEqBounded := true)
+abbrev canonImplicit (parent f : Expr) (i : Nat) (e : Expr) := withReducible <| canonElemCore parent f i e (useIsDefEqBounded := true)
+
+/--
+Return type for the `shouldCanon` function.
+-/
+private inductive ShouldCanonResult where
+  | /- Nested types (and type formers) are canonicalized. -/
+    canonType
+  | /- Nested instances are canonicalized. -/
+    canonInst
+  | /- Implicit argument that is not an instance nor a type. -/
+    canonImplicit
+  | /-
+    Term is not a proof, type (former), nor an instance.
+    Thus, it must be recursively visited by the canonizer.
+    -/
+    visit
+  deriving Inhabited
+
+instance : Repr ShouldCanonResult where
+  reprPrec r _ := match r with
+    | .canonType => "canonType"
+    | .canonInst => "canonInst"
+    | .canonImplicit => "canonImplicit"
+    | .visit => "visit"
+
+/--
+See comments at `ShouldCanonResult`.
+-/
+def shouldCanon (pinfos : Array ParamInfo) (i : Nat) (arg : Expr) : MetaM ShouldCanonResult := do
+  if h : i < pinfos.size then
+    let pinfo := pinfos[i]
+    if pinfo.isInstImplicit then
+      return .canonInst
+    else if pinfo.isProp then
+      return .visit
+    else if pinfo.isImplicit then
+      if (← isTypeFormer arg) then
+        return .canonType
+      else
+        return .canonImplicit
+  if (← isProp arg) then
+    return .visit
+  else if (← isTypeFormer arg) then
+    return .canonType
+  else
+    return .visit
+
+unsafe def canonImpl (e : Expr) : GoalM Expr := do
+  visit e |>.run' mkPtrMap
+where
+  visit (e : Expr) : StateRefT (PtrMap Expr Expr) GoalM Expr := do
+    unless e.isApp || e.isForall do return e
+    -- Check whether it is cached
+    if let some r := (← get).find? e then
+      return r
+    let e' ← match e with
+      | .app .. => e.withApp fun f args => do
+        if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
+          let prop := args[0]!
+          let prop' ← visit prop
+          if let some r := (← get').proofCanon.find? prop' then
+            pure r
+          else
+            let e' := if ptrEq prop prop' then e else mkAppN f (args.set! 0 prop')
+            modify' fun s => { s with proofCanon := s.proofCanon.insert prop' e' }
+            pure e'
+        else
+          let pinfos := (← getFunInfo f).paramInfo
+          let mut modified := false
+          let mut args := args.toVector
+          for h : i in [:args.size] do
+            let arg := args[i]
+            trace_goal[grind.debug.canon] "[{repr (← shouldCanon pinfos i arg)}]: {arg} : {← inferType arg}"
+            let arg' ← match (← shouldCanon pinfos i arg) with
+            | .canonType  => canonType e f i arg
+            | .canonInst  => canonInst e f i arg
+            | .canonImplicit => canonImplicit e f i (← visit arg)
+            | .visit      => visit arg
+            unless ptrEq arg arg' do
+              args := args.set i arg'
+              modified := true
+          pure <| if modified then mkAppN f args.toArray else e
+      | .forallE _ d b _ =>
+        -- Recall that we have `ForallProp.lean`.
+        let d' ← visit d
+        -- Remark: users may not want to convert `p → q` into `¬p ∨ q`
+        let b' ← if b.hasLooseBVars then pure b else visit b
+        pure <| e.updateForallE! d' b'
+      | _ => unreachable!
+    modify fun s => s.insert e e'
+    return e'
+
+end Canon
+
+/-- Canonicalizes nested types, type formers, and instances in `e`. -/
+def canon (e : Expr) : GoalM Expr := do profileitM Exception "grind canon" (← getOptions) do
+  trace_goal[grind.debug.canon] "{e}"
+  unsafe Canon.canonImpl e
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Cases.lean

@@ -0,0 +1,191 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Cases
+
+namespace Lean.Meta.Grind
+
+/-- Types that `grind` will case-split on. -/
+structure CasesTypes where
+  casesMap : PHashMap Name Bool := {}
+  deriving Inhabited
+
+structure CasesEntry where
+  declName : Name
+  eager : Bool
+  deriving Inhabited
+
+/--
+`grind` always case-splits on the following types. Even when using `grind only`.
+The goal is to reduce noise in the tactic generated by `grind?`
+-/
+private def builtinEagerCases : NameSet :=
+  RBTree.ofList [``And, ``Exists, ``True, ``False, ``Unit, ``Empty]
+
+/--
+Returns `true` if `declName` is the name of inductive type/predicate that
+even `grind only` case splits on.
+Remark: we added support for them to reduce the noise in the tactic generated by
+`grind?`
+-/
+def isBuiltinEagerCases (declName : Name) : Bool :=
+  builtinEagerCases.contains declName
+
+/-- Returns `true` if `s` contains a `declName`. -/
+def CasesTypes.contains (s : CasesTypes) (declName : Name) : Bool :=
+  s.casesMap.contains declName
+
+/-- Removes the given declaration from `s`. -/
+def CasesTypes.erase (s : CasesTypes) (declName : Name) : CasesTypes :=
+  { s with casesMap := s.casesMap.erase declName }
+
+def CasesTypes.insert (s : CasesTypes) (declName : Name) (eager : Bool) : CasesTypes :=
+  { s with casesMap := s.casesMap.insert declName eager }
+
+def CasesTypes.find? (s : CasesTypes) (declName : Name) : Option Bool :=
+  s.casesMap.find? declName
+
+def CasesTypes.isEagerSplit (s : CasesTypes) (declName : Name) : Bool :=
+  (s.casesMap.find? declName |>.getD false) || isBuiltinEagerCases declName
+
+def CasesTypes.isSplit (s : CasesTypes) (declName : Name) : Bool :=
+  (s.casesMap.find? declName |>.isSome) || isBuiltinEagerCases declName
+
+builtin_initialize casesExt : SimpleScopedEnvExtension CasesEntry CasesTypes ←
+  registerSimpleScopedEnvExtension {
+    initial        := {}
+    addEntry       := fun s {declName, eager} => s.insert declName eager
+  }
+
+def resetCasesExt : CoreM Unit := do
+  modifyEnv fun env => casesExt.modifyState env fun _ => {}
+
+def getCasesTypes : CoreM CasesTypes :=
+  return casesExt.getState (← getEnv)
+
+/-- Returns `true` is `declName` is a builtin split or has been tagged with `[grind]` attribute. -/
+def isSplit (declName : Name) : CoreM Bool := do
+  return (← getCasesTypes).isSplit declName
+
+partial def isCasesAttrCandidate? (declName : Name) (eager : Bool) : CoreM (Option Name) := do
+  match (← getConstInfo declName) with
+  | .inductInfo info => if !info.isRec || !eager then return some declName else return none
+  | _ => return none
+
+def isCasesAttrCandidate (declName : Name) (eager : Bool) : CoreM Bool := do
+  return (← isCasesAttrCandidate? declName eager).isSome
+
+def isCasesAttrPredicateCandidate? (declName : Name) (eager : Bool) : MetaM (Option InductiveVal) := do
+  let some declName ← isCasesAttrCandidate? declName eager | return none
+  isInductivePredicate? declName
+
+def validateCasesAttr (declName : Name) (eager : Bool) : CoreM Unit := do
+  unless (← isCasesAttrCandidate declName eager) do
+    if eager then
+      throwError "invalid `[grind cases eager]`, `{declName}` is not a non-recursive inductive datatype or an alias for one"
+    else
+      throwError "invalid `[grind cases]`, `{declName}` is not an inductive datatype or an alias for one"
+
+def addCasesAttr (declName : Name) (eager : Bool) (attrKind : AttributeKind) : CoreM Unit := do
+  validateCasesAttr declName eager
+  casesExt.add { declName, eager } attrKind
+
+def CasesTypes.eraseDecl (s : CasesTypes) (declName : Name) : CoreM CasesTypes := do
+  if s.contains declName then
+    return s.erase declName
+  else
+    throwError "`{declName}` is not marked with the `[grind]` attribute"
+
+def ensureNotBuiltinCases (declName : Name) : CoreM Unit := do
+  if isBuiltinEagerCases declName then
+    throwError "`{declName}` is marked as a built-in case-split for `grind` and cannot be erased"
+
+def eraseCasesAttr (declName : Name) : CoreM Unit := do
+  ensureNotBuiltinCases declName
+  let s := casesExt.getState (← getEnv)
+  let s ← s.eraseDecl declName
+  modifyEnv fun env => casesExt.modifyState env fun _ => s
+
+/--
+We say a free variable is "simple" to be processed by the cases tactic IF:
+- It is the latest and consequently there are no forward dependencies, OR
+- It is not a proposion.
+-/
+private def isSimpleFVar (e : Expr) : MetaM Bool := do
+  let .fvar fvarId := e | return false
+  let decl ← fvarId.getDecl
+  if decl.index == (← getLCtx).numIndices - 1 then
+    -- It is the latest free variable, so there are no forward dependencies
+    return true
+  else
+    -- It is pointless to add an auxiliary equality if `e`s type is a proposition
+    isProp decl.type
+
+/--
+The `grind` tactic includes an auxiliary `cases` tactic that is not intended for direct use by users.
+This method implements it.
+This tactic is automatically applied when introducing local declarations with a type tagged with `[grind_cases]`.
+It is also used for "case-splitting" on terms during the search.
+
+It differs from the user-facing Lean `cases` tactic in the following ways:
+
+- It avoids unnecessary `revert` and `intro` operations.
+
+- It does not introduce new local declarations for each minor premise. Instead, the `grind` tactic preprocessor is responsible for introducing them.
+
+- If the major premise type is an indexed family, auxiliary declarations and (heterogeneous) equalities are introduced.
+  However, these equalities are not resolved using `unifyEqs`. Instead, the `grind` tactic employs union-find and
+  congruence closure to process these auxiliary equalities. This approach avoids applying substitution to propositions
+  that have already been internalized by `grind`.
+-/
+def cases (mvarId : MVarId) (e : Expr) : MetaM (List MVarId) := mvarId.withContext do
+  let tag ← mvarId.getTag
+  let type ← whnf (← inferType e)
+  let .const declName _ := type.getAppFn | throwInductiveExpected type
+  let .inductInfo _ ← getConstInfo declName | throwInductiveExpected type
+  let recursorInfo ← mkRecursorInfo (mkCasesOnName declName)
+  let k (mvarId : MVarId) (fvarId : FVarId) (indices : Array FVarId) : MetaM (List MVarId) := do
+    let indicesExpr := indices.map mkFVar
+    let recursor ← mkRecursorAppPrefix mvarId `grind.cases fvarId recursorInfo indicesExpr
+    let lctx ← getLCtx
+    let lctx := lctx.setKind fvarId .implDetail
+    let lctx := indices.foldl (init := lctx) fun lctx fvarId => lctx.setKind fvarId .implDetail
+    let localInsts ← getLocalInstances
+    let mut recursor := mkApp (mkAppN recursor indicesExpr) (mkFVar fvarId)
+    let mut recursorType ← inferType recursor
+    let mut mvarIdsNew := #[]
+    let mut idx := 1
+    for _ in [:recursorInfo.numMinors] do
+      let .forallE _ targetNew recursorTypeNew _ ← whnf recursorType
+        | throwTacticEx `grind.cases mvarId "unexpected recursor type"
+      recursorType := recursorTypeNew
+      let tagNew := if recursorInfo.numMinors > 1 then Name.num tag idx else tag
+      let mvar ← mkFreshExprMVarAt lctx localInsts targetNew .syntheticOpaque tagNew
+      recursor := mkApp recursor mvar
+      mvarIdsNew := mvarIdsNew.push mvar.mvarId!
+      idx := idx + 1
+    mvarId.assign recursor
+    return mvarIdsNew.toList
+  if recursorInfo.numIndices > 0 then
+    let s ← generalizeIndices' mvarId e
+    s.mvarId.withContext do
+      k s.mvarId s.fvarId s.indicesFVarIds
+  else if (← isSimpleFVar e) then
+    -- We don't need to revert anything.
+    k mvarId e.fvarId! #[]
+  else
+    let mvarId ← if (← isProof e) then
+      mvarId.assert (← mkFreshUserName `x) type e
+    else
+      mvarId.assertExt (← mkFreshUserName `x) type e
+    let (fvarId, mvarId) ← mvarId.intro1
+    mvarId.withContext do k mvarId fvarId #[]
+
+where
+  throwInductiveExpected {α} (type : Expr) : MetaM α := do
+    throwTacticEx `grind.cases mvarId m!"(non-recursive) inductive type expected at {e}{indentExpr type}"
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/CasesMatch.lean

@@ -0,0 +1,82 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Cases
+import Lean.Meta.Match.MatcherApp
+import Lean.Meta.Tactic.Grind.MatchCond
+
+namespace Lean.Meta.Grind
+
+/-- Returns `true` if `e` is of the form `∀ ..., _ = _ ... -> False` -/
+def isMatchCondCandidate (e : Expr) : Bool :=
+  -- TODO: see comment at the beginning of `MatchCond.lean`.
+  Simp.isEqnThmHypothesis e
+
+/--
+Given a splitter alternative, annotate the terms that are `match`-expression
+conditions corresponding to overlapping patterns.
+-/
+private def addMatchCondsToAlt (alt : Expr) : Expr := Id.run do
+  let .forallE _ d b _ := alt
+    | return alt
+  let d := if isMatchCondCandidate d then markAsPreMatchCond d else d
+  return alt.updateForallE! d (addMatchCondsToAlt b)
+
+/--
+Annotates the `match`-expression conditions in the alternatives in the given
+`match` splitter type.
+-/
+private def addMatchCondsToSplitter (splitterType : Expr) (numAlts : Nat) : Expr := Id.run do
+  if numAlts == 0 then return splitterType
+  let .forallE _ alt b _ := splitterType
+    | return splitterType
+  return splitterType.updateForallE! (addMatchCondsToAlt alt) (addMatchCondsToSplitter b (numAlts-1))
+
+def casesMatch (mvarId : MVarId) (e : Expr) : MetaM (List MVarId) := mvarId.withContext do
+  let some app ← matchMatcherApp? e
+    | throwTacticEx `grind.casesMatch mvarId m!"`match`-expression expected{indentExpr e}"
+  let (motive, eqRefls) ← mkMotiveAndRefls app
+  let target ← mvarId.getType
+  let mut us := app.matcherLevels
+  if let some i := app.uElimPos? then
+    us := us.set! i (← getLevel target)
+  let splitterName := (← Match.getEquationsFor app.matcherName).splitterName
+  let splitterApp := mkConst splitterName us.toList
+  let splitterApp := mkAppN splitterApp app.params
+  let splitterApp := mkApp splitterApp motive
+  let splitterApp := mkAppN splitterApp app.discrs
+  let numAlts := app.alts.size
+  let splitterType ← inferType splitterApp
+  let splitterType := addMatchCondsToSplitter splitterType app.alts.size
+  let (mvars, _, _) ← forallMetaBoundedTelescope splitterType numAlts (kind := .syntheticOpaque)
+  let splitterApp := mkAppN splitterApp mvars
+  let val := mkAppN splitterApp eqRefls
+  mvarId.assign val
+  updateTags mvars
+  return mvars.toList.map (·.mvarId!)
+where
+  mkMotiveAndRefls (app : MatcherApp) : MetaM (Expr × Array Expr) := do
+    let dummy := mkSort 0
+    let aux := mkApp (mkAppN e.getAppFn app.params) dummy
+    forallBoundedTelescope (← inferType aux) app.discrs.size fun xs _ => do
+    withNewEqs app.discrs xs fun eqs eqRefls => do
+      let type ← mvarId.getType
+      let type ← mkForallFVars eqs type
+      let motive ← mkLambdaFVars xs type
+      return (motive, eqRefls)
+
+  updateTags (mvars : Array Expr) : MetaM Unit := do
+    let tag ← mvarId.getTag
+    if mvars.size == 1 then
+      mvars[0]!.mvarId!.setTag tag
+    else
+      let mut idx := 1
+      for mvar in mvars do
+        mvar.mvarId!.setTag (Name.num tag idx)
+        idx := idx + 1
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Core.lean

@@ -0,0 +1,431 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Grind.Util
+import Lean.Meta.LitValues
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.PP
+import Lean.Meta.Tactic.Grind.Ctor
+import Lean.Meta.Tactic.Grind.Util
+import Lean.Meta.Tactic.Grind.Beta
+import Lean.Meta.Tactic.Grind.Internalize
+import Lean.Meta.Tactic.Grind.Simp
+
+namespace Lean.Meta.Grind
+
+/--
+The fields `target?` and `proof?` in `e`'s `ENode` are encoding a transitivity proof
+from `e` to the root of the equivalence class
+This method "inverts" the proof, and makes it to go from the root of the equivalence class to `e`.
+
+We use this method when merging two equivalence classes.
+-/
+private partial def invertTrans (e : Expr) : GoalM Unit := do
+  go e false none none
+where
+  go (e : Expr) (flippedNew : Bool) (targetNew? : Option Expr) (proofNew? : Option Expr) : GoalM Unit := do
+    let node ← getENode e
+    if let some target := node.target? then
+      go target (!node.flipped) (some e) node.proof?
+    setENode e { node with
+      target? := targetNew?
+      flipped := flippedNew
+      proof?  := proofNew?
+    }
+
+/--
+Returns `true` if the parent is relevant for congruence closure.
+-/
+private def isCongrRelevant (parent : Expr) : Bool :=
+  parent.isApp || parent.isArrow
+
+/--
+Removes `root` parents from the congruence table.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def removeParents (root : Expr) : GoalM ParentSet := do
+  let parents ← getParents root
+  for parent in parents do
+    -- Recall that we may have `Expr.forallE` in `parents` because of `ForallProp.lean`
+    if (← pure (isCongrRelevant parent) <&&> isCongrRoot parent) then
+      trace_goal[grind.debug.parent] "remove: {parent}"
+      modify fun s => { s with congrTable := s.congrTable.erase { e := parent } }
+  return parents
+
+/--
+Reinserts parents into the congruence table and detect new equalities.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def reinsertParents (parents : ParentSet) : GoalM Unit := do
+  for parent in parents do
+    if (← pure (isCongrRelevant parent) <&&> isCongrRoot parent) then
+      trace_goal[grind.debug.parent] "reinsert: {parent}"
+      addCongrTable parent
+
+/-- Closes the goal when `True` and `False` are in the same equivalence class. -/
+private def closeGoalWithTrueEqFalse : GoalM Unit := do
+  let mvarId := (← get).mvarId
+  unless (← mvarId.isAssigned) do
+    let trueEqFalse ← mkEqFalseProof (← getTrueExpr)
+    let falseProof := mkApp4 (mkConst ``Eq.mp [levelZero]) (← getTrueExpr) (← getFalseExpr) trueEqFalse (mkConst ``True.intro)
+    closeGoal falseProof
+
+/-- Closes the goal when `lhs` and `rhs` are both literal values and belong to the same equivalence class. -/
+private def closeGoalWithValuesEq (lhs rhs : Expr) : GoalM Unit := do
+  let p ← mkEq lhs rhs
+  let hp ← mkEqProof lhs rhs
+  let d ← mkDecide p
+  let pEqFalse := mkApp3 (mkConst ``eq_false_of_decide) p d.appArg! (mkApp2 (mkConst ``Eq.refl [1]) (mkConst ``Bool) (mkConst ``false))
+  let falseProof := mkApp4 (mkConst ``Eq.mp [levelZero]) p (← getFalseExpr) pEqFalse hp
+  closeGoal falseProof
+
+/--
+Updates the modification time to `gmt` for the parents of `root`.
+The modification time is used to decide which terms are considered during e-matching.
+-/
+private partial def updateMT (root : Expr) : GoalM Unit := do
+  let gmt := (← get).ematch.gmt
+  for parent in (← getParents root) do
+    let node ← getENode parent
+    if node.mt < gmt then
+      setENode parent { node with mt := gmt }
+      updateMT parent
+
+/--
+Equalities or disequalities to be propagated to a theory solver **after**
+two equivalence classes have been merged.
+
+Some solvers (e.g. `cutsat`) require the core data structures to satisfy
+their invariants.  During the merge operations some of these invariants do not hold.
+Thus, we first *record* the facts that must be propagated in a `PendingTheoryPropagation` value,
+complete the merge, and only then perform the propagation.
+
+We now use this workflow for *all* theory solvers, even when a particular
+solver does not rely on these invariants.  This keeps the core
+solver-agnostic and lets us modify solvers without further adjustments.
+-/
+inductive PendingTheoryPropagation where
+  | /-- Nothing to propagate. -/
+    none
+  | /-- Propagate the equality `lhs = rhs`. -/
+    eq (lhs rhs : Expr)
+  | /-- Propagate the disequalities in `ps`. -/
+    diseqs (ps : ParentSet)
+
+/--
+Helper function for combining `ENode.offset?` fields and detecting what needs
+to be propagated to the offset constraint module.
+-/
+private def checkOffsetEq (rhsRoot lhsRoot : ENode) : GoalM PendingTheoryPropagation := do
+  match lhsRoot.offset? with
+  | some lhsOffset =>
+    if let some rhsOffset := rhsRoot.offset? then
+      return .eq lhsOffset rhsOffset
+    else
+      -- We have to retrieve the node because other fields have been updated
+      let rhsRoot ← getENode rhsRoot.self
+      setENode rhsRoot.self { rhsRoot with offset? := lhsOffset }
+      return .none
+  | none => return .none
+
+def propagateOffset : PendingTheoryPropagation → GoalM Unit
+  | .eq lhs rhs => Arith.Offset.processNewEq lhs rhs
+  | _ => return ()
+
+/--
+Helper function for combining `ENode.cutsat?` fields and detecting what needs
+to be propagated to the cutsat module.
+-/
+private def checkCutsatEq (rhsRoot lhsRoot : ENode) : GoalM PendingTheoryPropagation := do
+  match lhsRoot.cutsat? with
+  | some lhsCutsat =>
+    if let some rhsCutsat := rhsRoot.cutsat? then
+      return .eq lhsCutsat rhsCutsat
+    else
+      -- We have to retrieve the node because other fields have been updated
+      let rhsRoot ← getENode rhsRoot.self
+      setENode rhsRoot.self { rhsRoot with cutsat? := lhsCutsat }
+      return .diseqs (← getParents rhsRoot.self)
+  | none =>
+    if rhsRoot.cutsat?.isSome then
+      return .diseqs (← getParents lhsRoot.self)
+    else
+      return .none
+
+def propagateCutsat : PendingTheoryPropagation → GoalM Unit
+  | .eq lhs rhs => Arith.Cutsat.processNewEq lhs rhs
+  | .diseqs ps => propagateCutsatDiseqs ps
+  | .none => return ()
+
+/--
+Helper function for combining `ENode.ring?` fields and detecting what needs to be
+propagated to the commutative ring module.
+-/
+private def checkCommRingEq (rhsRoot lhsRoot : ENode) : GoalM PendingTheoryPropagation := do
+  match lhsRoot.ring? with
+  | some lhsRing =>
+    if let some rhsRing := rhsRoot.ring? then
+      return .eq lhsRing rhsRing
+    else
+      -- We have to retrieve the node because other fields have been updated
+      let rhsRoot ← getENode rhsRoot.self
+      setENode rhsRoot.self { rhsRoot with ring? := lhsRing }
+      return .diseqs (← getParents rhsRoot.self)
+  | none =>
+    if rhsRoot.ring?.isSome then
+      return .diseqs (← getParents lhsRoot.self)
+    else
+      return .none
+
+def propagateCommRing : PendingTheoryPropagation → GoalM Unit
+  | .eq lhs rhs => Arith.CommRing.processNewEq lhs rhs
+  | .diseqs ps => propagateCommRingDiseqs ps
+  | _ => return ()
+
+/--
+Helper function for combining `ENode.linarith?` fields and detecting what needs to be
+propagated to the linarith module.
+-/
+private def checkLinarithEq (rhsRoot lhsRoot : ENode) : GoalM PendingTheoryPropagation := do
+  match lhsRoot.linarith? with
+  | some lhs =>
+    if let some rhs := rhsRoot.linarith? then
+      return .eq lhs rhs
+    else
+      -- We have to retrieve the node because other fields have been updated
+      let rhsRoot ← getENode rhsRoot.self
+      setENode rhsRoot.self { rhsRoot with linarith? := lhs }
+      return .diseqs (← getParents rhsRoot.self)
+  | none =>
+    if rhsRoot.linarith?.isSome then
+      return .diseqs (← getParents lhsRoot.self)
+    else
+      return .none
+
+def propagateLinarith : PendingTheoryPropagation → GoalM Unit
+  | .eq lhs rhs => Arith.Linear.processNewEq lhs rhs
+  | .diseqs ps => propagateLinarithDiseqs ps
+  | _ => return ()
+
+/--
+Tries to apply beta-reductiong using the parent applications of the functions in `fns` with
+the lambda expressions in `lams`.
+-/
+def propagateBeta (lams : Array Expr) (fns : Array Expr) : GoalM Unit := do
+  if lams.isEmpty then return ()
+  let lamRoot ← getRoot lams.back!
+  trace_goal[grind.debug.beta] "fns: {fns}, lams: {lams}"
+  for fn in fns do
+    trace_goal[grind.debug.beta] "fn: {fn}, parents: {(← getParents fn).toArray}"
+    for parent in (← getParents fn) do
+      let mut args := #[]
+      let mut curr := parent
+      trace_goal[grind.debug.beta] "parent: {parent}"
+      repeat
+        trace_goal[grind.debug.beta] "curr: {curr}"
+        if (← isEqv curr lamRoot) then
+          propagateBetaEqs lams curr args.reverse
+        let .app f arg := curr
+          | break
+        -- Remark: recall that we do not eagerly internalize partial applications.
+        internalize curr (← getGeneration parent)
+        args := args.push arg
+        curr := f
+
+private partial def addEqStep (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
+  let lhsNode ← getENode lhs
+  let rhsNode ← getENode rhs
+  if isSameExpr lhsNode.root rhsNode.root then
+    -- `lhs` and `rhs` are already in the same equivalence class.
+    trace_goal[grind.debug] "{← ppENodeRef lhs} and {← ppENodeRef rhs} are already in the same equivalence class"
+    return ()
+  trace_goal[grind.eqc] "{← if isHEq then mkHEq lhs rhs else mkEq lhs rhs}"
+  let lhsRoot ← getENode lhsNode.root
+  let rhsRoot ← getENode rhsNode.root
+  let mut valueInconsistency := false
+  let mut trueEqFalse := false
+  if lhsRoot.interpreted && rhsRoot.interpreted then
+    if lhsNode.root.isTrue || rhsNode.root.isTrue then
+      markAsInconsistent
+      trueEqFalse := true
+    else
+      valueInconsistency := true
+  if    (lhsRoot.interpreted && !rhsRoot.interpreted)
+     || (lhsRoot.ctor && !rhsRoot.ctor)
+     || (lhsRoot.size > rhsRoot.size && !rhsRoot.interpreted && !rhsRoot.ctor) then
+    go rhs lhs rhsNode lhsNode rhsRoot lhsRoot true
+  else
+    go lhs rhs lhsNode rhsNode lhsRoot rhsRoot false
+  if trueEqFalse then
+    closeGoalWithTrueEqFalse
+  unless (← isInconsistent) do
+    if lhsRoot.ctor && rhsRoot.ctor then
+      propagateCtor lhsRoot.self rhsRoot.self
+  unless (← isInconsistent) do
+    if valueInconsistency then
+      closeGoalWithValuesEq lhsRoot.self rhsRoot.self
+  trace_goal[grind.debug] "after addEqStep, {← (← get).ppState}"
+  checkInvariants
+where
+  go (lhs rhs : Expr) (lhsNode rhsNode lhsRoot rhsRoot : ENode) (flipped : Bool) : GoalM Unit := do
+    trace_goal[grind.debug] "adding {← ppENodeRef lhs} ↦ {← ppENodeRef rhs}"
+    /-
+    We have the following `target?/proof?`
+    `lhs -> ... -> lhsNode.root`
+    `rhs -> ... -> rhsNode.root`
+    We want to convert it to
+    `lhsNode.root -> ... -> lhs -*-> rhs -> ... -> rhsNode.root`
+    where step `-*->` is justified by `proof` (or `proof.symm` if `flipped := true`)
+    -/
+    invertTrans lhs
+    setENode lhs { lhsNode with
+      target? := rhs
+      proof?  := proof
+      flipped
+    }
+    let lams₁ ← getEqcLambdas lhsRoot
+    let lams₂ ← getEqcLambdas rhsRoot
+    let fns₁  ← if lams₁.isEmpty then pure #[] else getFnRoots rhsRoot.self
+    let fns₂  ← if lams₂.isEmpty then pure #[] else getFnRoots lhsRoot.self
+    let parents ← removeParents lhsRoot.self
+    updateRoots lhs rhsNode.root
+    trace_goal[grind.debug] "{← ppENodeRef lhs} new root {← ppENodeRef rhsNode.root}, {← ppENodeRef (← getRoot lhs)}"
+    reinsertParents parents
+    /-
+    Remark: we used to `propagateDown` here, but this was problematic
+    because it limits what the propagator can do because several invariants do not
+    hold until we complete all updates.
+    -/
+    -- TODO: improve performance: we only need to collect terms that may propagate.
+    let toPropagateDown ← getEqc lhs
+    setENode lhsNode.root { (← getENode lhsRoot.self) with -- We must retrieve `lhsRoot` since it was updated.
+      next := rhsRoot.next
+    }
+    setENode rhsNode.root { rhsRoot with
+      next       := lhsRoot.next
+      size       := rhsRoot.size + lhsRoot.size
+      hasLambdas := rhsRoot.hasLambdas || lhsRoot.hasLambdas
+      heqProofs  := isHEq || rhsRoot.heqProofs || lhsRoot.heqProofs
+    }
+    propagateBeta lams₁ fns₁
+    propagateBeta lams₂ fns₂
+    let offsetTodo ← checkOffsetEq rhsRoot lhsRoot
+    let cutsatTodo ← checkCutsatEq rhsRoot lhsRoot
+    let ringTodo ← checkCommRingEq rhsRoot lhsRoot
+    let linarithTodo ← checkLinarithEq rhsRoot lhsRoot
+    resetParentsOf lhsRoot.self
+    copyParentsTo parents rhsNode.root
+    unless (← isInconsistent) do
+      updateMT rhsRoot.self
+    unless (← isInconsistent) do
+      for parent in parents do
+        propagateUp parent
+      for e in toPropagateDown do
+        propagateDown e
+      propagateOffset offsetTodo
+      propagateCutsat cutsatTodo
+      propagateCommRing ringTodo
+      propagateLinarith linarithTodo
+  updateRoots (lhs : Expr) (rootNew : Expr) : GoalM Unit := do
+    traverseEqc lhs fun n =>
+      setENode n.self { n with root := rootNew }
+
+/-- Ensures collection of equations to be processed is empty. -/
+private def resetNewFacts : GoalM Unit :=
+  modify fun s => { s with newFacts := #[] }
+
+/-- Pops and returns the next equality to be processed. -/
+private def popNextFact? : GoalM (Option NewFact) := do
+  let r := (← get).newFacts.back?
+  if r.isSome then
+    modify fun s => { s with newFacts := s.newFacts.pop }
+  return r
+
+private def addEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
+  addEqStep lhs rhs proof isHEq
+  processNewFacts
+
+/-- Adds a new equality `lhs = rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
+private def addEq (lhs rhs proof : Expr) : GoalM Unit := do
+  addEqCore lhs rhs proof false
+
+/-- Adds a new heterogeneous equality `lhs ≍ rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
+private def addHEq (lhs rhs proof : Expr) : GoalM Unit := do
+  addEqCore lhs rhs proof true
+
+/-- Save asserted facts for pretty printing goal. -/
+private def storeFact (fact : Expr) : GoalM Unit := do
+  modify fun s => { s with facts := s.facts.push fact }
+
+/-- Internalizes `lhs` and `rhs`, and then adds equality `lhs = rhs`. -/
+def addNewEq (lhs rhs proof : Expr) (generation : Nat) : GoalM Unit := do
+  let eq ← mkEq lhs rhs
+  storeFact eq
+  internalize lhs generation eq
+  internalize rhs generation eq
+  addEq lhs rhs proof
+
+private def addFactStep (fact : Expr) (proof : Expr) (generation : Nat) : GoalM Unit := do
+  storeFact fact
+  trace_goal[grind.assert] "{fact}"
+  let_expr Not p := fact
+    | go fact false
+  go p true
+where
+  go (p : Expr) (isNeg : Bool) : GoalM Unit := do
+    match_expr p with
+    | Eq α lhs rhs =>
+      if α.isProp then
+        -- It is morally an iff.
+        -- We do not use the `goEq` optimization because we want to register `p` as a case-split
+        goFact p isNeg
+      else
+        goEq p lhs rhs isNeg false
+    | HEq _ lhs _ rhs => goEq p lhs rhs isNeg true
+    | _ => goFact p isNeg
+
+  goFact (p : Expr) (isNeg : Bool) : GoalM Unit := do
+    internalize p generation
+    if isNeg then
+      addEq p (← getFalseExpr) (← mkEqFalse proof)
+    else
+      addEq p (← getTrueExpr) (← mkEqTrue proof)
+
+  goEq (p : Expr) (lhs rhs : Expr) (isNeg : Bool) (isHEq : Bool) : GoalM Unit := do
+    if isNeg then
+      internalize p generation
+      addEq p (← getFalseExpr) (← mkEqFalse proof)
+    else
+      internalize lhs generation p
+      internalize rhs generation p
+      addEqCore lhs rhs proof isHEq
+
+@[export lean_grind_process_new_facts]
+private def processNewFactsImpl : GoalM Unit := do
+  repeat
+    if (← isInconsistent) then
+      resetNewFacts
+      return ()
+    checkSystem "grind"
+    let some next := (← popNextFact?)
+      | return ()
+    match next with
+    | .eq lhs rhs proof isHEq => addEqStep lhs rhs proof isHEq
+    | .fact prop proof gen => addFactStep prop proof gen
+
+/-- Adds a new `fact` justified by the given proof and using the given generation. -/
+def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
+  if fact.isTrue then return ()
+  if (← isInconsistent) then return ()
+  resetNewFacts
+  addFactStep fact proof generation
+
+/-- Adds a new hypothesis. -/
+def addHypothesis (fvarId : FVarId) (generation := 0) : GoalM Unit := do
+  add (← fvarId.getType) (mkFVar fvarId) generation
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Ctor.lean

@@ -0,0 +1,60 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.ProveEq
+
+namespace Lean.Meta.Grind
+
+private partial def propagateInjEqs (eqs : Expr) (proof : Expr) : GoalM Unit := do
+  -- Remark: we must use `shareCommon` before using `pushEq` and `pushHEq`.
+  -- This is needed because the result type of the injection theorem may allocate
+  match_expr eqs with
+  | And left right =>
+    propagateInjEqs left (.proj ``And 0 proof)
+    propagateInjEqs right (.proj ``And 1 proof)
+  | Eq _ lhs rhs    =>
+    pushEq (← preprocessLight lhs) (← preprocessLight rhs) proof
+  | HEq _ lhs _ rhs =>
+    pushHEq (← preprocessLight lhs) (← preprocessLight rhs) proof
+  | _ =>
+   reportIssue! "unexpected injectivity theorem result type{indentExpr eqs}"
+   return ()
+
+/--
+Given constructors `a` and `b`, propagate equalities if they are the same,
+and close goal if they are different.
+-/
+def propagateCtor (a b : Expr) : GoalM Unit := do
+  let aType ← whnfD (← inferType a)
+  let bType ← whnfD (← inferType b)
+  unless (← withDefault <| isDefEq aType bType) do
+    return ()
+  let ctor₁ := a.getAppFn
+  let ctor₂ := b.getAppFn
+  if ctor₁ == ctor₂ then
+    let .const ctorName _ := a.getAppFn | return ()
+    let injDeclName := Name.mkStr ctorName "inj"
+    unless (← getEnv).contains injDeclName do return ()
+    let info ← getConstInfo injDeclName
+    let n := info.type.getForallArity
+    let mask : Array (Option Expr) := .replicate n none
+    /-
+    We use `mkExpectedTypeHint` here to ensure that `mkAppOptM` will "fill" the implicit
+    arguments of `injDeclName` using exactly the fields of `a` and `b`.
+    There is no guarantee that `inferType (← mkEqProof a b)` is structurally equal to `a = b`.
+    -/
+    let mask := mask.set! (n-1) (some (← mkExpectedTypeHint (← mkEqProof a b) (← mkEq a b)))
+    let injLemma ← mkAppOptM injDeclName mask
+    let injLemmaType ← inferType injLemma
+    propagateInjEqs injLemmaType injLemma
+  else
+    let .const declName _ := aType.getAppFn | return ()
+    let noConfusionDeclName := Name.mkStr declName "noConfusion"
+    unless (← getEnv).contains noConfusionDeclName do return ()
+    closeGoal (← mkNoConfusion (← getFalseExpr) (← mkEqProof a b))
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Diseq.lean

@@ -0,0 +1,86 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Grind.Lemmas
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+/--
+Returns `some (c = d)` if
+- `c = d` and `False` are in the same equivalence class, and
+- `a` (`b`) and `c` are in the same equivalence class, and
+- `b` (`a`) and `d` are in the same equivalence class.
+Otherwise return `none`.
+
+Remark `a` and `b` are assumed to have the same type.
+-/
+private def getDiseqFor? (a b : Expr) : GoalM (Option Expr) := do
+  /-
+  In Z3, we use the congruence table to find equalities more efficiently,
+  but this optimization would be more complicated here because equalities have
+  the type as an implicit argument, and `grind`s congruence table assumes it is
+  hash-consed and canonicalized. So, we use the "slower" approach of visiting
+  parents.
+  -/
+  let aRoot ← getRoot a
+  let bRoot ← getRoot b
+  let aParents ← getParents aRoot
+  let bParents ← getParents bRoot
+  if aParents.size ≤ bParents.size then
+    go aParents
+  else
+    go bParents
+where
+  go (parents : ParentSet) : GoalM (Option Expr) := do
+    for parent in parents do
+      let_expr Eq α c d := parent | continue
+      if (← isEqFalse parent) then
+        -- Remark: we expect `hasType` test to seldom fail, but it can happen because of
+        -- heterogeneous equalities
+        if (← isEqv a c <&&> isEqv b d <&&> hasType a α) then
+          return some parent
+        if (← isEqv a d <&&> isEqv b c <&&> hasType a α) then
+          return some parent
+    return none
+
+/--
+Returns `true` if `a` and `b` are known to be disequal.
+See `getDiseqFor?`
+-/
+def isDiseq (a b : Expr) : GoalM Bool := do
+  return (← getDiseqFor? a b).isSome
+
+/--
+Returns a proof for `true` if `a` and `b` are known to be disequal.
+See `getDiseqFor?`
+-/
+def mkDiseqProof? (a b : Expr) : GoalM (Option Expr) := do
+  let some eq ← getDiseqFor? a b | return none
+  let_expr f@Eq α c d := eq | unreachable!
+  let u := f.constLevels!
+  let h ← mkOfEqFalse (← mkEqFalseProof eq)
+  let (c, d, h) ← if (← isEqv a c <&&> isEqv b d) then
+    pure (c, d, h)
+  else
+    pure (d, c, mkApp4 (mkConst ``Ne.symm u) α c d h)
+  -- We have `a = c` and `b = d`
+  let h ← if isSameExpr a c then
+    pure h
+  else
+    pure <| mkApp6 (mkConst ``Grind.ne_of_ne_of_eq_left u) α a c d (← mkEqProof a c) h
+  -- `h : a ≠ d
+  if isSameExpr b d then
+    return h
+  else
+    return mkApp6 (mkConst ``Grind.ne_of_ne_of_eq_right u) α b a d (← mkEqProof b d) h
+
+def mkDiseqProof (a b : Expr) : GoalM Expr := do
+ let some h ← mkDiseqProof? a b
+   | throwError "internal `grind` error, failed to build disequality proof for{indentExpr a}\nand{indentExpr b}"
+  return h
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/EMatch.lean

@@ -0,0 +1,577 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Intro
+import Lean.Meta.Tactic.Grind.MatchDiscrOnly
+import Lean.Meta.Tactic.Grind.MatchCond
+import Lean.Meta.Tactic.Grind.Core
+
+namespace Lean.Meta.Grind
+namespace EMatch
+/-! This module implements a simple E-matching procedure as a backtracking search. -/
+
+/-- We represent an `E-matching` problem as a list of constraints. -/
+inductive Cnstr where
+  | /-- Matches pattern `pat` with term `e` -/
+    «match» (gen? : Option GenPatternInfo) (pat : Expr) (e : Expr)
+  | /-- Matches offset pattern `pat+k` with term `e` -/
+    offset (gen? : Option GenPatternInfo) (pat : Expr) (k : Nat) (e : Expr)
+  | /-- This constraint is used to encode multi-patterns. -/
+    «continue» (pat : Expr)
+  deriving Inhabited
+
+/--
+Internal "marker" for representing unassigned elements in the `assignment` field.
+This is a small hack to avoid one extra level of indirection by using `Option Expr` at `assignment`.
+-/
+private def unassigned : Expr := mkConst (Name.mkSimple "[grind_unassigned]")
+
+/--
+Internal "marker" for representing equality proofs for generalized patterns.
+They must be synthesized after we have the partial assignment.
+-/
+private def delayedEqProof : Expr := mkConst (Name.mkSimple "[grind_delayed_eq_proof]")
+
+private def assignmentToMessageData (assignment : Array Expr) : Array MessageData :=
+  assignment.reverse.map fun e =>
+    if isSameExpr e unassigned then m!"_" else m!"{e}"
+
+/--
+Choice point for the backtracking search.
+The state of the procedure contains a stack of choices.
+-/
+structure Choice where
+  /-- Constraints to be processed. -/
+  cnstrs     : List Cnstr
+  /-- Maximum term generation found so far. -/
+  gen        : Nat
+  /-- Partial assignment so far. Recall that pattern variables are encoded as de-Bruijn variables. -/
+  assignment : Array Expr
+  deriving Inhabited
+
+/-- Context for the E-matching monad. -/
+structure Context where
+  /-- `useMT` is `true` if we are using the mod-time optimization. It is always set to false for new `EMatchTheorem`s. -/
+  useMT : Bool := true
+  /-- `EMatchTheorem` being processed. -/
+  thm   : EMatchTheorem := default
+  /-- Initial application used to start E-matching -/
+  initApp : Expr := default
+  deriving Inhabited
+
+/-- State for the E-matching monad -/
+structure SearchState where
+  /-- Choices that still have to be processed. -/
+  choiceStack  : List Choice := []
+  deriving Inhabited
+
+abbrev M := ReaderT Context $ StateRefT SearchState GoalM
+
+def M.run' (x : M α) : GoalM α :=
+  x {} |>.run' {}
+
+@[inline] private abbrev withInitApp (e : Expr) (x : M α) : M α :=
+  withReader (fun ctx => { ctx with initApp := e }) x
+
+/--
+Assigns `bidx := e` in `c`. If `bidx` is already assigned in `c`, we check whether
+`e` and `c.assignment[bidx]` are in the same equivalence class.
+This function assumes `bidx < c.assignment.size`.
+Recall that we initialize the assignment array with the number of theorem parameters.
+-/
+private def assign? (c : Choice) (bidx : Nat) (e : Expr) : OptionT GoalM Choice := do
+  if h : bidx < c.assignment.size then
+    let v := c.assignment[bidx]
+    if isSameExpr v unassigned then
+      return { c with assignment := c.assignment.set bidx e }
+    else
+      guard (← isEqv v e)
+      return c
+  else
+    -- `Choice` was not properly initialized
+    unreachable!
+
+/--
+Assigns `bidx` with the marker for a delayed equality proof for generalized patterns.
+The proof is assigned after we have the complete assignment.
+-/
+private def assignDelayedEqProof? (c : Choice) (bidx : Nat) : OptionT GoalM Choice := do
+  if h : bidx < c.assignment.size then
+    let v := c.assignment[bidx]
+    if isSameExpr v unassigned then
+      return { c with assignment := c.assignment.set bidx delayedEqProof }
+    else
+      return c
+  else
+    -- `Choice` was not properly initialized
+    unreachable!
+
+
+private def unassign (c : Choice) (bidx : Nat) : Choice :=
+  { c with assignment := c.assignment.set! bidx unassigned }
+
+/--
+Returns `true` if the function `pFn` of a pattern is equivalent to the function `eFn`.
+Recall that we ignore universe levels in patterns.
+-/
+private def eqvFunctions (pFn eFn : Expr) : Bool :=
+  (pFn.isFVar && pFn == eFn)
+  || (pFn.isConst && eFn.isConstOf pFn.constName!)
+
+protected def _root_.Lean.Meta.Grind.GenPatternInfo.assign? (genInfo : GenPatternInfo) (c : Choice) (x : Expr) : OptionT GoalM Choice := do
+  let c ← assign? c genInfo.xIdx x
+  let c ← assignDelayedEqProof? c genInfo.hIdx
+  return c
+
+/-- Matches a pattern argument. See `matchArgs?`. -/
+private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM Choice := do
+  if isPatternDontCare pArg then
+    return c
+  else if pArg.isBVar then
+    assign? c pArg.bvarIdx! eArg
+  else if let some pArg := groundPattern? pArg then
+    /-
+    We need to use `withReducibleAndIntances` because ground patterns are often instances.
+    Here is an example
+    ```
+    instance : Max Nat where
+      max := Nat.max -- Redefined the instance
+
+    example (a : Nat) : max a a = a := by
+      grind
+    ```
+    Possible future improvements:
+    - When `diagnostics` is true, try with `withDefault` and report issue if it succeeds.
+    - (minor) Only use `withReducibleAndInstances` if the argument is an implicit instance.
+      Potential issue: some user write `{_ : Class α}` when the instance can be inferred from
+      explicit arguments.
+    -/
+    guard (← isEqv pArg eArg <||> withReducibleAndInstances (isDefEq pArg eArg))
+    return c
+  else if let some (pArg, k) := isOffsetPattern? pArg then
+    assert! Option.isNone <| isOffsetPattern? pArg
+    assert! !isPatternDontCare pArg
+    return { c with cnstrs := .offset none pArg k eArg :: c.cnstrs }
+  else if let some (genInfo, pArg) := isGenPattern? pArg then
+    if pArg.isBVar then
+      let c ← assign? c pArg.bvarIdx! eArg
+      genInfo.assign? c eArg
+    else if let some pArg := groundPattern? pArg then
+      guard (← isEqv pArg eArg <||> withReducibleAndInstances (isDefEq pArg eArg))
+      genInfo.assign? c eArg
+    else if let some (pArg, k) := isOffsetPattern? pArg then
+      return { c with cnstrs := .offset (some genInfo) pArg k eArg :: c.cnstrs }
+    else
+      return { c with cnstrs := .match (some genInfo) pArg eArg :: c.cnstrs }
+  else
+    return { c with cnstrs := .match none pArg eArg :: c.cnstrs }
+
+private def Choice.updateGen (c : Choice) (gen : Nat) : Choice :=
+  { c with gen := Nat.max gen c.gen }
+
+private def pushChoice (c : Choice) : M Unit :=
+  modify fun s => { s with choiceStack := c :: s.choiceStack }
+
+/--
+Matches arguments of pattern `p` with term `e`. Returns `some` if successful,
+and `none` otherwise. It may update `c`s assignment and list of constraints to be
+processed.
+-/
+private partial def matchArgs? (c : Choice) (p : Expr) (e : Expr) : OptionT GoalM Choice := do
+  if !p.isApp then return c -- Done
+  let pArg := p.appArg!
+  let eArg := e.appArg!
+  let c ← matchArg? c pArg eArg
+  matchArgs? c p.appFn! e.appFn!
+
+/-- Similar to `matchArgs?` but if `p` has fewer arguments than `e`, we match `p` with a prefix of `e`. -/
+private partial def matchArgsPrefix? (c : Choice) (p : Expr) (e : Expr) : OptionT GoalM Choice := do
+  let pn := p.getAppNumArgs
+  let en := e.getAppNumArgs
+  guard (pn <= en)
+  if pn == en then
+    matchArgs? c p e
+  else
+    matchArgs? c p (e.getAppPrefix pn)
+
+-- Helper function for `processMatch` and `processGenMatch`
+@[inline] private def isCandidate (n : ENode) (pFn : Expr) (pNumArgs : Nat) (maxGeneration : Nat) : Bool :=
+    -- Remark: we use `<` because the instance generation is the maximum term generation + 1
+    n.generation < maxGeneration
+    -- uses heterogeneous equality or is the root of its congruence class
+    && (n.heqProofs || n.isCongrRoot)
+    && eqvFunctions pFn n.self.getAppFn
+    && n.self.getAppNumArgs == pNumArgs
+
+private def assignGenInfo? (genInfo? : Option GenPatternInfo) (c : Choice) (x : Expr) : OptionT GoalM Choice := do
+  let some genInfo := genInfo? | return c
+  genInfo.assign? c x
+
+/--
+Matches pattern `p` with term `e` with respect to choice `c`.
+We traverse the equivalence class of `e` looking for applications compatible with `p`.
+For each candidate application, we match the arguments and may update `c`s assignments and constraints.
+We add the updated choices to the choice stack.
+-/
+private partial def processMatch (c : Choice) (genInfo? : Option GenPatternInfo) (p : Expr) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let pFn := p.getAppFn
+  let numArgs := p.getAppNumArgs
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    -- Remark: we use `<` because the instance generation is the maximum term generation + 1
+    if isCandidate n pFn numArgs maxGeneration then
+      if let some c ← assignGenInfo? genInfo? c e |>.run then
+      if let some c ← matchArgs? c p curr |>.run then
+        pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/--
+Matches offset pattern `pArg+k` with term `e` with respect to choice `c`.
+-/
+private partial def processOffset (c : Choice) (genInfo? : Option GenPatternInfo) (pArg : Expr) (k : Nat) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    if n.generation < maxGeneration then
+      if let some (eArg, k') ← isOffset? curr |>.run then
+        if let some c ← assignGenInfo? genInfo? c e |>.run then
+          if k' < k then
+            let c := c.updateGen n.generation
+            pushChoice { c with cnstrs := .offset none pArg (k - k') eArg :: c.cnstrs }
+          else if k' == k then
+            if let some c ← matchArg? c pArg eArg |>.run then
+              pushChoice (c.updateGen n.generation)
+          else if k' > k then
+            let eArg' := mkNatAdd eArg (mkNatLit (k' - k))
+            let eArg' ← shareCommon (← canon eArg')
+            internalize eArg' (n.generation+1)
+            if let some c ← matchArg? c pArg eArg' |>.run then
+              pushChoice (c.updateGen n.generation)
+      else if let some k' ← evalNat curr |>.run then
+        if let some c ← assignGenInfo? genInfo? c e |>.run then
+          if k' >= k then
+            let eArg' := mkNatLit (k' - k)
+            let eArg' ← shareCommon (← canon eArg')
+            internalize eArg' (n.generation+1)
+            if let some c ← matchArg? c pArg eArg' |>.run then
+              pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/--
+Returns "applications" in the given goal that may match `p`.
+We say "applications," because we assume a constant is a zero-ary application.
+-/
+private def getAppsOf (p : Expr) : GoalM (Option (List Expr)) := do
+  if p.isConst then
+    if (← alreadyInternalized p) then
+      return some [p]
+    else
+      return none
+  else
+    return (← get).appMap.find? p.toHeadIndex
+
+/-- Processes `continue` constraint used to implement multi-patterns. -/
+private def processContinue (c : Choice) (p : Expr) : M Unit := do
+  let some apps ← getAppsOf p
+    | return ()
+  let maxGeneration ← getMaxGeneration
+  for app in apps do
+    let n ← getENode app
+    if n.generation < maxGeneration
+       && (n.heqProofs || n.isCongrRoot) then
+      if let some c ← matchArgsPrefix? c p app |>.run then
+        let gen := n.generation
+        let c := { c with gen := Nat.max gen c.gen }
+        modify fun s => { s with choiceStack := c :: s.choiceStack }
+
+/--
+Given a proposition `prop` corresponding to an equational theorem.
+Annotate the conditions using `Grind.MatchCond`. See `MatchCond.lean`.
+-/
+private partial def annotateEqnTypeConds (prop : Expr) (k : Expr → M Expr := pure) : M Expr := do
+  if let .forallE n d b bi := prop then
+    let d := if (← isProp d) then
+      markAsPreMatchCond d
+    else
+      d
+    withLocalDecl n bi d fun x => do
+      mkForallFVars #[x] (← annotateEqnTypeConds (b.instantiate1 x) k)
+  else
+    k prop
+
+/--
+Helper function for marking parts of `match`-equation theorem as "do-not-simplify"
+`initApp` is the match-expression used to instantiate the `match`-equation.
+It also introduce `Grind.MatchCond` at equation conditions. See `MatchCond.lean`.
+-/
+private def annotateMatchEqnType (prop : Expr) (initApp : Expr) : M Expr := do
+  annotateEqnTypeConds prop fun prop => do
+    let_expr f@Eq α lhs rhs := prop | return prop
+    -- See comment at `Grind.EqMatch`
+    let lhs ← markAsSimpMatchDiscrsOnly lhs
+    return mkApp4 (mkConst ``Grind.EqMatch f.constLevels!) α lhs rhs initApp
+
+/--
+Stores new theorem instance in the state.
+Recall that new instances are internalized later, after a full round of ematching.
+-/
+private def addNewInstance (thm : EMatchTheorem) (proof : Expr) (generation : Nat) : M Unit := do
+  let proof ← instantiateMVars proof
+  if grind.debug.proofs.get (← getOptions) then
+    check proof
+  let mut prop ← inferType proof
+  let mut proof := proof
+  if (← isMatchEqLikeDeclName thm.origin.key) then
+    prop ← annotateMatchEqnType prop (← read).initApp
+    -- We must add a hint here because `annotateMatchEqnType` introduces `simpMatchDiscrsOnly` and
+    -- `Grind.PreMatchCond` which are not reducible.
+    proof := mkExpectedPropHint proof prop
+  else if (← isEqnThm thm.origin.key) then
+    prop ← annotateEqnTypeConds prop
+    -- We must add a hint because `annotateEqnTypeConds` introduces `Grind.PreMatchCond`
+    -- which is not reducible.
+    proof := mkExpectedPropHint proof prop
+  trace_goal[grind.ematch.instance] "{← thm.origin.pp}: {prop}"
+  addTheoremInstance thm proof prop (generation+1)
+
+private def synthesizeInsts (mvars : Array Expr) (bis : Array BinderInfo) : OptionT M Unit := do
+  let thm := (← read).thm
+  for mvar in mvars, bi in bis do
+    if bi.isInstImplicit && !(← mvar.mvarId!.isAssigned) then
+      let type ← inferType mvar
+      unless (← synthesizeInstanceAndAssign mvar type) do
+        reportIssue! "failed to synthesize instance when instantiating {← thm.origin.pp}{indentExpr type}"
+        failure
+
+private def preprocessGeneralizedPatternRHS (lhs : Expr) (rhs : Expr) (origin : Origin) (expectedType : Expr) : OptionT (StateT Choice M) Expr := do
+  assert! (← alreadyInternalized lhs)
+  -- We use `dsimp` here to ensure terms such as `Nat.succ x` are normalized as `x+1`.
+  let rhs ← preprocessLight (← dsimpCore rhs)
+  internalize rhs (← getGeneration lhs)
+  processNewFacts
+  if (← isEqv lhs rhs) then
+    return rhs
+  else
+    reportIssue! "invalid generalized pattern at `{← origin.pp}`\nwhen processing argument with type{indentExpr expectedType}\nfailed to prove{indentExpr lhs}\nis equal to{indentExpr rhs}"
+    failure
+
+private def assignGeneralizedPatternProof (mvarId : MVarId) (eqProof : Expr) (origin : Origin) : OptionT (StateT Choice M) Unit := do
+  unless (← mvarId.checkedAssign eqProof) do
+    reportIssue! "invalid generalized pattern at `{← origin.pp}`\nfailed to assign {mkMVar mvarId}\nwith{indentExpr eqProof}"
+    failure
+
+private def applyAssignment (mvars : Array Expr) : OptionT (StateT Choice M) Unit := do
+  let thm := (← read).thm
+  let numParams := thm.numParams
+  for h : i in [:mvars.size] do
+    let bidx := numParams - i - 1
+    let mut v := (← get).assignment[bidx]!
+    if isSameExpr v delayedEqProof then
+      let mvarId := mvars[i].mvarId!
+      let mvarIdType ← instantiateMVars (← mvarId.getType)
+      match_expr mvarIdType with
+      | Eq α lhs rhs =>
+        let rhs ← preprocessGeneralizedPatternRHS lhs rhs thm.origin mvarIdType
+        assignGeneralizedPatternProof mvarId (← mkEqProof lhs rhs) thm.origin
+      | HEq α lhs β rhs =>
+        let rhs ← preprocessGeneralizedPatternRHS lhs rhs thm.origin mvarIdType
+        assignGeneralizedPatternProof mvarId (← mkHEqProof lhs rhs) thm.origin
+      | _ =>
+        reportIssue! "invalid generalized pattern at `{← thm.origin.pp}`\nequality type expected{indentExpr mvarIdType}"
+        failure
+    else if !isSameExpr v unassigned then
+      let mvarId := mvars[i].mvarId!
+      let mvarIdType ← mvarId.getType
+      let vType ← inferType v
+      let unassignOrFail : OptionT (StateT Choice M) Unit := do
+        /-
+        If there is type error and `vType` is a proposition, we can still instantiate the
+        theorem by unassigning `v` and using it as an extra hypothesis.
+        Here is an example to motivate the unassignment.
+        ```
+        example (xs : Array Nat) (w : xs.reverse = xs) (j : Nat) (hj : 0 ≤ j) (hj' : j < xs.size / 2)
+            : xs[j] = xs[xs.size - 1 - j] := by
+          grind
+        ```
+        Without the unassignment we get a type error while trying to instantiate the theorem
+        ```
+        theorem getElem_reverse {xs : Array α} {i : Nat} (hi : i < xs.reverse.size) :
+          (xs.reverse)[i] = xs[xs.size - 1 - i]'(by simp at hi; omega)
+        ```
+        The pattern for this theorem is `xs.reverse[i]`. Note that `hi` occurs there as an implicit argument.
+        The term `xs[j]` in our goal e-matches the pattern because we have the equality `xs.reverse = xs`.
+        However, the implicit proof at `xs[j]` has type `j < xs.size` instead of `j < xs.reverse.size`.
+        -/
+        if (← isProp vType) then
+          modify (unassign · bidx)
+        else
+          reportIssue! "type error constructing proof for {← thm.origin.pp}\nwhen assigning metavariable {mvars[i]} with {indentExpr v}\n{← mkHasTypeButIsExpectedMsg vType mvarIdType}"
+          failure
+      unless (← withDefault <| isDefEq mvarIdType vType) do
+        if let some heq ← withoutReportingMVarIssues <| proveEq? vType mvarIdType (abstract := true) then
+          /-
+          Some of the `cast`s will appear inside the `Grind.MatchCond` binders, and
+          we want their proofs to be properly wrapped.
+          -/
+          let heq := mkApp2 (mkConst ``Grind.nestedProof) (← mkEq vType mvarIdType) heq
+          v ← mkAppM ``cast #[heq, v]
+        else
+          unassignOrFail
+          continue
+      unless (← mvarId.checkedAssign v) do
+        unassignOrFail
+
+/--
+After processing a (multi-)pattern, use the choice assignment to instantiate the proof.
+Missing parameters are synthesized using type inference and type class synthesis."
+-/
+private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do withNewMCtxDepth do
+  let thm := (← read).thm
+  unless (← markTheoremInstance thm.proof c.assignment) do
+    return ()
+  trace_goal[grind.ematch.instance.assignment] "{← thm.origin.pp}: {assignmentToMessageData c.assignment}"
+  let proof ← thm.getProofWithFreshMVarLevels
+  let numParams := thm.numParams
+  assert! c.assignment.size == numParams
+  let (mvars, bis, _) ← forallMetaBoundedTelescope (← inferType proof) numParams
+  if mvars.size != thm.numParams then
+    reportIssue! "unexpected number of parameters at {← thm.origin.pp}"
+    return ()
+  let (some _, c) ← applyAssignment mvars |>.run c | return ()
+  let some _ ← synthesizeInsts mvars bis | return ()
+  let proof := mkAppN proof mvars
+  if (← mvars.allM (·.mvarId!.isAssigned)) then
+    addNewInstance thm proof c.gen
+  else
+    let mvars ← mvars.filterM fun mvar => return !(← mvar.mvarId!.isAssigned)
+    if let some mvarBad ← mvars.findM? fun mvar => return !(← isProof mvar) then
+      reportIssue! "failed to instantiate {← thm.origin.pp}, failed to instantiate non propositional argument with type{indentExpr (← inferType mvarBad)}"
+    let proof ← mkLambdaFVars (binderInfoForMVars := .default) mvars (← instantiateMVars proof)
+    addNewInstance thm proof c.gen
+
+/-- Process choice stack until we don't have more choices to be processed. -/
+private def processChoices : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  while !(← get).choiceStack.isEmpty do
+    checkSystem "ematch"
+    if (← checkMaxInstancesExceeded) then return ()
+    let c ← modifyGet fun s : SearchState => (s.choiceStack.head!, { s with choiceStack := s.choiceStack.tail! })
+    if c.gen < maxGeneration then
+      match c.cnstrs with
+      | [] => instantiateTheorem c
+      | .match genInfo? p e :: cnstrs => processMatch { c with cnstrs } genInfo? p e
+      | .offset genInfo? p k e :: cnstrs => processOffset { c with cnstrs } genInfo? p k e
+      | .continue p :: cnstrs => processContinue { c with cnstrs } p
+
+private def main (p : Expr) (cnstrs : List Cnstr) : M Unit := do
+  let some apps ← getAppsOf p
+    | return ()
+  let numParams  := (← read).thm.numParams
+  let assignment := .replicate numParams unassigned
+  let useMT      := (← read).useMT
+  let gmt        := (← getThe Goal).ematch.gmt
+  for app in apps do
+    if (← checkMaxInstancesExceeded) then return ()
+    let n ← getENode app
+    if (n.heqProofs || n.isCongrRoot) &&
+       (!useMT || n.mt == gmt) then
+      withInitApp app do
+        if let some c ← matchArgsPrefix? { cnstrs, assignment, gen := n.generation } p app |>.run then
+          modify fun s => { s with choiceStack := [c] }
+          processChoices
+
+/--
+Entry point for matching `lhs ←= rhs` patterns.
+It traverses disequalities `a = b`, and tries to solve two matching problems:
+1- match `lhs` with `a` and `rhs` with `b`
+2- match `lhs` with `b` and `rhs` with `a`
+-/
+private def matchEqBwdPat (p : Expr) : M Unit := do
+  let_expr Grind.eqBwdPattern pα plhs prhs := p | return ()
+  let numParams  := (← read).thm.numParams
+  let assignment := .replicate numParams unassigned
+  let useMT      := (← read).useMT
+  let gmt        := (← getThe Goal).ematch.gmt
+  let false      ← getFalseExpr
+  let mut curr   := false
+  repeat
+    if (← checkMaxInstancesExceeded) then return ()
+    let n ← getENode curr
+    if (n.heqProofs || n.isCongrRoot) &&
+       (!useMT || n.mt == gmt) then
+      let_expr Eq α lhs rhs := n.self | pure ()
+      if let some c₀ ← matchArg? { cnstrs := [], assignment, gen := n.generation } pα α |>.run then
+        let go (lhs rhs : Expr) : M Unit := do
+          let some c₁ ← matchArg? c₀ plhs lhs |>.run | return ()
+          let some c₂ ← matchArg? c₁ prhs rhs |>.run | return ()
+          modify fun s => { s with choiceStack := [c₂] }
+          processChoices
+        go lhs rhs
+        go rhs lhs
+    if isSameExpr n.next false then return ()
+    curr := n.next
+
+def ematchTheorem (thm : EMatchTheorem) : M Unit := do
+  if (← checkMaxInstancesExceeded) then return ()
+  withReader (fun ctx => { ctx with thm }) do
+    let ps := thm.patterns
+    match ps, (← read).useMT with
+    | [p],   _     => if isEqBwdPattern p then matchEqBwdPat p else main p []
+    | p::ps, false => main p (ps.map (.continue ·))
+    | _::_,  true  => tryAll ps []
+    | _,     _     => unreachable!
+where
+  /--
+  When using the mod-time optimization with multi-patterns,
+  we must start ematching at each different pattern. That is,
+  if we have `[p₁, p₂, p₃]`, we must execute
+  - `main p₁ [.continue p₂, .continue p₃]`
+  - `main p₂ [.continue p₁, .continue p₃]`
+  - `main p₃ [.continue p₁, .continue p₂]`
+  -/
+  tryAll (ps : List Expr) (cs : List Cnstr) : M Unit := do
+    match ps with
+    | []    => return ()
+    | p::ps =>
+      main p (cs.reverse ++ (ps.map (.continue ·)))
+      tryAll ps (.continue p :: cs)
+
+def ematchTheorems (thms : PArray EMatchTheorem) : M Unit := do
+  thms.forM ematchTheorem
+
+end EMatch
+
+open EMatch
+
+/-- Performs one round of E-matching, and returns new instances. -/
+private def ematchCore : GoalM Unit := do
+  let go (thms newThms : PArray EMatchTheorem) : EMatch.M Unit := do
+    withReader (fun ctx => { ctx with useMT := true }) <| ematchTheorems thms
+    withReader (fun ctx => { ctx with useMT := false }) <| ematchTheorems newThms
+  if (← checkMaxInstancesExceeded <||> checkMaxEmatchExceeded) then
+    return ()
+  else
+    go (← get).ematch.thms (← get).ematch.newThms |>.run'
+    modify fun s => { s with
+      ematch.thms      := s.ematch.thms ++ s.ematch.newThms
+      ematch.newThms   := {}
+      ematch.gmt       := s.ematch.gmt + 1
+      ematch.num       := s.ematch.num + 1
+    }
+
+/-- Performs one round of E-matching, and returns `true` if new instances were generated. -/
+def ematch : GoalM Bool := do
+  let numInstances := (← get).ematch.numInstances
+  ematchCore
+  return (← get).ematch.numInstances != numInstances
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/EMatchTheorem.lean

@@ -0,0 +1,1277 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Grind.Util
+import Init.Grind.Tactics
+import Lean.HeadIndex
+import Lean.PrettyPrinter
+import Lean.Util.FoldConsts
+import Lean.Util.CollectFVars
+import Lean.Meta.Basic
+import Lean.Meta.InferType
+import Lean.Meta.Eqns
+import Lean.Meta.Match.MatchEqs
+import Lean.Meta.Tactic.Grind.Util
+
+namespace Lean.Meta.Grind
+
+/--
+`grind` uses symbol priorities when inferring patterns for E-matching.
+Symbols not in `map` are assumed to have default priority (i.e., `eval_prio default`).
+-/
+structure SymbolPriorities where
+  map : PHashMap Name Nat := {}
+  deriving Inhabited
+
+structure SymbolPriorityEntry where
+  declName : Name
+  prio : Nat
+  deriving Inhabited
+
+/-- Removes the given declaration from `s`. -/
+def SymbolPriorities.erase (s : SymbolPriorities) (declName : Name) : SymbolPriorities :=
+  { s with map := s.map.erase declName }
+
+/-- Inserts `declName ↦ prio` into `s`. -/
+def SymbolPriorities.insert (s : SymbolPriorities) (declName : Name) (prio : Nat) : SymbolPriorities :=
+  { s with map := s.map.insert declName prio }
+
+/-- Returns `declName` priority for E-matching pattern inference in `s`. -/
+def SymbolPriorities.getPrio (s : SymbolPriorities) (declName : Name) : Nat :=
+  if let some prio := s.map.find? declName then
+    prio
+  else
+    eval_prio default
+
+/--
+Returns `true`, if there is an entry `declName ↦ prio` in `s`.
+Recall that symbols not in `s` are assumed to have default priority.
+-/
+def SymbolPriorities.contains (s : SymbolPriorities) (declName : Name) : Bool :=
+  s.map.contains declName
+
+private builtin_initialize symbolPrioExt : SimpleScopedEnvExtension SymbolPriorityEntry SymbolPriorities ←
+  registerSimpleScopedEnvExtension {
+    initial        := {}
+    addEntry       := fun s {declName, prio} => s.insert declName prio
+  }
+
+def resetSymbolPrioExt : CoreM Unit := do
+  modifyEnv fun env => symbolPrioExt.modifyState env fun _ => {}
+
+def getGlobalSymbolPriorities : CoreM SymbolPriorities :=
+  return symbolPrioExt.getState (← getEnv)
+
+/-- Sets `declName` priority to be used during E-matching pattern inference -/
+def addSymbolPriorityAttr (declName : Name) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
+  symbolPrioExt.add { declName, prio } attrKind
+
+def mkOffsetPattern (pat : Expr) (k : Nat) : Expr :=
+  mkApp2 (mkConst ``Grind.offset) pat (mkRawNatLit k)
+
+private def detectOffsets (pat : Expr) : MetaM Expr := do
+  let pre (e : Expr) := do
+    if e == pat then
+      -- We only consider nested offset patterns
+      return .continue e
+    else match e with
+      | .letE .. | .lam .. | .forallE .. => return .done e
+      | _ =>
+        let some (e, k) ← isOffset? e
+          | return .continue e
+        if k == 0 then return .continue e
+        return .continue <| mkOffsetPattern e k
+  Core.transform pat (pre := pre)
+
+def isOffsetPattern? (pat : Expr) : Option (Expr × Nat) := Id.run do
+  let_expr Grind.offset pat k := pat | none
+  let .lit (.natVal k) := k | none
+  return some (pat, k)
+
+/--
+`detectOffsets` inverse.
+This function is used to expand `mkOffsetPattern` occurring in a constant pattern.
+-/
+private def expandOffsetPatterns (pat : Expr) : CoreM Expr := do
+  let pre (e : Expr) := do
+    match e with
+    | .letE .. | .lam .. | .forallE .. => return .done e
+    | _ =>
+      let some (e, k) := isOffsetPattern? e
+        | return .continue e
+      if k == 0 then return .continue e
+      return .continue <| mkNatAdd e (mkNatLit k)
+  Core.transform pat (pre := pre)
+
+def mkEqBwdPattern (u : List Level) (α : Expr) (lhs rhs : Expr) : Expr :=
+  mkApp3 (mkConst ``Grind.eqBwdPattern u) α lhs rhs
+
+def isEqBwdPattern (e : Expr) : Bool :=
+  e.isAppOfArity ``Grind.eqBwdPattern 3
+
+def isEqBwdPattern? (e : Expr) : Option (Expr × Expr) :=
+  let_expr Grind.eqBwdPattern _ lhs rhs := e
+    | none
+  some (lhs, rhs)
+
+def mkGenPattern (u : List Level) (α : Expr) (h : Expr) (x : Expr) (val : Expr) : Expr :=
+  mkApp4 (mkConst ``Grind.genPattern u) α h x val
+
+def mkGenHEqPattern (u : List Level) (α β : Expr) (h : Expr) (x : Expr) (val : Expr) : Expr :=
+  mkApp5 (mkConst ``Grind.genHEqPattern u) α β h x val
+
+/-- Generalized pattern information. See `Grind.genPattern` gadget. -/
+structure GenPatternInfo where
+  heq  : Bool
+  hIdx : Nat
+  xIdx : Nat
+  deriving Repr
+
+def isGenPattern? (pat : Expr) : Option (GenPatternInfo × Expr) :=
+  match_expr pat with
+  | Grind.genPattern _ h x pat => Id.run do
+    let .bvar hIdx := h | unreachable!
+    let .bvar xIdx := x | unreachable!
+    return some ({ heq := false, hIdx, xIdx }, pat )
+  | Grind.genHEqPattern _ _ h x pat => Id.run do
+    let .bvar hIdx := h | unreachable!
+    let .bvar xIdx := x | unreachable!
+    return some ({ heq := true, hIdx, xIdx }, pat )
+  | _ => none
+
+/-- Returns `true` if `declName` is the name of a `match`-expression congruence equation. -/
+def isMatchCongrEqDeclName (declName : Name) : CoreM Bool := do
+  let declName := privateToUserName declName
+  match declName with
+  | .str p s => return (← isMatcher p) && Match.isCongrEqnReservedNameSuffix s
+  | _ => return false
+
+/-- Returns `true` if `e` is a constant for a `match`-expression congruence equation. -/
+private def isMatchCongrEqConst (e : Expr) : CoreM Bool := do
+  let .const declName _ := e | return false
+  isMatchCongrEqDeclName declName
+
+/--
+Given the type of a `match` congruence equation, annotate the discriminants using
+the gadgets `Grind.genPattern` and `Grind.genHEqPattern`.
+For example, consider the following `match` congruence theorem type
+```
+forall
+  (motive : Option Nat → Sort u_1) (a✝ : Option Nat)
+  (h_1 : a✝ = none → motive none)
+  (h_2 : (val : Nat) → a✝ = some val → motive (some val))
+  (val✝ : Nat)
+  (heq_1 : a✝ = some val✝),
+  g.match_1 motive a✝ h_1 h_2 ≍ h_2 val✝ heq_1
+```
+This function returns the type
+```
+forall
+  (motive : Option Nat → Sort u_1) (a✝ : Option Nat)
+  (h_1 : a✝ = none → motive none)
+  (h_2 : (val : Nat) → a✝ = some val → motive (some val))
+  (val✝ : Nat)
+  (heq_1 : a✝ = some val✝),
+  g.match_1 motive (Grind.genPattern (Option Nat) heq_1 a✝ (some val✝)) h_1 h_2
+  ≍ h_2 val✝ heq_1
+```
+The gadget is used to infer a `generalize` pattern. The following term is used
+during E-matching `g.match_1 motive (Grind.genPattern (Option Nat) heq_1 a✝ (some val✝)) h_1 h_2`
+when matching `Grind.genPattern (Option Nat) heq_1 a✝ (some val✝)` the matcher uses
+`(some val✝)` as the actual pattern, but also assigns `heq_1` `a✝` using the information stored
+in the equivalence class.
+-/
+private def preprocessMatchCongrEqType (type : Expr) : MetaM Expr := do
+  forallTelescopeReducing type fun hs resultType => do
+    let lhs ← match_expr resultType with
+      | Eq _ lhs _ => pure lhs
+      | HEq _ lhs _ _ => pure lhs
+      | _ => return type
+    let lhsFn := lhs.getAppFn
+    let .const declName _ := lhsFn | return type
+    let some matcherInfo ← getMatcherInfo? declName | return type
+    let range := matcherInfo.getDiscrRange
+    let mut args := lhs.getAppArgs
+    for h in hs do
+      match_expr (← inferType h) with
+      | f@Eq α lhs rhs =>
+        for i in range do
+          if lhs == args[i]! then
+            args := args.set! i (mkGenPattern f.constLevels! α h lhs rhs)
+            break
+      | f@HEq α lhs β rhs =>
+        for i in range do
+          if lhs == args[i]! then
+            args := args.set! i (mkGenHEqPattern f.constLevels! α β h lhs rhs)
+            break
+      | _ => pure ()
+    let lhsNew := mkAppN lhsFn args
+    let resultTypeFn := resultType.getAppFn
+    let resultArgs := resultType.getAppArgs
+    let resultType := mkAppN resultTypeFn (resultArgs.set! 1 lhsNew)
+    mkForallFVars hs resultType
+
+/--
+A heuristic procedure for detecting generalized patterns.
+For example, given the theorem
+```
+theorem Option.pbind_some' {α β} {x : Option α} {a : α} {f : (a : α) → x = some a → Option β}
+  (h : x = some a) : pbind x f = f a h
+```
+In the current implementation, we support only occurrences in the resulting type.
+Thus, the following resulting type is generated for the example above:
+```
+pbind (Grind.genPattern h x (some a)) f = f a h
+```
+-/
+private def detectGeneralizedPatterns? (type : Expr) : MetaM Expr := do
+  forallTelescopeReducing type fun hs resultType => do
+    let isTarget? (lhs : Expr) (rhs : Expr) (s : FVarSubst) : Option (FVarId × Expr) := Id.run do
+      let .fvar fvarId := lhs | return none
+      if !hs.contains lhs then
+        return none -- It is a foreign free variable
+      if rhs.containsFVar fvarId then
+        return none -- It is not a generalization if `rhs` contains it
+      if s.contains fvarId then
+        return none -- Remark: may want to abort instead, it is probably not a generalization
+      let rhs := s.apply rhs
+      return some (fvarId, rhs)
+    let mut s : FVarSubst := {}
+    for h in hs do
+      match_expr (← inferType h) with
+      | f@Eq α lhs rhs =>
+        let some (fvarId, rhs) := isTarget? lhs rhs s | pure ()
+        s := s.insert fvarId <| mkGenPattern f.constLevels! α h lhs rhs
+      | f@HEq α lhs β rhs =>
+        let some (fvarId, rhs) := isTarget? lhs rhs s | pure ()
+        s := s.insert fvarId <| mkGenHEqPattern f.constLevels! α β h lhs rhs
+      | _ => pure ()
+    if s.isEmpty then
+      return type
+    let resultType' := s.apply resultType
+    if resultType' == resultType then
+      return type
+    mkForallFVars hs resultType'
+
+/--
+Given the proof for a proposition to be used as an E-matching theorem,
+infers its type, and preprocess it to identify generalized patterns.
+Recall that we infer these generalized patterns automatically for
+`match` congruence equations.
+-/
+private def inferEMatchProofType (proof : Expr) (gen : Bool) : MetaM Expr := do
+  let type ← inferType proof
+  if (← isMatchCongrEqConst proof) then
+    preprocessMatchCongrEqType type
+  else if gen then
+    detectGeneralizedPatterns? type
+  else
+    return type
+
+-- Configuration for the `grind` normalizer. We want both `zetaDelta` and `zeta`
+private def normConfig : Grind.Config := {}
+theorem normConfig_zeta : normConfig.zeta = true := rfl
+theorem normConfig_zetaDelta : normConfig.zetaDelta = true := rfl
+
+def preprocessPattern (pat : Expr) (normalizePattern := true) : MetaM Expr := do
+  let pat ← instantiateMVars pat
+  let pat ← unfoldReducible pat
+  let pat ← if normalizePattern then normalize pat normConfig else pure pat
+  let pat ← detectOffsets pat
+  let pat ← foldProjs pat
+  return pat
+
+inductive Origin where
+  /-- A global declaration in the environment. -/
+  | decl (declName : Name)
+  /-- A local hypothesis. -/
+  | fvar (fvarId : FVarId)
+  /--
+  A proof term provided directly to a call to `grind` where `ref`
+  is the provided grind argument. The `id` is a unique identifier for the call.
+  -/
+  | stx (id : Name) (ref : Syntax)
+  /-- It is local, but we don't have a local hypothesis for it. -/
+  | local (id : Name)
+  deriving Inhabited, Repr
+
+/-- A unique identifier corresponding to the origin. -/
+def Origin.key : Origin → Name
+  | .decl declName => declName
+  | .fvar fvarId   => fvarId.name
+  | .stx id _      => id
+  | .local id      => id
+
+def Origin.pp [Monad m] [MonadEnv m] [MonadError m] (o : Origin) : m MessageData := do
+  match o with
+  | .decl declName => return MessageData.ofConst (← mkConstWithLevelParams declName)
+  | .fvar fvarId   => return mkFVar fvarId
+  | .stx _ ref     => return ref
+  | .local id      => return id
+
+instance : BEq Origin where
+  beq a b := a.key == b.key
+
+instance : Hashable Origin where
+  hash a := hash a.key
+
+inductive EMatchTheoremKind where
+  | eqLhs (gen : Bool)
+  | eqRhs (gen : Bool)
+  | eqBoth (gen : Bool)
+  | eqBwd
+  | fwd
+  | bwd (gen : Bool)
+  | leftRight
+  | rightLeft
+  | default (gen : Bool)
+  | user /- pattern specified using `grind_pattern` command -/
+  deriving Inhabited, BEq, Repr, Hashable
+
+def EMatchTheoremKind.isEqLhs : EMatchTheoremKind → Bool
+  | .eqLhs _ => true
+  | _ => false
+
+def EMatchTheoremKind.isDefault : EMatchTheoremKind → Bool
+  | .default _ => true
+  | _ => false
+
+private def EMatchTheoremKind.toAttribute : EMatchTheoremKind → String
+  | .eqLhs true     => "[grind = gen]"
+  | .eqLhs false    => "[grind =]"
+  | .eqRhs true     => "[grind =_ gen]"
+  | .eqRhs false    => "[grind =_]"
+  | .eqBoth false   => "[grind _=_]"
+  | .eqBoth true    => "[grind _=_ gen]"
+  | .eqBwd          => "[grind ←=]"
+  | .fwd            => "[grind →]"
+  | .bwd false      => "[grind ←]"
+  | .bwd true       => "[grind ← gen]"
+  | .leftRight      => "[grind =>]"
+  | .rightLeft      => "[grind <=]"
+  | .default false  => "[grind]"
+  | .default true   => "[grind gen]"
+  | .user           => "[grind]"
+
+private def EMatchTheoremKind.explainFailure : EMatchTheoremKind → String
+  | .eqLhs _   => "failed to find pattern in the left-hand side of the theorem's conclusion"
+  | .eqRhs _   => "failed to find pattern in the right-hand side of the theorem's conclusion"
+  | .eqBoth _  => unreachable! -- eqBoth is a macro
+  | .eqBwd     => "failed to use theorem's conclusion as a pattern"
+  | .fwd       => "failed to find patterns in the antecedents of the theorem"
+  | .bwd _     => "failed to find patterns in the theorem's conclusion"
+  | .leftRight => "failed to find patterns searching from left to right"
+  | .rightLeft => "failed to find patterns searching from right to left"
+  | .default _ => "failed to find patterns"
+  | .user      => unreachable!
+
+/-- A theorem for heuristic instantiation based on E-matching. -/
+structure EMatchTheorem where
+  /--
+  It stores universe parameter names for universe polymorphic proofs.
+  Recall that it is non-empty only when we elaborate an expression provided by the user.
+  When `proof` is just a constant, we can use the universe parameter names stored in the declaration.
+  -/
+  levelParams : Array Name
+  proof       : Expr
+  numParams   : Nat
+  patterns    : List Expr
+  /-- Contains all symbols used in `patterns`. -/
+  symbols     : List HeadIndex
+  origin      : Origin
+  /-- The `kind` is used for generating the `patterns`. We save it here to implement `grind?`. -/
+  kind        : EMatchTheoremKind
+  deriving Inhabited
+
+/-- Set of E-matching theorems. -/
+structure EMatchTheorems where
+  /-- The key is a symbol from `EMatchTheorem.symbols`. -/
+  private smap : PHashMap Name (List EMatchTheorem) := {}
+  /-- Set of theorem ids that have been inserted using `insert`. -/
+  private origins : PHashSet Origin := {}
+  /-- Theorems that have been marked as erased -/
+  private erased  : PHashSet Origin := {}
+  /-- Mapping from origin to E-matching theorems associated with this origin. -/
+  private omap : PHashMap Origin (List EMatchTheorem) := {}
+  /-- Priorities for pattern inference -/
+  private prios : SymbolPriorities := {}
+  deriving Inhabited
+
+/--
+Inserts a `thm` with symbols `[s_1, ..., s_n]` to `s`.
+We add `s_1 -> { thm with symbols := [s_2, ..., s_n] }`.
+When `grind` internalizes a term containing symbol `s`, we
+process all theorems `thm` associated with key `s`.
+If their `thm.symbols` is empty, we say they are activated.
+Otherwise, we reinsert into `map`.
+-/
+def EMatchTheorems.insert (s : EMatchTheorems) (thm : EMatchTheorem) : EMatchTheorems := Id.run do
+  let .const declName :: syms := thm.symbols
+    | unreachable!
+  let thm := { thm with symbols := syms }
+  let { smap, origins, erased, omap, prios } := s
+  let origin := thm.origin
+  let origins := origins.insert origin
+  let erased := erased.erase origin
+  let smap := if let some thms := smap.find? declName then
+    smap.insert declName (thm::thms)
+  else
+    smap.insert declName [thm]
+  let omap := if let some thms := omap.find? origin then
+    omap.insert origin (thm::thms)
+  else
+    omap.insert origin [thm]
+  return { smap, origins, erased, omap, prios }
+
+/-- Returns `true` if `s` contains a theorem with the given origin. -/
+def EMatchTheorems.contains (s : EMatchTheorems) (origin : Origin) : Bool :=
+  s.origins.contains origin
+
+/-- Mark the theorem with the given origin as `erased` -/
+def EMatchTheorems.erase (s : EMatchTheorems) (origin : Origin) : EMatchTheorems :=
+  { s with erased := s.erased.insert origin, origins := s.origins.erase origin }
+
+/-- Returns true if the theorem has been marked as erased. -/
+def EMatchTheorems.isErased (s : EMatchTheorems) (origin : Origin) : Bool :=
+  s.erased.contains origin
+
+/--
+Retrieves theorems from `s` associated with the given symbol. See `EMatchTheorem.insert`.
+The theorems are removed from `s`.
+-/
+@[inline]
+def EMatchTheorems.retrieve? (s : EMatchTheorems) (sym : Name) : Option (List EMatchTheorem × EMatchTheorems) :=
+  if let some thms := s.smap.find? sym then
+    some (thms, { s with smap := s.smap.erase sym })
+  else
+    none
+
+/--
+Returns theorems associated with the given origin.
+-/
+def EMatchTheorems.find (s : EMatchTheorems) (origin : Origin) : List EMatchTheorem :=
+  if let some thms := s.omap.find? origin then
+    thms
+  else
+    []
+
+def EMatchTheorem.getProofWithFreshMVarLevels (thm : EMatchTheorem) : MetaM Expr := do
+  if thm.proof.isConst && thm.levelParams.isEmpty then
+    let declName := thm.proof.constName!
+    let info ← getConstInfo declName
+    if info.levelParams.isEmpty then
+      return thm.proof
+    else
+      mkConstWithFreshMVarLevels declName
+  else if thm.levelParams.isEmpty then
+    return thm.proof
+  else
+    let us ← thm.levelParams.mapM fun _ => mkFreshLevelMVar
+    return thm.proof.instantiateLevelParamsArray thm.levelParams us
+
+private builtin_initialize ematchTheoremsExt : SimpleScopedEnvExtension EMatchTheorem EMatchTheorems ←
+  registerSimpleScopedEnvExtension {
+    addEntry := EMatchTheorems.insert
+    initial  := {}
+  }
+
+/-- Returns `true` if `declName` has been tagged as an E-match theorem using `[grind]`. -/
+def isEMatchTheorem (declName : Name) : CoreM Bool := do
+  return ematchTheoremsExt.getState (← getEnv) |>.omap.contains (.decl declName)
+
+def resetEMatchTheoremsExt : CoreM Unit := do
+  modifyEnv fun env => ematchTheoremsExt.modifyState env fun _ => {}
+
+/--
+Auxiliary function to expand a pattern containing forbidden application symbols
+into a multi-pattern.
+
+This function enhances the usability of the `[grind =]` attribute by automatically handling
+forbidden pattern symbols. For example, consider the following theorem tagged with this attribute:
+```
+getLast?_eq_some_iff {xs : List α} {a : α} : xs.getLast? = some a ↔ ∃ ys, xs = ys ++ [a]
+```
+Here, the selected pattern is `xs.getLast? = some a`, but `Eq` is a forbidden pattern symbol.
+Instead of producing an error, this function converts the pattern into a multi-pattern,
+allowing the attribute to be used conveniently.
+
+The function recursively expands patterns with forbidden symbols by splitting them
+into their sub-components. If the pattern does not contain forbidden symbols,
+it is returned as-is.
+-/
+partial def splitWhileForbidden (pat : Expr) : List Expr :=
+  match_expr pat with
+  | Not p => splitWhileForbidden p
+  | And p₁ p₂ => splitWhileForbidden p₁ ++ splitWhileForbidden p₂
+  | Or p₁ p₂ => splitWhileForbidden p₁ ++ splitWhileForbidden p₂
+  | Eq _ lhs rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
+  | Iff lhs rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
+  | HEq _ lhs _ rhs => splitWhileForbidden lhs ++ splitWhileForbidden rhs
+  | _ => [pat]
+
+private def dontCare := mkConst (Name.mkSimple "[grind_dontcare]")
+
+def mkGroundPattern (e : Expr) : Expr :=
+  mkAnnotation `grind.ground_pat e
+
+def groundPattern? (e : Expr) : Option Expr :=
+  annotation? `grind.ground_pat e
+
+private def isGroundPattern (e : Expr) : Bool :=
+  groundPattern? e |>.isSome
+
+def isPatternDontCare (e : Expr) : Bool :=
+  e == dontCare
+
+private def isAtomicPattern (e : Expr) : Bool :=
+  e.isBVar || isPatternDontCare e || isGroundPattern e
+
+partial def ppPattern (pattern : Expr) : MessageData := Id.run do
+  if let some e := groundPattern? pattern then
+    return m!"`[{e}]"
+  else if isPatternDontCare pattern then
+    return m!"_"
+  else match pattern with
+    | .bvar idx => return m!"#{idx}"
+    | _ =>
+      if pattern.isAppOfArity ``Grind.offset 2 then
+        let lhs := ppArg <| pattern.getArg! 0
+        let rhs := ppPattern <| pattern.getArg! 1
+        return m!"{lhs} + {rhs}"
+      else
+        let mut r := m!"{pattern.getAppFn}"
+        for arg in pattern.getAppArgs do
+          r := r ++ " " ++ ppArg arg
+        return r
+where
+  ppArg (arg : Expr) : MessageData :=
+    if isAtomicPattern arg then
+      ppPattern arg
+    else
+      .paren (ppPattern arg)
+
+namespace NormalizePattern
+
+structure State where
+  symbols    : Array HeadIndex := #[]
+  symbolSet  : Std.HashSet HeadIndex := {}
+  bvarsFound : Std.HashSet Nat := {}
+
+private structure Context where
+  symPrios : SymbolPriorities
+  /-- Only symbols with priority `>= minPrio` are considered in patterns. -/
+  minPrio  : Nat
+
+abbrev M := ReaderT Context StateRefT State MetaM
+
+/-- Helper declaration for finding bootstrapping issues. See `isCandidateSymbol`. -/
+private abbrev badForPatterns := [``Eq, ``HEq, ``Iff, ``And, ``Or, ``Not]
+
+def isCandidateSymbol (declName : Name) (root : Bool) : M Bool := do
+  let ctx ← read
+  let prio := ctx.symPrios.getPrio declName
+  -- Priority 0 are never considered, they are treated as forbidden
+  if prio == 0 then return false
+  -- Remark: uncomment the following code to fix bootstrapping issues
+  -- if declName ∈ badForPatterns then
+  --  throwError "INSERT `import Init.Grind.Tactics`, otherwise a pattern containing `{declName}` will be used, prio: {prio}"
+  -- If it is the root symbol, then we check whether `prio ≥ minPrio`
+  if root then
+    return prio ≥ ctx.minPrio
+  else
+    return true
+
+private def saveSymbol (h : HeadIndex) : M Unit := do
+  if let .const declName := h then
+    if declName == ``Grind.genHEqPattern || declName == ``Grind.genPattern then
+      -- We do not save gadgets in the list of symbols.
+      return ()
+  unless (← get).symbolSet.contains h do
+    modify fun s => { s with symbols := s.symbols.push h, symbolSet := s.symbolSet.insert h }
+
+private def foundBVar (idx : Nat) : M Bool :=
+  return (← get).bvarsFound.contains idx
+
+private def saveBVar (idx : Nat) : M Unit := do
+  modify fun s => { s with bvarsFound := s.bvarsFound.insert idx }
+
+inductive PatternArgKind where
+  | /-- Argument is relevant for E-matching. -/
+    relevant
+  | /-- Instance implicit arguments are considered support and handled using `isDefEq`. -/
+    instImplicit
+  | /-- Proofs are ignored during E-matching. Lean is proof irrelevant. -/
+    proof
+  | /--
+    Types and type formers are mostly ignored during E-matching, and processed using
+    `isDefEq`. However, if the argument is of the form `C ..` where `C` is inductive type
+    we process it as part of the pattern. Suppose we have `as bs : List α`, and a pattern
+    candidate expression `as ++ bs`, i.e., `@HAppend.hAppend (List α) (List α) (List α) inst as bs`.
+    If we completely ignore the types, the pattern will just be
+    ```
+    @HAppend.hAppend _ _ _ _ #1 #0
+    ```
+    This is not ideal because the E-matcher will try it in any goal that contains `++`,
+    even if it does not even mention lists.
+    -/
+    typeFormer
+    deriving Repr
+
+def PatternArgKind.isSupport : PatternArgKind → Bool
+  | .relevant => false
+  | _ => true
+
+/--
+Returns an array `kinds` s.ts `kinds[i]` is the kind of the corresponding argument.
+
+- a type (that is not a proposition) or type former (which has forward dependencies) or
+- a proof, or
+- an instance implicit argument
+
+When `kinds[i].isSupport` is `true`, we say the corresponding argument is a "support" argument.
+-/
+def getPatternArgKinds (f : Expr) (numArgs : Nat) : MetaM (Array PatternArgKind) := do
+  let pinfos := (← getFunInfoNArgs f numArgs).paramInfo
+  forallBoundedTelescope (← inferType f) numArgs fun xs _ => do
+    xs.mapIdxM fun idx x => do
+      if (← isProp x) then
+        return .relevant
+      else if (← isProof x) then
+        return .proof
+      else if (← isTypeFormer x) then
+        if h : idx < pinfos.size then
+          /-
+          We originally wanted to ignore types and type formers in `grind` and treat them as supporting elements.
+          Thus, we wanted to always return `.typeFormer`. However, we changed our heuristic because of the following example:
+          ```
+          example {α} (f : α → Type) (a : α) (h : ∀ x, Nonempty (f x)) : Nonempty (f a) := by
+            grind
+          ```
+          In this example, we are reasoning about types. Therefore, we adjusted the heuristic as follows:
+          a type or type former is considered a supporting element only if it has forward dependencies.
+          Note that this is not the case for `Nonempty`.
+          -/
+          if pinfos[idx].hasFwdDeps then return .typeFormer else return .relevant
+        else
+          return .typeFormer
+      else if (← x.fvarId!.getDecl).binderInfo matches .instImplicit then
+        return .instImplicit
+      else
+        return .relevant
+
+private def getPatternFn? (pattern : Expr) (inSupport : Bool) (root : Bool) (argKind : PatternArgKind) : M (Option Expr) := do
+  if !pattern.isApp && !pattern.isConst then
+    return none
+  else match pattern.getAppFn with
+    | f@(.const declName _) =>
+      if !(← isCandidateSymbol declName root) then
+        return none
+      if declName == ``Grind.genPattern || declName == ``Grind.genHEqPattern then
+        return some f
+      if inSupport then
+        if argKind matches .typeFormer | .relevant then
+          if (← isInductive declName) then
+            return some f
+        return none
+      return some f
+    | f@(.fvar _) =>
+      if inSupport then return none else return some f
+    | _ =>
+      return none
+
+private partial def go (pattern : Expr) (inSupport : Bool) (root : Bool) : M Expr := do
+  if let some (e, k) := isOffsetPattern? pattern then
+    let e ← goArg e inSupport .relevant
+    if e == dontCare then
+      return dontCare
+    else
+      return mkOffsetPattern e k
+  let some f ← getPatternFn? pattern inSupport root .relevant
+    | throwError "invalid pattern, (non-forbidden) application expected{indentExpr pattern}"
+  assert! f.isConst || f.isFVar
+  unless f.isConstOf ``Grind.eqBwdPattern do
+    saveSymbol f.toHeadIndex
+  let mut args := pattern.getAppArgs.toVector
+  let patternArgKinds ← getPatternArgKinds f args.size
+  for h : i in [:args.size] do
+    let arg := args[i]
+    let argKind := patternArgKinds[i]?.getD .relevant
+    args := args.set i (← goArg arg (inSupport || argKind.isSupport) argKind)
+  return mkAppN f args.toArray
+where
+  goArg (arg : Expr) (inSupport : Bool) (argKind : PatternArgKind) : M Expr := do
+    if !arg.hasLooseBVars then
+      if arg.hasMVar then
+        pure dontCare
+      else
+        return mkGroundPattern (← expandOffsetPatterns arg)
+    else match arg with
+      | .bvar idx =>
+        if inSupport && (← foundBVar idx) then
+          pure dontCare
+        else
+          saveBVar idx
+          pure arg
+      | _ =>
+        if let some _ ← getPatternFn? arg inSupport (root := false) argKind then
+          go arg inSupport (root := false)
+        else
+          pure dontCare
+
+def main (patterns : List Expr) (symPrios : SymbolPriorities) (minPrio : Nat) : MetaM (List Expr × List HeadIndex × Std.HashSet Nat) := do
+  let (patterns, s) ← patterns.mapM (go (inSupport := false) (root := true)) { symPrios, minPrio } |>.run {}
+  return (patterns, s.symbols.toList, s.bvarsFound)
+
+def normalizePattern (e : Expr) : M Expr := do
+  go e (inSupport := false) (root := true)
+
+end NormalizePattern
+
+/--
+Returns `true` if free variables in `type` are not in `thmVars` or are in `fvarsFound`.
+We use this function to check whether `type` is fully instantiated.
+-/
+private def checkTypeFVars (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (type : Expr) : Bool :=
+  let typeFVars := (collectFVars {} type).fvarIds
+  typeFVars.all fun fvarId => !thmVars.contains fvarId || fvarsFound.contains fvarId
+
+/--
+Given an type class instance type `instType`, returns true if free variables in input parameters
+1- are not in `thmVars`, or
+2- are in `fvarsFound`.
+Remark: `fvarsFound` is a subset of `thmVars`
+-/
+private def canBeSynthesized (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (instType : Expr) : MetaM Bool := do
+  forallTelescopeReducing instType fun xs type => type.withApp fun classFn classArgs => do
+    for x in xs do
+      unless checkTypeFVars thmVars fvarsFound (← inferType x) do return false
+    forallBoundedTelescope (← inferType classFn) type.getAppNumArgs fun params _ => do
+      for param in params, classArg in classArgs do
+        let paramType ← inferType param
+        if !paramType.isAppOf ``semiOutParam && !paramType.isAppOf ``outParam then
+          unless checkTypeFVars thmVars fvarsFound classArg do
+            return false
+      return true
+
+/--
+Auxiliary type for the `checkCoverage` function.
+-/
+inductive CheckCoverageResult where
+  | /-- `checkCoverage` succeeded -/
+    ok
+  | /--
+    `checkCoverage` failed because some of the theorem parameters are missing,
+    `pos` contains their positions
+    -/
+    missing (pos : List Nat)
+
+/--
+After we process a set of patterns, we obtain the set of de Bruijn indices in these patterns.
+We say they are pattern variables. This function checks whether the set of pattern variables is sufficient for
+instantiating the theorem with proof `thmProof`. The theorem has `numParams` parameters.
+The missing parameters:
+1- we may be able to infer them using type inference or type class synthesis, or
+2- they are propositions, and may become hypotheses of the instantiated theorem.
+
+For type class instance parameters, we must check whether the free variables in class input parameters are available.
+-/
+private def checkCoverage (thmProof : Expr) (numParams : Nat) (bvarsFound : Std.HashSet Nat) : MetaM CheckCoverageResult := do
+  if bvarsFound.size == numParams then return .ok
+  forallBoundedTelescope (← inferType thmProof) numParams fun xs _ => do
+    assert! numParams == xs.size
+    let patternVars := bvarsFound.toList.map fun bidx => xs[numParams - bidx - 1]!.fvarId!
+    -- `xs` as a `FVarIdSet`.
+    let thmVars : FVarIdSet := RBTree.ofList <| xs.toList.map (·.fvarId!)
+    -- Collect free variables occurring in `e`, and insert the ones that are in `thmVars` into `fvarsFound`
+    let update (fvarsFound : FVarIdSet) (e : Expr) : FVarIdSet :=
+      (collectFVars {} e).fvarIds.foldl (init := fvarsFound) fun s fvarId =>
+        if thmVars.contains fvarId then s.insert fvarId else s
+    -- Theorem variables found so far. We initialize with the variables occurring in patterns
+    -- Remark: fvarsFound is a subset of thmVars
+    let mut fvarsFound : FVarIdSet := RBTree.ofList patternVars
+    for patternVar in patternVars do
+      let type ← patternVar.getType
+      fvarsFound := update fvarsFound type
+    if fvarsFound.size == numParams then return .ok
+    -- Now, we keep traversing remaining variables and collecting
+    -- `processed` contains the variables we have already processed.
+    let mut processed : FVarIdSet := RBTree.ofList patternVars
+    let mut modified := false
+    repeat
+      modified := false
+      for x in xs do
+        let fvarId := x.fvarId!
+        unless processed.contains fvarId do
+          let xType ← inferType x
+          if fvarsFound.contains fvarId then
+            -- Collect free vars in `x`s type and mark as processed
+            fvarsFound := update fvarsFound xType
+            processed := processed.insert fvarId
+            modified := true
+          else if (← isProp xType) then
+            -- If `x` is a proposition, and all theorem variables in `x`s type have already been found
+            -- add it to `fvarsFound` and mark it as processed.
+            if checkTypeFVars thmVars fvarsFound xType then
+              fvarsFound := fvarsFound.insert fvarId
+              processed := processed.insert fvarId
+              modified := true
+          else if (← fvarId.getDecl).binderInfo matches .instImplicit then
+            -- If `x` is instance implicit, check whether
+            -- we have found all free variables needed to synthesize instance
+            if (← canBeSynthesized thmVars fvarsFound xType) then
+              fvarsFound := fvarsFound.insert fvarId
+              fvarsFound := update fvarsFound xType
+              processed := processed.insert fvarId
+              modified := true
+      if fvarsFound.size == numParams then
+        return .ok
+      if !modified then
+        break
+    let mut pos := #[]
+    for h : i in [:xs.size] do
+      let fvarId := xs[i].fvarId!
+      unless fvarsFound.contains fvarId do
+        pos := pos.push i
+    return .missing pos.toList
+
+/--
+Given a theorem with proof `proof` and `numParams` parameters, returns a message
+containing the parameters at positions `paramPos`.
+-/
+private def ppParamsAt (proof : Expr) (numParams : Nat) (paramPos : List Nat) : MetaM MessageData := do
+  forallBoundedTelescope (← inferType proof) numParams fun xs _ => do
+    let mut msg := m!""
+    let mut first := true
+    for h : i in [:xs.size] do
+      if paramPos.contains i then
+        let x := xs[i]
+        if first then first := false else msg := msg ++ "\n"
+        msg := msg ++ m!"{x} : {← inferType x}"
+    addMessageContextFull msg
+
+private def logPatternWhen (showInfo : Bool) (origin : Origin) (patterns : List Expr) : MetaM Unit := do
+  if showInfo then
+    logInfo m!"{← origin.pp}: {patterns.map ppPattern}"
+
+/--
+Creates an E-matching theorem for a theorem with proof `proof`, `numParams` parameters, and the given set of patterns.
+Pattern variables are represented using de Bruijn indices.
+-/
+def mkEMatchTheoremCore (origin : Origin) (levelParams : Array Name) (numParams : Nat) (proof : Expr)
+    (patterns : List Expr) (kind : EMatchTheoremKind) (showInfo := false) : MetaM EMatchTheorem := do
+  -- the patterns have already been selected, there is no point in using priorities here
+  let (patterns, symbols, bvarFound) ← NormalizePattern.main patterns (← getGlobalSymbolPriorities) (minPrio := 1)
+  if symbols.isEmpty then
+    throwError "invalid pattern for `{← origin.pp}`{indentD (patterns.map ppPattern)}\nthe pattern does not contain constant symbols for indexing"
+  trace[grind.ematch.pattern] "{← origin.pp}: {patterns.map ppPattern}"
+  if let .missing pos ← checkCoverage proof numParams bvarFound then
+     let pats : MessageData := m!"{patterns.map ppPattern}"
+     throwError "invalid pattern(s) for `{← origin.pp}`{indentD pats}\nthe following theorem parameters cannot be instantiated:{indentD (← ppParamsAt proof numParams pos)}"
+  logPatternWhen showInfo origin patterns
+  return {
+    proof, patterns, numParams, symbols
+    levelParams, origin, kind
+  }
+
+private def getProofFor (declName : Name) : MetaM Expr := do
+  let info ← getConstInfo declName
+  -- For theorems, `isProp` has already been checked at declaration time
+  unless wasOriginallyTheorem (← getEnv) declName do
+    unless (← isProp info.type) do
+      throwError "invalid E-matching theorem `{declName}`, type is not a proposition"
+  let us := info.levelParams.map mkLevelParam
+  return mkConst declName us
+
+/--
+Creates an E-matching theorem for `declName` with `numParams` parameters, and the given set of patterns.
+Pattern variables are represented using de Bruijn indices.
+-/
+def mkEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) (kind : EMatchTheoremKind) : MetaM EMatchTheorem := do
+  mkEMatchTheoremCore (.decl declName) #[] numParams (← getProofFor declName) patterns kind
+
+/--
+Given a theorem with proof `proof` and type of the form `∀ (a_1 ... a_n), lhs = rhs`,
+creates an E-matching pattern for it using `addEMatchTheorem n [lhs]`
+If `normalizePattern` is true, it applies the `grind` simplification theorems and simprocs to the pattern.
+-/
+def mkEMatchEqTheoremCore (origin : Origin) (levelParams : Array Name) (proof : Expr) (normalizePattern : Bool)
+  (useLhs : Bool) (gen : Bool) (showInfo := false) : MetaM EMatchTheorem := do
+  let (numParams, patterns) ← forallTelescopeReducing (← inferEMatchProofType proof gen) fun xs type => do
+    let (lhs, rhs) ← match_expr type with
+      | Eq _ lhs rhs => pure (lhs, rhs)
+      | Iff lhs rhs => pure (lhs, rhs)
+      | HEq _ lhs _ rhs => pure (lhs, rhs)
+      | _ => throwError "invalid E-matching equality theorem, conclusion must be an equality{indentExpr type}"
+    let pat := if useLhs then lhs else rhs
+    trace[grind.debug.ematch.pattern] "mkEMatchEqTheoremCore: origin: {← origin.pp}, pat: {pat}, useLhs: {useLhs}"
+    let pat ← preprocessPattern pat normalizePattern
+    trace[grind.debug.ematch.pattern] "mkEMatchEqTheoremCore: after preprocessing: {pat}, {← normalize pat normConfig}"
+    let pats := splitWhileForbidden (pat.abstract xs)
+    return (xs.size, pats)
+  mkEMatchTheoremCore origin levelParams numParams proof patterns (if useLhs then .eqLhs gen else .eqRhs gen) (showInfo := showInfo)
+
+def mkEMatchEqBwdTheoremCore (origin : Origin) (levelParams : Array Name) (proof : Expr) (showInfo := false) : MetaM EMatchTheorem := do
+  let (numParams, patterns) ← forallTelescopeReducing (← inferEMatchProofType proof (gen := false)) fun xs type => do
+    let_expr f@Eq α lhs rhs := type
+      | throwError "invalid E-matching `←=` theorem, conclusion must be an equality{indentExpr type}"
+    let pat ← preprocessPattern (mkEqBwdPattern f.constLevels! α lhs rhs)
+    return (xs.size, [pat.abstract xs])
+  mkEMatchTheoremCore origin levelParams numParams proof patterns .eqBwd (showInfo := showInfo)
+
+/--
+Given theorem with name `declName` and type of the form `∀ (a_1 ... a_n), lhs = rhs`,
+creates an E-matching pattern for it using `addEMatchTheorem n [lhs]`
+
+If `normalizePattern` is true, it applies the `grind` simplification theorems and simprocs to the
+pattern.
+-/
+def mkEMatchEqTheorem (declName : Name) (normalizePattern := true) (useLhs : Bool := true) (gen : Bool := false) (showInfo := false) : MetaM EMatchTheorem := do
+  mkEMatchEqTheoremCore (.decl declName) #[] (← getProofFor declName) normalizePattern useLhs gen (showInfo := showInfo)
+
+/--
+Adds an E-matching theorem to the environment.
+See `mkEMatchTheorem`.
+-/
+def addEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) (kind : EMatchTheoremKind) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchTheorem declName numParams patterns kind)
+
+/--
+Adds an E-matching equality theorem to the environment.
+See `mkEMatchEqTheorem`.
+-/
+def addEMatchEqTheorem (declName : Name) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchEqTheorem declName)
+
+/-- Returns the E-matching theorems registered in the environment. -/
+def getEMatchTheorems : CoreM EMatchTheorems :=
+  return ematchTheoremsExt.getState (← getEnv)
+
+/-- Returns the types of `xs` that are propositions. -/
+private def getPropTypes (xs : Array Expr) : MetaM (Array Expr) :=
+  xs.filterMapM fun x => do
+    let type ← inferType x
+    if (← isProp type) then return some type else return none
+
+/-- State for the (pattern) `CollectorM` monad -/
+private structure Collector.State where
+  /-- Pattern found so far. -/
+  patterns  : Array Expr := #[]
+  done      : Bool := false
+
+private structure Collector.Context where
+  proof : Expr
+  xs    : Array Expr
+
+/-- Monad for collecting patterns for a theorem. -/
+private abbrev CollectorM := ReaderT Collector.Context $ StateRefT Collector.State NormalizePattern.M
+
+/-- Similar to `getPatternFn?`, but operates on expressions that do not contain loose de Bruijn variables. -/
+private def isPatternFnCandidate (f : Expr) : CollectorM Bool := do
+  match f with
+  | .const declName _ => NormalizePattern.isCandidateSymbol declName (root := true)
+  | .fvar .. => return !(← read).xs.contains f
+  | _ => return false
+
+private def addNewPattern (p : Expr) : CollectorM Unit := do
+  trace[grind.debug.ematch.pattern] "found pattern: {ppPattern p}"
+  let bvarsFound := (← getThe NormalizePattern.State).bvarsFound
+  let done := (← checkCoverage (← read).proof (← read).xs.size bvarsFound) matches .ok
+  if done then
+    trace[grind.debug.ematch.pattern] "found full coverage"
+  modify fun s => { s with patterns := s.patterns.push p, done }
+
+/-- Collect the pattern (i.e., de Bruijn) variables in the given pattern. -/
+private def collectPatternBVars (p : Expr) : List Nat :=
+  go p |>.run [] |>.2
+where
+  go (e : Expr) : StateM (List Nat) Unit := do
+    match e with
+    | .app f a    => go f; go a
+    | .mdata _ b  => go b
+    | .bvar idx   => modify fun s => if s.contains idx then s else idx :: s
+    | _           => return ()
+
+private def diff (s : List Nat) (found : Std.HashSet Nat) : List Nat :=
+  if found.isEmpty then s else s.filter fun x => !found.contains x
+
+/--
+Returns `true` if pattern `p` contains a child `c` such that
+1- `p` and `c` have the same new pattern variables. We say a pattern variable is new if it is not in `alreadyFound`.
+2- `c` is not a support argument. See `NormalizePattern.getPatternSupportMask` for definition.
+3- `c` is not an offset pattern.
+4- `c` is not a bound variable.
+-/
+private def hasChildWithSameNewBVars (p : Expr)
+    (argKinds : Array NormalizePattern.PatternArgKind) (alreadyFound : Std.HashSet Nat) : CoreM Bool := do
+  let s := diff (collectPatternBVars p) alreadyFound
+  for arg in p.getAppArgs, argKind in argKinds do
+    unless argKind.isSupport do
+    unless arg.isBVar do
+    unless isOffsetPattern? arg |>.isSome do
+      let sArg := diff (collectPatternBVars arg) alreadyFound
+      if s ⊆ sArg then
+        return true
+  return false
+
+private partial def collect (e : Expr) : CollectorM Unit := do
+  if (← get).done then return ()
+  match e with
+  | .app .. =>
+    trace[grind.debug.ematch.pattern] "collect: {e}"
+    let f := e.getAppFn
+    let argKinds ← NormalizePattern.getPatternArgKinds f e.getAppNumArgs
+    if (← isPatternFnCandidate f) then
+      let saved ← getThe NormalizePattern.State
+      try
+        trace[grind.debug.ematch.pattern] "candidate: {e}"
+        let p := e.abstract (← read).xs
+        unless p.hasLooseBVars do
+          trace[grind.debug.ematch.pattern] "skip, does not contain pattern variables"
+          return ()
+        let p ← NormalizePattern.normalizePattern p
+        if saved.bvarsFound.size < (← getThe NormalizePattern.State).bvarsFound.size then
+          unless (← hasChildWithSameNewBVars p argKinds saved.bvarsFound) do
+            addNewPattern p
+            return ()
+        trace[grind.debug.ematch.pattern] "skip, no new variables covered"
+        -- restore state and continue search
+        set saved
+      catch ex =>
+        trace[grind.debug.ematch.pattern] "skip, exception during normalization{indentD ex.toMessageData}"
+        -- restore state and continue search
+        set saved
+    let args := e.getAppArgs
+    for arg in args, argKind in argKinds do
+      trace[grind.debug.ematch.pattern] "arg: {arg}, support: {argKind.isSupport}"
+      unless argKind.isSupport do
+        collect arg
+  | .forallE _ d b _ =>
+    if (← pure e.isArrow <&&> isProp d <&&> isProp b) then
+      collect d
+      collect b
+  | _ => return ()
+
+private def collectPatterns? (proof : Expr) (xs : Array Expr) (searchPlaces : Array Expr) (symPrios : SymbolPriorities) (minPrio : Nat)
+    : MetaM (Option (List Expr × List HeadIndex)) := do
+  let go : CollectorM (Option (List Expr)) := do
+    for place in searchPlaces do
+      trace[grind.debug.ematch.pattern] "place: {place}"
+      let place ← preprocessPattern place
+      collect place
+      if (← get).done then
+        return some ((← get).patterns.toList)
+    return none
+  let (some ps, s) ← go { proof, xs } |>.run' {} { symPrios, minPrio } |>.run {}
+    | return none
+  return some (ps, s.symbols.toList)
+
+/--
+Tries to find a ground pattern to activate the theorem.
+This is used for theorems such as `theorem evenZ : Even 0`.
+This function is only used if `collectPatterns?` returns `none`.
+
+Remark: only symbols with priority `>= minPrio` are considered.
+-/
+private partial def collectGroundPattern? (proof : Expr) (xs : Array Expr) (searchPlaces : Array Expr) (symPrios: SymbolPriorities) (minPrio : Nat)
+    : MetaM (Option (Expr × List HeadIndex)) := do
+  unless (← checkCoverage proof xs.size {}) matches .ok do
+    return none
+  let go? : CollectorM (Option Expr) := do
+    for place in searchPlaces do
+      let place ← preprocessPattern place
+      if let some r ← visit? place then
+        return r
+    return none
+  let (some p, s) ← go? { proof, xs } |>.run' {} { symPrios, minPrio } |>.run {}
+    | return none
+  return some (p, s.symbols.toList)
+where
+  visit? (e : Expr) : CollectorM (Option Expr) := do
+    match e with
+    | .app .. =>
+      let f := e.getAppFn
+      if (← isPatternFnCandidate f) then
+        let e ← NormalizePattern.normalizePattern e
+        return some e
+      else
+        let args := e.getAppArgs
+        for arg in args, argKind in (← NormalizePattern.getPatternArgKinds f args.size) do
+          unless argKind.isSupport do
+            if let some r ← visit? arg then
+              return r
+        return none
+    | .forallE _ d b _ =>
+      if (← pure e.isArrow <&&> isProp d <&&> isProp b) then
+        if let some d ← visit? d then return d
+        visit? b
+      else
+        return none
+    | _ => return none
+
+def EMatchTheoremKind.gen : EMatchTheoremKind → Bool
+  | .eqLhs gen => gen
+  | .eqRhs gen => gen
+  | .eqBoth gen => gen
+  | .default gen => gen
+  | .bwd gen => gen
+  | .eqBwd | .fwd | .rightLeft
+  | .leftRight | .user => false
+
+private def collectUsedPriorities (prios : SymbolPriorities) (searchPlaces : Array Expr) : Array Nat := Id.run do
+  let mut s : Std.HashSet Nat := {}
+  for place in searchPlaces do
+    s := place.foldConsts (init := s) fun declName s =>
+      let prio := prios.getPrio declName
+      if prio > 0 then s.insert prio else s
+  let r := s.toArray
+  if r.isEmpty then
+    return #[eval_prio default]
+  else
+    return r.qsort fun p₁ p₂ => p₁ > p₂
+
+/--
+Creates an E-match theorem using the given proof and kind.
+If `groundPatterns` is `true`, it accepts patterns without pattern variables. This is useful for
+theorems such as `theorem evenZ : Even 0`. For local theorems, we use `groundPatterns := false`
+since the theorem is already in the `grind` state and there is nothing to be instantiated.
+-/
+def mkEMatchTheoremWithKind?
+      (origin : Origin) (levelParams : Array Name) (proof : Expr) (kind : EMatchTheoremKind) (symPrios : SymbolPriorities)
+      (groundPatterns := true) (showInfo := false) : MetaM (Option EMatchTheorem) := do
+  match kind with
+  | .eqLhs gen =>
+    return (← mkEMatchEqTheoremCore origin levelParams proof (normalizePattern := true) (useLhs := true) (gen := gen) (showInfo := showInfo))
+  | .eqRhs gen =>
+    return (← mkEMatchEqTheoremCore origin levelParams proof (normalizePattern := true) (useLhs := false) (gen := gen) (showInfo := showInfo))
+  | .eqBwd =>
+    return (← mkEMatchEqBwdTheoremCore origin levelParams proof (showInfo := showInfo))
+  | _ =>
+    pure ()
+  let type ← inferEMatchProofType proof kind.gen
+  /-
+  Remark: we should not use `forallTelescopeReducing` (with default reducibility) here
+  because it may unfold a definition/abstraction, and then select a suboptimal pattern.
+  Here is an example. Suppose we have
+  ```
+  def State.le (σ₁ σ₂ : State) : Prop := ∀ ⦃x : Var⦄ ⦃v : Val⦄, σ₁.find? x = some v → σ₂.find? x = some v
+
+  infix:50 " ≼ " => State.le
+  ```
+  Then, we write the theorem
+  ```
+  @[grind] theorem State.join_le_left (σ₁ σ₂ : State) : σ₁.join σ₂ ≼ σ₁ := by
+  ```
+  We do not want `State.le` to be unfolded and the abstraction exposed.
+
+  That said, we must still reduce `[reducible]` definitions since `grind` unfolds them.
+  -/
+  withReducible <| forallTelescopeReducing type fun xs type => withDefault do
+    let searchPlaces ← match kind with
+      | .fwd =>
+        let ps ← getPropTypes xs
+        if ps.isEmpty then
+          throwError "invalid `grind` forward theorem, theorem `{← origin.pp}` does not have propositional hypotheses"
+        pure ps
+      | .bwd _ => pure #[type]
+      | .leftRight => pure <| (← getPropTypes xs).push type
+      | .rightLeft => pure <| #[type] ++ (← getPropTypes xs).reverse
+      | .default _ => pure <| #[type] ++ (← getPropTypes xs)
+      | _ => unreachable!
+    go xs searchPlaces
+where
+  collect (xs : Array Expr) (searchPlaces : Array Expr) : MetaM (Option (List Expr × List HeadIndex)) := do
+    let prios := collectUsedPriorities symPrios searchPlaces
+    for minPrio in prios do
+      if let some r ← collectPatterns? proof xs searchPlaces symPrios minPrio then
+        return some r
+      else if groundPatterns then
+        if let some (pattern, symbols) ← collectGroundPattern? proof xs searchPlaces symPrios minPrio then
+          return some ([pattern], symbols)
+    return none
+
+  go (xs : Array Expr) (searchPlaces : Array Expr) : MetaM (Option EMatchTheorem) := do
+    let some (patterns, symbols) ← collect xs searchPlaces | return none
+    let numParams := xs.size
+    trace[grind.ematch.pattern] "{← origin.pp}: {patterns.map ppPattern}"
+    logPatternWhen showInfo origin patterns
+    return some {
+      proof, patterns, numParams, symbols
+      levelParams, origin, kind
+    }
+
+def mkEMatchTheoremForDecl (declName : Name) (thmKind : EMatchTheoremKind) (prios : SymbolPriorities) (showInfo := false) : MetaM EMatchTheorem := do
+  let some thm ← mkEMatchTheoremWithKind? (.decl declName) #[] (← getProofFor declName) thmKind prios (showInfo := showInfo)
+    | throwError "`@{thmKind.toAttribute} theorem {declName}` {thmKind.explainFailure}, consider using different options or the `grind_pattern` command"
+  return thm
+
+def mkEMatchEqTheoremsForDef? (declName : Name) (showInfo := false) : MetaM (Option (Array EMatchTheorem)) := do
+  let some eqns ← getEqnsFor? declName | return none
+  eqns.mapM fun eqn => do
+    mkEMatchEqTheorem eqn (normalizePattern := true) (showInfo := showInfo)
+
+private def addGrindEqAttr (declName : Name) (attrKind : AttributeKind) (thmKind : EMatchTheoremKind) (useLhs := true) (showInfo := false) : MetaM Unit := do
+  if wasOriginallyTheorem (← getEnv) declName then
+    ematchTheoremsExt.add (← mkEMatchEqTheorem declName (normalizePattern := true) (useLhs := useLhs) (gen := thmKind.gen) (showInfo := showInfo)) attrKind
+  else if let some thms ← mkEMatchEqTheoremsForDef? declName (showInfo := showInfo) then
+    unless useLhs do
+      throwError "`{declName}` is a definition, you must only use the left-hand side for extracting patterns"
+    thms.forM (ematchTheoremsExt.add · attrKind)
+  else
+    throwError s!"`{thmKind.toAttribute}` attribute can only be applied to equational theorems or function definitions"
+
+def EMatchTheorems.eraseDecl (s : EMatchTheorems) (declName : Name) : MetaM EMatchTheorems := do
+  let throwErr {α} : MetaM α :=
+    throwError "`{declName}` is not marked with the `[grind]` attribute"
+  if !wasOriginallyTheorem (← getEnv) declName then
+    if let some eqns ← getEqnsFor? declName then
+       let s := ematchTheoremsExt.getState (← getEnv)
+       unless eqns.all fun eqn => s.contains (.decl eqn) do
+         throwErr
+       return eqns.foldl (init := s) fun s eqn => s.erase (.decl eqn)
+    else
+      throwErr
+  else
+    unless ematchTheoremsExt.getState (← getEnv) |>.contains (.decl declName) do
+      throwErr
+    return s.erase <| .decl declName
+
+def addEMatchAttr (declName : Name) (attrKind : AttributeKind) (thmKind : EMatchTheoremKind) (prios : SymbolPriorities) (showInfo := false) : MetaM Unit := do
+  match thmKind with
+  | .eqLhs _ =>
+    addGrindEqAttr declName attrKind thmKind (useLhs := true) (showInfo := showInfo)
+  | .eqRhs _ =>
+    addGrindEqAttr declName attrKind thmKind (useLhs := false) (showInfo := showInfo)
+  | .eqBoth _ =>
+    addGrindEqAttr declName attrKind thmKind (useLhs := true) (showInfo := showInfo)
+    addGrindEqAttr declName attrKind thmKind (useLhs := false) (showInfo := showInfo)
+  | _ =>
+    let info ← getConstInfo declName
+    if !wasOriginallyTheorem (← getEnv) declName && !info.isCtor && !info.isAxiom then
+      addGrindEqAttr declName attrKind thmKind (showInfo := showInfo)
+    else
+      let thm ← mkEMatchTheoremForDecl declName thmKind prios (showInfo := showInfo)
+      ematchTheoremsExt.add thm attrKind
+
+def eraseEMatchAttr (declName : Name) : MetaM Unit := do
+  /-
+  Remark: consider the following example
+  ```
+  attribute [grind] foo  -- ok
+  attribute [-grind] foo.eqn_2  -- ok
+  attribute [-grind] foo  -- error
+  ```
+  One may argue that the correct behavior should be
+  ```
+  attribute [grind] foo  -- ok
+  attribute [-grind] foo.eqn_2  -- error
+  attribute [-grind] foo  -- ok
+  ```
+  -/
+  let s := ematchTheoremsExt.getState (← getEnv)
+  let s ← s.eraseDecl declName
+  modifyEnv fun env => ematchTheoremsExt.modifyState env fun _ => s
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/EqResolution.lean

@@ -0,0 +1,133 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.AppBuilder
+import Lean.Meta.MatchUtil
+import Lean.Util.ForEachExpr
+
+namespace Lean.Meta.Grind
+/-! A basic "equality resolution" procedure. -/
+
+/--
+Similar to `forallMetaTelescopeReducing`, but if `prop` resulting type is of the form `¬ p`, it will "convert" it so `p → False`, and
+will return a hypothesis for it and return `False` as the resulting type.
+-/
+private def forallMetaTelescopeReducingAndUnfoldingNot (prop : Expr) : MetaM (Array Expr × Expr) := do
+  let (ms, _, type) ← forallMetaTelescopeReducing prop
+  if let some p ← matchNot? type then
+    let m ← mkFreshExprMVar p
+    return (ms.push m, mkConst ``False)
+  return (ms, type)
+
+structure TopSort.State where
+  tempMark  : Std.HashSet Expr := {}
+  permMark  : Std.HashSet Expr := {}
+  result : Array Expr := #[]
+
+abbrev TopSortM := OptionT $ StateT TopSort.State MetaM
+
+/--
+Sorts metavariables `ms` using topological sort.
+There is an "edge" from `m₁` to `m₂` if type of `m₁` contains `m₂`.
+We use this function to ensure that after applying equality resolution to
+```
+∀ x : Nat, p x a → ∀ y : Nat, p y b → x = y → False
+```
+we produce
+```
+∀ y, p y a → p y b → False
+```
+instead of
+```
+p ?y a → ∀ y, p y b → False
+```
+Recall that in equality resolution we create a meta-variable for each hypothesis.
+Thus, we initially have
+```
+?x : Nat, ?h₁ : p ?x a, ?y : Nat, ?h₂ : p ?y b, ?h₃ : ?x = ?y
+```
+Then, we resolve `?h₃ : ?x = ?y` as `?y := ?x` and `?h₃ := Eq.refl ?y`.
+But `?h₁` occurs before `?y`. We use topological sort to address this situation.
+If a cycle is detected, it returns `none`.
+-/
+private partial def topsortMVars? (ms : Array Expr) : MetaM (Option (Array Expr)) := do
+  let (some _, s) ← go.run.run {} | return none
+  return some s.result
+where
+  go : TopSortM Unit := do
+    for m in ms do
+      visit m
+
+  visit (m : Expr) : TopSortM Unit := do
+    if (← get).permMark.contains m then
+      return ()
+    if (← get).tempMark.contains m then
+      failure
+    modify fun s => { s with tempMark := s.tempMark.insert m }
+    visitTypeOf m
+    modify fun s => { s with
+      result := s.result.push m
+      permMark := s.permMark.insert m
+    }
+
+  visitTypeOf (m : Expr) : TopSortM Unit := do
+    let type ← instantiateMVars (← inferType m)
+    type.forEach' fun e => do
+      if e.hasExprMVar then
+        if e.isMVar && ms.contains e then
+          visit e
+        return true
+      else
+        return false
+
+private def eqResCore (prop proof : Expr) : MetaM (Option (Expr × Expr)) := withNewMCtxDepth do
+  /-
+  We use `forallMetaTelescopeReducingAndUnfoldingNot` because we want to treat
+  ```
+  ∀ x, ¬ f x = f a
+  ```
+  as
+  ```
+  ∀ x, f x = f a → False
+  ```
+  recall that `¬` is not reducible.
+  -/
+  let (ms, type) ← forallMetaTelescopeReducingAndUnfoldingNot prop
+  if ms.isEmpty then return none
+  let mut progress := false
+  for m in ms do
+    let type ← inferType m
+    let_expr Eq _ lhs rhs ← type
+      | pure ()
+    if (← isDefEq lhs rhs) then
+      unless (← m.mvarId!.checkedAssign (← mkEqRefl lhs)) do
+        return none
+      progress := true
+  unless progress do
+    return none
+  if (← ms.anyM fun m => m.mvarId!.isDelayedAssigned) then
+    return none
+  let prop' ← instantiateMVars type
+  let proof' ← instantiateMVars (mkAppN proof ms)
+  let ms ← ms.filterM fun m => return !(← m.mvarId!.isAssigned)
+  let some ms ← topsortMVars? ms | return none
+  let prop' ← mkForallFVars ms prop' (binderInfoForMVars := .default)
+  let proof' ← mkLambdaFVars ms proof'
+  return some (prop', proof')
+
+/--
+A basic "equality resolution" procedure: Given a proposition `prop` with a proof `proof`, it attempts to resolve equality hypotheses using `isDefEq`. For example, it reduces `∀ x y, f x = f (g y y) → g x y = y` to `∀ y, g (g y y) y = y`, and `∀ (x : Nat), f x ≠ f a` to `False`.
+If successful, the result is a pair `(prop', proof)`, where `prop'` is the simplified proposition,
+and `proof : prop → prop'`
+-/
+def eqResolution (prop : Expr) : MetaM (Option (Expr × Expr)) :=
+  withLocalDeclD `h prop fun h => do
+    let some (prop', proof') ← eqResCore prop h
+      | return none
+    let proof' ← mkLambdaFVars #[h] proof'
+    return some (prop', proof')
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/ExprPtr.lean

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

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Ext.lean

@@ -0,0 +1,41 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+/-! Extensionality theorems support. -/
+
+def instantiateExtTheorem (thm : Ext.ExtTheorem) (e : Expr) : GoalM Unit := withNewMCtxDepth do
+  unless (← getGeneration e) < (← getMaxGeneration) do return ()
+  let c ← mkConstWithFreshMVarLevels thm.declName
+  let (mvars, bis, type) ← withDefault <| forallMetaTelescopeReducing (← inferType c)
+  unless (← isDefEq e type) do
+    reportIssue! "failed to apply extensionality theorem `{thm.declName}` for {indentExpr e}\nis not definitionally equal to{indentExpr type}"
+    return ()
+  -- Instantiate type class instances
+  for mvar in mvars, bi in bis do
+    if bi.isInstImplicit && !(← mvar.mvarId!.isAssigned) then
+      let type ← inferType mvar
+      unless (← synthesizeInstanceAndAssign mvar type) do
+        reportIssue! "failed to synthesize instance when instantiating extensionality theorem `{thm.declName}` for {indentExpr e}"
+        return ()
+  -- Remark: `proof c mvars` has type `e`
+  let proof ← instantiateMVars (mkAppN c mvars)
+  -- `e` is equal to `False`
+  let eEqFalse ← mkEqFalseProof e
+  -- So, we use `Eq.mp` to build a `proof` of `False`
+  let proof := mkApp4 (mkConst ``Eq.mp [levelZero]) e (← getFalseExpr) eEqFalse proof
+  let mvars ← mvars.filterM fun mvar => return !(← mvar.mvarId!.isAssigned)
+  let proof' ← instantiateMVars (← mkLambdaFVars mvars proof)
+  let prop' ← inferType proof'
+  if proof'.hasMVar || prop'.hasMVar then
+    reportIssue! "failed to apply extensionality theorem `{thm.declName}` for {indentExpr e}\nresulting terms contain metavariables"
+    return ()
+  trace[grind.ext] "{thm.declName}: {prop'}"
+  addNewRawFact proof' prop' ((← getGeneration e) + 1) (.ext thm.declName)
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/ExtAttr.lean

@@ -0,0 +1,44 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Tactic.Ext
+
+namespace Lean.Meta.Grind
+/-! Grind extensionality attribute to mark which `[ext]` theorems should be used. -/
+
+/-- Extensionality theorems that can be used by `grind` -/
+abbrev ExtTheorems := PHashSet Name
+
+builtin_initialize extTheoremsExt : SimpleScopedEnvExtension Name ExtTheorems ←
+  registerSimpleScopedEnvExtension {
+    initial        := {}
+    addEntry       := fun s declName => s.insert declName
+  }
+
+def validateExtAttr (declName : Name) : CoreM Unit := do
+  if !(← Ext.isExtTheorem declName) then
+  if !(isStructure (← getEnv) declName) then
+    throwError "invalid `[grind ext]`, `{declName}` is neither tagged with `[ext]` nor is a structure"
+
+def addExtAttr (declName : Name) (attrKind : AttributeKind) : CoreM Unit := do
+  validateExtAttr declName
+  extTheoremsExt.add declName attrKind
+
+private def eraseDecl (s : ExtTheorems) (declName : Name) : CoreM ExtTheorems := do
+  if s.contains declName then
+    return s.erase declName
+  else
+    throwError "`{declName}` is not marked with the `[grind ext]` attribute"
+
+def eraseExtAttr (declName : Name) : CoreM Unit := do
+  let s := extTheoremsExt.getState (← getEnv)
+  let s ← eraseDecl s declName
+  modifyEnv fun env => extTheoremsExt.modifyState env fun _ => s
+
+def isExtTheorem (declName : Name) : CoreM Bool := do
+  return extTheoremsExt.getState (← getEnv) |>.contains declName
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/ForallProp.lean

@@ -0,0 +1,126 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Grind.Lemmas
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Internalize
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.EqResolution
+
+namespace Lean.Meta.Grind
+/--
+If `parent` is a projection-application `proj_i c`,
+check whether the root of the equivalence class containing `c` is a constructor-application `ctor ... a_i ...`.
+If so, internalize the term `proj_i (ctor ... a_i ...)` and add the equality `proj_i (ctor ... a_i ...) = a_i`.
+-/
+def propagateForallPropUp (e : Expr) : GoalM Unit := do
+  let .forallE n p q bi := e | return ()
+  trace_goal[grind.debug.forallPropagator] "{e}"
+  if !q.hasLooseBVars then
+    propagateImpliesUp p q
+  else
+    unless (← isEqTrue p) do return
+    trace_goal[grind.debug.forallPropagator] "isEqTrue, {e}"
+    let h₁ ← mkEqTrueProof p
+    let qh₁ := q.instantiate1 (mkOfEqTrueCore p h₁)
+    let r ← preprocess qh₁
+    let q := mkLambda n bi p q
+    let q' := r.expr
+    internalize q' (← getGeneration e)
+    trace_goal[grind.debug.forallPropagator] "q': {q'} for{indentExpr e}"
+    let h₂ ← r.getProof
+    let h := mkApp5 (mkConst ``Lean.Grind.forall_propagator) p q q' h₁ h₂
+    pushEq e q' h
+where
+  propagateImpliesUp (a b : Expr) : GoalM Unit := do
+    unless (← alreadyInternalized b) do return ()
+    if (← isEqFalse a <&&> isProp b) then
+      -- a = False → (a → b) = True
+      pushEqTrue e <| mkApp3 (mkConst ``Grind.imp_eq_of_eq_false_left) a b (← mkEqFalseProof a)
+    else if (← isEqTrue a <&&> isProp b) then
+      -- a = True → (a → b) = b
+      pushEq e b <| mkApp3 (mkConst ``Grind.imp_eq_of_eq_true_left) a b (← mkEqTrueProof a)
+    else if (← isEqTrue b <&&> isProp a) then
+      -- b = True → (a → b) = True
+      pushEqTrue e <| mkApp3 (mkConst ``Grind.imp_eq_of_eq_true_right) a b (← mkEqTrueProof b)
+    else if (← isEqFalse b <&&> isEqTrue e <&&> isProp a) then
+      -- (a → b) = True → b = False → a = False
+      pushEqFalse a <| mkApp4 (mkConst ``Grind.eq_false_of_imp_eq_true) a b (← mkEqTrueProof e) (← mkEqFalseProof b)
+
+private def isEqTrueHyp? (proof : Expr) : Option FVarId := Id.run do
+  let_expr eq_true _ p := proof | return none
+  let .fvar fvarId := p | return none
+  return some fvarId
+
+/-- Similar to `mkEMatchTheoremWithKind?`, but swallow any exceptions. -/
+private def mkEMatchTheoremWithKind'? (origin : Origin) (proof : Expr) (kind : EMatchTheoremKind) (prios : SymbolPriorities) : MetaM (Option EMatchTheorem) := do
+  try
+    mkEMatchTheoremWithKind? origin #[] proof kind prios (groundPatterns := false)
+  catch _ =>
+    return none
+
+private def addLocalEMatchTheorems (e : Expr) : GoalM Unit := do
+  let proof ← mkEqTrueProof e
+  let origin ← if let some fvarId := isEqTrueHyp? proof then
+    pure <| .fvar fvarId
+  else
+    let idx ← modifyGet fun s => (s.ematch.nextThmIdx, { s with ematch.nextThmIdx := s.ematch.nextThmIdx + 1 })
+    pure <| .local ((`local).appendIndexAfter idx)
+  let proof := mkOfEqTrueCore e proof
+  let size := (← get).ematch.newThms.size
+  let gen ← getGeneration e
+  -- TODO: we should have a flag for collecting all unary patterns in a local theorem
+  if let some thm ← mkEMatchTheoremWithKind'? origin proof .leftRight (← getSymbolPriorities) then
+    activateTheorem thm gen
+  if let some thm ← mkEMatchTheoremWithKind'? origin proof .rightLeft (← getSymbolPriorities) then
+    activateTheorem thm gen
+  if (← get).ematch.newThms.size == size then
+    if let some thm ← mkEMatchTheoremWithKind'? origin proof (.default false) (← getSymbolPriorities) then
+      activateTheorem thm gen
+  if (← get).ematch.newThms.size == size then
+    reportIssue! "failed to create E-match local theorem for{indentExpr e}"
+
+def propagateForallPropDown (e : Expr) : GoalM Unit := do
+  let .forallE n a b bi := e | return ()
+  if (← isEqFalse e) then
+    if b.hasLooseBVars || !(← isProp a) then
+      let α := a
+      let p := b
+      -- `e` is of the form `∀ x : α, p x`
+      -- Add fact `∃ x : α, ¬ p x`
+      let u ← getLevel α
+      let prop := mkApp2 (mkConst ``Exists [u]) α (mkLambda n bi α (mkNot p))
+      let proof := mkApp3 (mkConst ``Grind.of_forall_eq_false [u]) α (mkLambda n bi α p) (← mkEqFalseProof e)
+      addNewRawFact proof prop (← getGeneration e) (.forallProp e)
+    else
+      let h ← mkEqFalseProof e
+      pushEqTrue a <| mkApp3 (mkConst ``Grind.eq_true_of_imp_eq_false) a b h
+      pushEqFalse b <| mkApp3 (mkConst ``Grind.eq_false_of_imp_eq_false) a b h
+  else if (← isEqTrue e) then
+    if let some (e', h') ← eqResolution e then
+      trace_goal[grind.eqResolution] "{e}, {e'}"
+      let h := mkOfEqTrueCore e (← mkEqTrueProof e)
+      let h' := mkApp h' h
+      addNewRawFact h' e' (← getGeneration e) (.forallProp e)
+    else
+      if b.hasLooseBVars then
+        addLocalEMatchTheorems e
+      else
+        unless (← alreadyInternalized b) do return ()
+        if (← isEqFalse b <&&> isProp a) then
+        -- (a → b) = True → b = False → a = False
+        pushEqFalse a <| mkApp4 (mkConst ``Grind.eq_false_of_imp_eq_true) a b (← mkEqTrueProof e) (← mkEqFalseProof b)
+
+builtin_grind_propagator propagateExistsDown ↓Exists := fun e => do
+  if (← isEqFalse e) then
+    let_expr f@Exists α p := e | return ()
+    let u := f.constLevels!
+    let notP := mkApp (mkConst ``Not) (mkApp p (.bvar 0) |>.headBeta)
+    let prop := mkForall `x .default α notP
+    let proof := mkApp3 (mkConst ``forall_not_of_not_exists u) α p (mkOfEqFalseCore e (← mkEqFalseProof e))
+    addNewRawFact proof prop (← getGeneration e) (.existsProp e)
+
+end Lean.Meta.Grind

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Meta/Tactic/Grind/Injection.lean

@@ -0,0 +1,39 @@
+/-
+Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.CtorRecognizer
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Clear
+
+namespace Lean.Meta.Grind
+/--
+The `grind` tactic includes an auxiliary `injection?` tactic that is not intended for direct use by users.
+This tactic is automatically applied when introducing non-dependent propositions.
+It differs from the user-facing Lean `injection` tactic in the following ways:
+
+- It does not introduce new propositions. Instead, the `grind` tactic preprocessor is responsible for introducing them.
+- It assumes that `fvarId` is the latest local declaration in the current goal.
+- It does not handle cases where the constructors are different because the simplifier already reduces such equalities to `False`.
+- It does not have support for heterogeneous equality. Recall that the simplifier already reduces them to `Eq` if
+  the types are definitionally equal.
+-/
+def injection? (mvarId : MVarId) (fvarId : FVarId) : MetaM (Option MVarId) := mvarId.withContext do
+  let decl ← fvarId.getDecl
+  let_expr Eq _ a b := decl.type | return none
+  match (← isConstructorAppCore? a), (← isConstructorAppCore? b) with
+  | some aCtor, some bCtor =>
+    if aCtor.name != bCtor.name then return none -- Simplifier handles this case
+    let target ← mvarId.getType
+    let val ← mkNoConfusion target (mkFVar fvarId)
+    let .forallE _ targetNew _ _ ← whnfD (← inferType val) | return none
+    let targetNew := targetNew.headBeta
+    let tag ← mvarId.getTag
+    let mvarNew ← mkFreshExprSyntheticOpaqueMVar targetNew tag
+    mvarId.assign (mkApp val mvarNew)
+    return some (← mvarNew.mvarId!.clear fvarId)
+  | _, _ => return none
+
+end Lean.Meta.Grind