import ..lectures.love05_inductive_predicates_demo

/-! # LoVe Demo 7: Metaprogramming

Note for Brown FPV students: we are not following this demo directly!
But I'm posting it because some definitions in here are used in the exercises.
 --Rob

Users can extend Lean with custom tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself. Abstract syntax trees __reflect__ internal data
structures, e.g., for expressions (terms). The prover's C++ internals are
exposed through Lean interfaces, which we can use for

* accessing the current context and goal;
* unifying expressions;
* querying and modifying the environment;
* setting attributes.

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Tactics and Tactic Combinators

When programming our own tactics, we often need to repeat some actions on
several goals, or to recover if a tactic fails. Tactic combinators help in such
case.

`repeat` applies its argument repeatedly on all (sub…sub)goals until it cannot
be applied any further. -/

lemma repeat_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat { apply even.add_two },
  repeat { sorry }
end

/-! The "orelse" combinator `<|>` tries its first argument and applies its
second argument in case of failure. -/

lemma repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/-! `iterate` works repeatedly on the first goal until it fails; then it
stops. -/

lemma iterate_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  iterate {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/-! `all_goals` applies its argument exactly once to each goal. It succeeds only
if the argument succeeds on **all** goals. -/

lemma all_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { apply even.add_two },   -- fails
  repeat { sorry }
end

/-! `try` transforms its argument into a tactic that never fails. -/

lemma all_goals_try_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { try { apply even.add_two } },
  repeat { sorry }
end

/-! `any_goals` applies its argument exactly once to each goal. It succeeds
if the argument succeeds on **any** goal. -/

lemma any_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { apply even.add_two },
  repeat { sorry }
end

/-! `solve1` transforms its argument into an all-or-nothing tactic. If the
argument does not prove the goal, `solve1` fails. -/

lemma any_goals_solve1_repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { solve1 { repeat {
    apply even.add_two
    <|> apply even.zero } } },
  repeat { sorry }
end

/-! The combinators `repeat`, `iterate`, `all_goals`, and `any_goals` can easily
lead to infinite looping: -/

/-
lemma repeat_not_example :
  ¬ even 1 :=
begin
  repeat { apply not.intro },
  sorry
end
-/

/-! Let us start with the actual metaprogramming, by coding a custom tactic. The
tactic embodies the behavior we hardcoded in the `solve1` example above: -/

meta def intro_and_even : tactic unit :=
do
  tactic.repeat (tactic.applyc ``and.intro),
  tactic.any_goals (tactic.solve1 (tactic.repeat
    (tactic.applyc ``even.add_two
     <|> tactic.applyc ``even.zero))),
  pure ()

/-! The `meta` keyword makes it possible for the function to call other
metafunctions. The `do` keyword enters a monad, and the `<|>` operator is the
"orelse" operator of alternative monads. At the end, we return `()`, of type
`unit`, to ensure the metaprogram has the desired type.

Any executable Lean definition can be used as a metaprogram. In addition, we can
put `meta` in front of a definition to indicate that is a metadefinition. Such
definitions need not terminate but cannot be used in non-`meta` contexts.

Let us apply our custom tactic: -/

lemma any_goals_solve1_repeat_orelse_example₂ :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  intro_and_even,
  repeat { sorry }
end

/-! ## The Metaprogramming Monad

Tactics have access to

* the list of **goals** as metavariables (each metavariables has a type and a
  local context (hypothesis); they can optionally be instantiated);

* the **elaborator** (to elaborate expressions and compute their type);

* the **environment**, containing all declarations and inductive types;

* the **attributes** (e.g., the list of `@[simp]` rules).

The tactic monad is an alternative monad, with `fail` and `<|>`. Tactics can
also produce trace messages. -/

lemma even_14 :
  even 14 :=
by do
  tactic.trace "Proving evenness …",
  intro_and_even

meta def hello_then_intro_and_even : tactic unit :=
do
  tactic.trace "Proving evenness …",
  intro_and_even

lemma even_16 :
  even 16 :=
by hello_then_intro_and_even

run_cmd tactic.trace "Hello, Metaworld!"

meta def trace_goals : tactic unit :=
do
  tactic.trace "local context:",
  ctx ← tactic.local_context,
  tactic.trace ctx,
  tactic.trace "target:",
  P ← tactic.target,
  tactic.trace P,
  tactic.trace "all missing proofs:",
  Hs ← tactic.get_goals,
  tactic.trace Hs,
  τs ← list.mmap tactic.infer_type Hs,
  tactic.trace τs

lemma even_18_and_even_20 (α : Type) (a : α) :
  even 18 ∧ even 20 :=
by do
  tactic.applyc ``and.intro,
  trace_goals,
  intro_and_even

lemma triv_imp (a : Prop) (h : a) :
  a :=
by do
  h ← tactic.get_local `h,
  tactic.trace "h:",
  tactic.trace h,
  tactic.trace "raw h:",
  tactic.trace (expr.to_raw_fmt h),
  tactic.trace "type of h:",
  τ ← tactic.infer_type h,
  tactic.trace τ,
  tactic.trace "type of type of h:",
  υ ← tactic.infer_type τ,
  tactic.trace υ,
  tactic.apply h

meta def exact_list : list expr → tactic unit
| []        := tactic.fail "no matching expression found"
| (h :: hs) :=
  do {
    tactic.trace "trying",
    tactic.trace h,
    tactic.exact h }
  <|> exact_list hs

meta def hypothesis : tactic unit :=
do
  hs ← tactic.local_context,
  exact_list hs

lemma app_of_app {α : Type} {p : α → Prop} {a : α}
    (h : p a) :
  p a :=
by hypothesis

/-! ## Names, Expressions, Declarations, and Environments

The metaprogramming framework is articulated around five main types:

* `tactic` manages the proof state, the global context, and more;

* `name` represents a structured name (e.g., `x`, `even.add_two`);

* `expr` represents an expression (a term) as an abstract syntax tree;

* `declaration` represents a constant declaration, a definition, an axiom, or a
  lemma;

* `environment` stores all the declarations and notations that make up the
  global context. -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)
#check expr.sort level.zero  -- Sort 0, i.e., Prop
#check expr.sort (level.succ level.zero)
  -- Sort 1, i.e., Type
#check expr.var 0  -- bound variable with De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default
  `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ)
  (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ)
  (expr.var 0) : expr)
#check expr.elet
#check expr.macro

/-! We can create literal expressions conveniently using backticks and
parentheses:

* Expressions with a single backtick must be fully elaborated.

* Expressions with two backticks are __pre-expressions__: They may contain some
  holes to be filled in later, based on some context.

* Expressions with three backticks are pre-expressions without name checking. -/

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  tactic.trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),   -- fails
  tactic.trace e

run_cmd do
  let e₁ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₂ : pexpr := ``(list.map _ [1, 2, 3]),
  tactic.trace e₁,
  tactic.trace e₂

run_cmd do
  let e : pexpr := ```(seattle.washington),
  tactic.trace e

/-! We can also create literal names with backticks:

* Names with a single backtick, `n, are not checked for existence.

* Names with two backticks, ``n, are resolved and checked. -/

run_cmd tactic.trace `and.intro
run_cmd tactic.trace `intro_and_even
run_cmd tactic.trace `seattle.washington

run_cmd tactic.trace ``and.intro
run_cmd tactic.trace ``intro_and_even
run_cmd tactic.trace ``seattle.washington   -- fails

/-! __Antiquotations__ embed an existing expression in a larger expression. They
are announced by the prefix `%%` followed by a name from the current context.
Antiquotations are available with one, two, and three backticks: -/

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ``(list.map %%x),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ```(a _ %%x),
  tactic.trace e

lemma one_add_two_eq_three :
  1 + 2 = 3 :=
by do
  `(%%a + %%b = %%c) ← tactic.target,
  tactic.trace a,
  tactic.trace b,
  tactic.trace c,
  `(@eq %%α %%l %%r) ← tactic.target,
  tactic.trace α,
  tactic.trace l,
  tactic.trace r,
  tactic.exact `(refl _ : 3 = 3)

#print declaration

/-! The `environment` type is presented as an abstract type, equipped with some
operations to query and modify it. The `environment.fold` metafunction iterates
over all declarations making up the environment. -/

run_cmd do
  env ← tactic.get_env,
  tactic.trace (environment.fold env 0 (λdecl n, n + 1))

/-! ## First Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/-! Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/-! Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/-! ## Second Example: A Provability Advisor

Next, we implement a `prove_direct` tool that traverses all lemmas in the
database and checks whether one of them can be used to prove the current goal. A
similar tactic is available in `mathlib` under the name `library_search`. -/

meta def is_theorem : declaration → bool
| (declaration.defn _ _ _ _ _ _) := ff
| (declaration.thm _ _ _ _)      := tt
| (declaration.cnst _ _ _ _)     := ff
| (declaration.ax _ _ _)         := tt

meta def get_all_theorems : tactic (list name) :=
do
  env ← tactic.get_env,
  pure (environment.fold env [] (λdecl nams,
    if is_theorem decl then declaration.to_name decl :: nams
    else nams))

meta def prove_with_name (nam : name) : tactic unit :=
do
  tactic.applyc nam
    ({ md := tactic.transparency.reducible, unify := ff }
     : tactic.apply_cfg),
  tactic.all_goals tactic.assumption,
  pure ()

meta def prove_direct : tactic unit :=
do
  nams ← get_all_theorems,
  list.mfirst (λnam,
      do
        prove_with_name nam,
        tactic.trace ("directly proved by " ++ to_string nam))
    nams

lemma nat.eq_symm (x y : ℕ) (h : x = y) :
  y = x :=
by prove_direct

lemma nat.eq_symm₂ (x y : ℕ) (h : x = y) :
  y = x :=
by library_search

lemma list.reverse_twice (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct

lemma list.reverse_twice_symm (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct   -- fails

/-! As a small refinement, we propose a version of `prove_direct` that also
looks for equalities stated in symmetric form. -/

meta def prove_direct_symm : tactic unit :=
prove_direct
<|>
do {
  tactic.applyc `eq.symm,
  prove_direct }

lemma list.reverse_twice₂ (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct_symm

lemma list.reverse_twice_symm₂ (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct_symm

/-! ## A Look at Two Predefined Tactics

Quite a few of Lean's predefined tactics are implemented as metaprograms and
not in C++. We can find these definitions by clicking the name of a construct
in Visual Studio Code while holding the control or command key. -/

#check tactic.intro
#check tactic.assumption

end LoVe


/-
Copyright (c) 2023 Thomas Murrills. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Murrills
-/
import Lean

/-!
# Fail if no progress

This implements the `fail_if_no_progress` tactic, which fails if no actual progress is made by the
following tactic sequence.

"Actual progress" means that either the number of goals has changed, that the
number or presence of expressions in the context has changed, or that the type of some expression
in the context or the type of the goal is no longer definitionally equal to what it used to be at
reducible transparency.

This means that, for example, `1 - 1` changing to `0` does not count as actual progress, since
```lean
example : (1 - 1 = 0) := by with_reducible rfl
```

This tactic is useful in situations where we want to stop iterating some tactics if they're not
having any  effect, e.g. `repeat (fail_if_no_progress simp <;> ring_nf)`.

-/

namespace Mathlib.Tactic

open Lean Meta Elab Tactic

/-- `fail_if_no_progress tacs` evaluates `tacs`, and fails if no progress is made on the main goal
or the local context at reducible transparency. -/
syntax (name := failIfNoProgress ) "fail_if_no_progress " tacticSeq : tactic

/-- `lctxIsDefEq l₁ l₂` compares two lists of `Option LocalDecl`s (as returned from e.g.
`(← (← getMainGoal).getDecl).lctx.decls.toList`). It returns `true` if they contain expressions of
the same type in the same order (up to defeq), and `false` otherwise. -/
def lctxIsDefEq : (l₁ l₂ : List (Option LocalDecl)) → MetaM Bool
  | some d₁ :: l₁, some d₂ :: l₂ => do
    unless (← withNewMCtxDepth <| isDefEq d₁.type d₂.type) do
      return false
    lctxIsDefEq l₁ l₂
  | none :: l₁, none :: l₂ => lctxIsDefEq l₁ l₂
  | [], [] => return true
  | _, _ => return false

/-- Run `tacs : TacticM Unit` on `goal`, and fail if no progress is made. -/
def runAndFailIfNoProgress (goal : MVarId) (tacs : TacticM Unit) : TacticM (List MVarId) := do
  let l ← run goal tacs
  try
    let [newGoal] := l | failure
    guard <|← withNewMCtxDepth <| withReducible <| isDefEq (← newGoal.getType) (← goal.getType)
    let ctxDecls := (← goal.getDecl).lctx.decls.toList
    let newCtxDecls := (← newGoal.getDecl).lctx.decls.toList
    guard <|← withNewMCtxDepth <| withReducible <| lctxIsDefEq ctxDecls newCtxDecls
  catch _ =>
    return l
  throwError "no progress made on {goal}"

elab_rules : tactic
| `(tactic| fail_if_no_progress $tacs) => do
  let goal ← getMainGoal
  let l ← runAndFailIfNoProgress goal (evalTactic tacs)
  replaceMainGoal l


macro "expensive_tactic" : tactic => `(sleep 5000)

example (h₁ : x = y) (h₂ : y = z) : z = x := by
  expensive_tactic
  save
  have : y = x := h₁.symm
  have : z = y := h₂.symm
  trace "hello world"
  apply this.trans
  exact ‹y = x›

example (h₁ : p ∨ q) (h₂ : p → x = 0) (h₃ : q → y = 0) : x * y = 0 := by
  expensive_tactic
  save
  match h₁ with
  | .inr h =>
    expensive_tactic
    save
    have : y = 0 := h₃ h
    simp [*]
  | .inl h => stop done

example (h₁ : p ∨ q) (h₂ : p → x = 0) (h₃ : q → y = 0) : x * y = 0 := by
  expensive_tactic
  save
  cases h₁ with
  | inr h =>
    expensive_tactic
    save
    have : y = 0 := h₃ h
    simp [*]
  | inl h => stop
    expensive_tactic
    save
    have : x = 0 := h₂ h
    simp [*]
    done


example [Subsingleton α] (p : α → Prop) : Subsingleton (Subtype p) :=
  ⟨fun ⟨x, _⟩ ⟨y, _⟩ => Subsingleton.elim x y ▸ sorry⟩


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.string.basic
! leanprover-community/mathlib commit 4a03bdeb31b3688c31d02d7ff8e0ff2e5d6174db
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.List.Basic
import Leanbin.Init.Data.Char.Basic

/-- In the VM, strings are implemented using a dynamic array and UTF-8 encoding.

   TODO: we currently cannot mark string_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/
structure StringImp where
  data : List Char
#align string_imp StringImp

#print String /-
def String :=
  StringImp
#align string String
-/

#print List.asString /-
def List.asString (s : List Char) : String :=
  ⟨s⟩
#align list.as_string List.asString
-/

namespace String

instance : LT String :=
  ⟨fun s₁ s₂ => s₁.data < s₂.data⟩

/-- Remark: this function has a VM builtin efficient implementation. -/
instance hasDecidableLt (s₁ s₂ : String) : Decidable (s₁ < s₂) :=
  List.hasDecidableLt s₁.data s₂.data
#align string.has_decidable_lt String.hasDecidableLt

instance hasDecidableEq : DecidableEq String := fun ⟨x⟩ ⟨y⟩ =>
  match List.hasDecEq x y with
  | is_true p => isTrue (congr_arg StringImp.mk p)
  | is_false p => isFalse fun q => p (StringImp.mk.inj q)
#align string.has_decidable_eq String.hasDecidableEq

def empty : String :=
  ⟨[]⟩
#align string.empty String.empty

#print String.length /-
def length : String → Nat
  | ⟨s⟩ => s.length
#align string.length String.length
-/

#print String.push /-
/-- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/
def push : String → Char → String
  | ⟨s⟩, c => ⟨s ++ [c]⟩
#align string.push String.push
-/

#print String.append /-
/-- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/
def append : String → String → String
  | ⟨a⟩, ⟨b⟩ => ⟨a ++ b⟩
#align string.append String.append
-/

#print String.toList /-
/-- O(n) in the VM, where n is the length of the string -/
def toList : String → List Char
  | ⟨s⟩ => s
#align string.to_list String.toList
-/

def fold {α} (a : α) (f : α → Char → α) (s : String) : α :=
  s.toList.foldl f a
#align string.fold String.fold

/-- In the VM, the string iterator is implemented as a pointer to the string being iterated + index.

   TODO: we currently cannot mark interator_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/
structure IteratorImp where
  fst : List Char
  snd : List Char
#align string.iterator_imp String.IteratorImp

#print String.Iterator /-
def Iterator :=
  IteratorImp
#align string.iterator String.Iterator
-/

#print String.mkIterator /-
def mkIterator : String → Iterator
  | ⟨s⟩ => ⟨[], s⟩
#align string.mk_iterator String.mkIterator
-/

namespace Iterator

#print String.Iterator.curr /-
def curr : Iterator → Char
  | ⟨p, c :: n⟩ => c
  | _ => default
#align string.iterator.curr String.Iterator.curr
-/

#print String.Iterator.setCurr /-
/--
In the VM, `set_curr` is constant time if the string being iterated is not shared and linear time
   if it is. -/
def setCurr : Iterator → Char → Iterator
  | ⟨p, c :: n⟩, c' => ⟨p, c' :: n⟩
  | it, c' => it
#align string.iterator.set_curr String.Iterator.setCurr
-/

#print String.Iterator.next /-
def next : Iterator → Iterator
  | ⟨p, c :: n⟩ => ⟨c :: p, n⟩
  | ⟨p, []⟩ => ⟨p, []⟩
#align string.iterator.next String.Iterator.next
-/

#print String.Iterator.prev /-
def prev : Iterator → Iterator
  | ⟨c :: p, n⟩ => ⟨p, c :: n⟩
  | ⟨[], n⟩ => ⟨[], n⟩
#align string.iterator.prev String.Iterator.prev
-/

#print String.Iterator.hasNext /-
def hasNext : Iterator → Bool
  | ⟨p, []⟩ => false
  | _ => true
#align string.iterator.has_next String.Iterator.hasNext
-/

#print String.Iterator.hasPrev /-
def hasPrev : Iterator → Bool
  | ⟨[], n⟩ => false
  | _ => true
#align string.iterator.has_prev String.Iterator.hasPrev
-/

def insert : Iterator → String → Iterator
  | ⟨p, n⟩, ⟨s⟩ => ⟨p, s ++ n⟩
#align string.iterator.insert String.Iterator.insert

def remove : Iterator → Nat → Iterator
  | ⟨p, n⟩, m => ⟨p, n.drop m⟩
#align string.iterator.remove String.Iterator.remove

#print String.Iterator.toString /-
/-- In the VM, `to_string` is a constant time operation. -/
def toString : Iterator → String
  | ⟨p, n⟩ => ⟨p.reverse ++ n⟩
#align string.iterator.to_string String.Iterator.toString
-/

#print String.Iterator.toEnd /-
def toEnd : Iterator → Iterator
  | ⟨p, n⟩ => ⟨n.reverse ++ p, []⟩
#align string.iterator.to_end String.Iterator.toEnd
-/

def nextToString : Iterator → String
  | ⟨p, n⟩ => ⟨n⟩
#align string.iterator.next_to_string String.Iterator.nextToString

def prevToString : Iterator → String
  | ⟨p, n⟩ => ⟨p.reverse⟩
#align string.iterator.prev_to_string String.Iterator.prevToString

protected def extractCore : List Char → List Char → Option (List Char)
  | [], cs => none
  | c :: cs₁, cs₂ =>
    if cs₁ = cs₂ then some [c]
    else
      match extract_core cs₁ cs₂ with
      | none => none
      | some r => some (c :: r)
#align string.iterator.extract_core String.Iterator.extractCore

/- warning: string.iterator.extract -> String.Iterator.extract is a dubious translation:
lean 3 declaration is
  String.Iterator -> String.Iterator -> (Option.{0} String)
but is expected to have type
  String.Iterator -> String.Iterator -> String
Case conversion may be inaccurate. Consider using '#align string.iterator.extract String.Iterator.extractₓ'. -/
def extract : Iterator → Iterator → Option String
  | ⟨p₁, n₁⟩, ⟨p₂, n₂⟩ =>
    if p₁.reverse ++ n₁ ≠ p₂.reverse ++ n₂ then none
    else
      if n₁ = n₂ then some ""
      else
        match Iterator.extractCore n₁ n₂ with
        | none => none
        | some r => some ⟨r⟩
#align string.iterator.extract String.Iterator.extract

end Iterator

end String

/-! The following definitions do not have builtin support in the VM -/

instance : Inhabited String :=
  ⟨String.empty⟩

instance : SizeOf String :=
  ⟨String.length⟩

instance : Append String :=
  ⟨String.append⟩

namespace String

#print String.str /-
def str : String → Char → String :=
  push
#align string.str String.str
-/

#print String.isEmpty /-
def isEmpty (s : String) : Bool :=
  decide (s.length = 0)
#align string.is_empty String.isEmpty
-/

#print String.front /-
def front (s : String) : Char :=
  s.mkIterator.curr
#align string.front String.front
-/

#print String.back /-
def back (s : String) : Char :=
  s.mkIterator.toEnd.prev.curr
#align string.back String.back
-/

#print String.join /-
def join (l : List String) : String :=
  l.foldl (fun r s => r ++ s) ""
#align string.join String.join
-/

#print String.singleton /-
def singleton (c : Char) : String :=
  empty.push c
#align string.singleton String.singleton
-/

#print String.intercalate /-
def intercalate (s : String) (ss : List String) : String :=
  (List.intercalate s.toList (ss.map toList)).asString
#align string.intercalate String.intercalate
-/

namespace Iterator

#print String.Iterator.nextn /-
def nextn : Iterator → Nat → Iterator
  | it, 0 => it
  | it, i + 1 => nextn it.next i
#align string.iterator.nextn String.Iterator.nextn
-/

#print String.Iterator.prevn /-
def prevn : Iterator → Nat → Iterator
  | it, 0 => it
  | it, i + 1 => prevn it.prev i
#align string.iterator.prevn String.Iterator.prevn
-/

end Iterator

def popBack (s : String) : String :=
  s.mkIterator.toEnd.prev.prevToString
#align string.pop_back String.popBack

def popnBack (s : String) (n : Nat) : String :=
  (s.mkIterator.toEnd.prevn n).prevToString
#align string.popn_back String.popnBack

def backn (s : String) (n : Nat) : String :=
  (s.mkIterator.toEnd.prevn n).nextToString
#align string.backn String.backn

end String

#print Char.toString /-
protected def Char.toString (c : Char) : String :=
  String.singleton c
#align char.to_string Char.toString
-/

private def to_nat_core : String.Iterator → Nat → Nat → Nat
  | it, 0, r => r
  | it, i + 1, r =>
    let c := it.curr
    let r := r * 10 + c.toNat - '0'.toNat
    to_nat_core it.next i r
#align to_nat_core to_nat_core

def String.toNat (s : String) : Nat :=
  toNatCore s.mkIterator s.length 0
#align string.to_nat String.toNat

namespace String

private theorem nil_ne_append_singleton : ∀ (c : Char) (l : List Char), [] ≠ l ++ [c]
  | c, [] => fun h => List.noConfusion h
  | c, d :: l => fun h => List.noConfusion h
#align string.nil_ne_append_singleton string.nil_ne_append_singleton

theorem empty_ne_str : ∀ (c : Char) (s : String), empty ≠ str s c
  | c, ⟨l⟩ => fun h : StringImp.mk [] = StringImp.mk (l ++ [c]) =>
    StringImp.noConfusion h fun h => nil_ne_append_singleton _ _ h
#align string.empty_ne_str String.empty_ne_str

theorem str_ne_empty (c : Char) (s : String) : str s c ≠ empty :=
  (empty_ne_str c s).symm
#align string.str_ne_empty String.str_ne_empty

private theorem str_ne_str_left_aux :
    ∀ {c₁ c₂ : Char} (l₁ l₂ : List Char), c₁ ≠ c₂ → l₁ ++ [c₁] ≠ l₂ ++ [c₂]
  | c₁, c₂, [], [], h₁, h₂ => List.noConfusion h₂ fun h _ => absurd h h₁
  | c₁, c₂, d₁ :: l₁, [], h₁, h₂ =>
    have : d₁ :: (l₁ ++ [c₁]) = [c₂] := h₂
    have : l₁ ++ [c₁] = [] := List.noConfusion this fun _ h => h
    absurd this.symm (nil_ne_append_singleton _ _)
  | c₁, c₂, [], d₂ :: l₂, h₁, h₂ =>
    have : [c₁] = d₂ :: (l₂ ++ [c₂]) := h₂
    have : [] = l₂ ++ [c₂] := List.noConfusion this fun _ h => h
    absurd this (nil_ne_append_singleton _ _)
  | c₁, c₂, d₁ :: l₁, d₂ :: l₂, h₁, h₂ =>
    have : d₁ :: (l₁ ++ [c₁]) = d₂ :: (l₂ ++ [c₂]) := h₂
    have : l₁ ++ [c₁] = l₂ ++ [c₂] := List.noConfusion this fun _ h => h
    absurd this (str_ne_str_left_aux l₁ l₂ h₁)
#align string.str_ne_str_left_aux string.str_ne_str_left_aux

theorem str_ne_str_left : ∀ {c₁ c₂ : Char} (s₁ s₂ : String), c₁ ≠ c₂ → str s₁ c₁ ≠ str s₂ c₂
  | c₁, c₂, StringImp.mk l₁, StringImp.mk l₂, h₁, h₂ =>
    have : l₁ ++ [c₁] = l₂ ++ [c₂] := StringImp.noConfusion h₂ id
    absurd this (str_ne_str_left_aux l₁ l₂ h₁)
#align string.str_ne_str_left String.str_ne_str_left

private theorem str_ne_str_right_aux :
    ∀ (c₁ c₂ : Char) {l₁ l₂ : List Char}, l₁ ≠ l₂ → l₁ ++ [c₁] ≠ l₂ ++ [c₂]
  | c₁, c₂, [], [], h₁, h₂ => absurd rfl h₁
  | c₁, c₂, d₁ :: l₁, [], h₁, h₂ =>
    have : d₁ :: (l₁ ++ [c₁]) = [c₂] := h₂
    have : l₁ ++ [c₁] = [] := List.noConfusion this fun _ h => h
    absurd this.symm (nil_ne_append_singleton _ _)
  | c₁, c₂, [], d₂ :: l₂, h₁, h₂ =>
    have : [c₁] = d₂ :: (l₂ ++ [c₂]) := h₂
    have : [] = l₂ ++ [c₂] := List.noConfusion this fun _ h => h
    absurd this (nil_ne_append_singleton _ _)
  | c₁, c₂, d₁ :: l₁, d₂ :: l₂, h₁, h₂ =>
    have aux₁ : d₁ :: (l₁ ++ [c₁]) = d₂ :: (l₂ ++ [c₂]) := h₂
    have : d₁ = d₂ := List.noConfusion aux₁ fun h _ => h
    have aux₂ : l₁ ≠ l₂ := fun h =>
      have : d₁ :: l₁ = d₂ :: l₂ := Eq.subst h (Eq.subst this rfl)
      absurd this h₁
    have : l₁ ++ [c₁] = l₂ ++ [c₂] := List.noConfusion aux₁ fun _ h => h
    absurd this (str_ne_str_right_aux c₁ c₂ aux₂)
#align string.str_ne_str_right_aux string.str_ne_str_right_aux

theorem str_ne_str_right : ∀ (c₁ c₂ : Char) {s₁ s₂ : String}, s₁ ≠ s₂ → str s₁ c₁ ≠ str s₂ c₂
  | c₁, c₂, StringImp.mk l₁, StringImp.mk l₂, h₁, h₂ =>
    have aux : l₁ ≠ l₂ := fun h =>
      have : StringImp.mk l₁ = StringImp.mk l₂ := Eq.subst h rfl
      absurd this h₁
    have : l₁ ++ [c₁] = l₂ ++ [c₂] := StringImp.noConfusion h₂ id
    absurd this (str_ne_str_right_aux c₁ c₂ aux)
#align string.str_ne_str_right String.str_ne_str_right

end String


/-
Copyright (c) 2019-2022 by Microsoft Corporation and the authors listed in the file AUTHORS
and their institutional affiliations. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Wojciech Nawrocki
-/
import Lean.ToExpr
import Lean.AuxRecursor
import Lean.ProjFns
import Lean.Structure
import Lean.Util.Recognizers
import Lean.Meta.WHNF
import Lean.Meta.Basic
import Lean.Meta.GetConst
import Lean.Meta.Match.MatcherInfo
import Lean.Meta.Match.MatchPatternAttr
import Lean.Meta.FunInfo
import Lean.Util.MonadCache

import Smt.Tactic.WHNFConfigurableRef

namespace Lean.Meta

/-- Use a fresh name if this one is already in the local context. While Lean seems to handle
shadowing correctly, external tools don't always do so. -/
def bumpNameIfUsed (nm : Name) : MetaM Name :=
  return (← getLCtx).getUnusedName nm

partial def letTelescopeAbstractingAux (fvars : Array Expr) (abs : Expr → MetaM Expr)
    (k : Array Expr → Expr → (Expr → MetaM Expr) → MetaM α)
    : Expr → MetaM α
  | Expr.letE nm t v b nonDep => do
    let nm ← bumpNameIfUsed nm
    withLocalDeclD nm t fun x =>
      letTelescopeAbstractingAux
        (fvars.push x)
        (fun e' => abs (Expr.letE nm t v (e'.abstract #[x]) nonDep))
        k
        (b.instantiate1 x)
  | Expr.mdata md e@(Expr.letE ..) =>
    letTelescopeAbstractingAux fvars (fun e' => abs (Expr.mdata md e')) k e
  | e => k fvars e abs

@[inline] def map3MetaM [MonadControlT MetaM m] [Monad m]
    (f : forall {α}, (β → γ → δ → MetaM α) → MetaM α)
    {α} (k : β → γ → δ → m α)
    : m α :=
  controlAt MetaM fun runInBase => f fun b c d => runInBase <| k b c d

/-- Like `lambdaTelescope` but just for `let` bindings, and the continuation is given an abstraction
function which it can use to reintroduce all the surrounding `let` bindings. The `let` bindings are
defined as `cdecl`s, i.e. their values are not exposed in the local context.

Unlike `lambdaTelescope` followed by `mkLetFVars`, this preserves `mdata` stored on `let` bindings. -/
def letTelescopeAbstracting [MonadControlT MetaM n] [Monad n] {α : Type} (e : Expr)
    (k : Array Expr → Expr → (Expr → MetaM Expr) → n α) : n α :=
  map3MetaM (fun k => letTelescopeAbstractingAux #[] pure k e) k

end Lean.Meta

namespace Smt

open Lean Meta

/- ===========================
   Smart unfolding support
   =========================== -/

def smartUnfoldingSuffix := "_sunfold"

@[inline] def mkSmartUnfoldingNameFor (declName : Name) : Name :=
  Name.mkStr declName smartUnfoldingSuffix

def hasSmartUnfoldingDecl (env : Environment) (declName : Name) : Bool :=
  env.contains (mkSmartUnfoldingNameFor declName)

/-- Add auxiliary annotation to indicate the `match`-expression `e` must be reduced when performing smart unfolding. -/
def markSmartUnfoldingMatch (e : Expr) : Expr :=
  mkAnnotation `sunfoldMatch e

def smartUnfoldingMatch? (e : Expr) : Option Expr :=
  annotation? `sunfoldMatch e

/-- Add auxiliary annotation to indicate expression `e` (a `match` alternative rhs) was successfully reduced by smart unfolding. -/
def markSmartUnfoldingMatchAlt (e : Expr) : Expr :=
  mkAnnotation `sunfoldMatchAlt e

def smartUnfoldingMatchAlt? (e : Expr) : Option Expr :=
  annotation? `sunfoldMatchAlt e

/- ===========================
   Helper methods
   =========================== -/
def isAuxDef (constName : Name) : MetaM Bool := do
  let env ← getEnv
  return isAuxRecursor env constName || isNoConfusion env constName

@[inline] private def matchConstAux {α} (e : Expr) (failK : Unit → ReductionM α) (k : ConstantInfo → List Level → ReductionM α) : ReductionM α :=
  match e with
  | Expr.const name lvls => do
    let (some cinfo) ← getConst? name | failK ()
    k cinfo lvls
  | _ => failK ()

/- ===========================
   Helper functions for reducing recursors
   =========================== -/

private def getFirstCtor (d : Name) : MetaM (Option Name) := do
  let some (ConstantInfo.inductInfo { ctors := ctor::_, ..}) ← getConstNoEx? d | pure none
  return some ctor

private def mkNullaryCtor (type : Expr) (nparams : Nat) : MetaM (Option Expr) := do
  match type.getAppFn with
  | Expr.const d lvls =>
    let (some ctor) ← getFirstCtor d | pure none
    return mkAppN (mkConst ctor lvls) (type.getAppArgs.shrink nparams)
  | _ =>
    return none

def toCtorIfLit : Expr → Expr
  | Expr.lit (Literal.natVal v) =>
    if v == 0 then mkConst `Nat.zero
    else mkApp (mkConst `Nat.succ) (mkRawNatLit (v-1))
  | Expr.lit (Literal.strVal v) =>
    mkApp (mkConst `String.mk) (toExpr v.toList)
  | e => e

private def getRecRuleFor (recVal : RecursorVal) (major : Expr) : Option RecursorRule :=
  match major.getAppFn with
  | Expr.const fn _ => recVal.rules.find? fun r => r.ctor == fn
  | _               => none

private def toCtorWhenK (recVal : RecursorVal) (major : Expr) : ReductionM Expr := do
  let majorType ← inferType major
  let majorType ← instantiateMVars (← whnf majorType)
  let majorTypeI := majorType.getAppFn
  if !majorTypeI.isConstOf recVal.getInduct then
    return major
  else if majorType.hasExprMVar && majorType.getAppArgs[recVal.numParams:].any Expr.hasExprMVar then
    return major
  else do
    let (some newCtorApp) ← mkNullaryCtor majorType recVal.numParams | pure major
    let newType ← inferType newCtorApp
    /- TODO: check whether changing reducibility to default hurts performance here.
       We do that to make sure auxiliary `Eq.rec` introduced by the `match`-compiler
       are reduced even when `TransparencyMode.reducible` (like in `simp`).

       We use `withNewMCtxDepth` to make sure metavariables at `majorType` are not assigned.
       For example, given `major : Eq ?x y`, we don't want to apply K by assigning `?x := y`.
    -/
    if (← withAtLeastTransparency TransparencyMode.default <| withNewMCtxDepth <| isDefEq majorType newType) then
      return newCtorApp
    else
      return major

/--
  Create the `i`th projection `major`. It tries to use the auto-generated projection functions if available. Otherwise falls back
  to `Expr.proj`.
-/
def mkProjFn (ctorVal : ConstructorVal) (us : List Level) (params : Array Expr) (i : Nat) (major : Expr) : CoreM Expr := do
  match getStructureInfo? (← getEnv) ctorVal.induct with
  | none => return mkProj ctorVal.induct i major
  | some info => match info.getProjFn? i with
    | none => return mkProj ctorVal.induct i major
    | some projFn => return mkApp (mkAppN (mkConst projFn us) params) major

/--
  If `major` is not a constructor application, and its type is a structure `C ...`, then return `C.mk major.1 ... major.n`

  \pre `inductName` is `C`.

  If `Meta.Config.etaStruct` is `false` or the condition above does not hold, this method just returns `major`. -/
private def toCtorWhenStructure (inductName : Name) (major : Expr) : ReductionM Expr := do
  unless (← useEtaStruct inductName) do
    return major
  let env ← getEnv
  if !isStructureLike env inductName then
    return major
  else if let some _ := major.isConstructorApp? env then
    return major
  else
    let majorType ← inferType major
    let majorType ← instantiateMVars (← whnf majorType)
    let majorTypeI := majorType.getAppFn
    if !majorTypeI.isConstOf inductName then
      return major
    match majorType.getAppFn with
    | Expr.const d us =>
      if (← whnfD (← inferType majorType)) == mkSort levelZero then
        return major -- We do not perform eta for propositions, see implementation in the kernel
      else
        let some ctorName ← getFirstCtor d | pure major
        let ctorInfo ← getConstInfoCtor ctorName
        let params := majorType.getAppArgs.shrink ctorInfo.numParams
        let mut result := mkAppN (mkConst ctorName us) params
        for i in [:ctorInfo.numFields] do
          result := mkApp result (← mkProjFn ctorInfo us params i major)
        return result
    | _ => return major

/-- Auxiliary function for reducing recursor applications. -/
private def reduceRec (recVal : RecursorVal) (recLvls : List Level) (recArgs : Array Expr)
    (failK : Unit → ReductionM α) (successK : Expr → ReductionM α)
    : ReductionM α := do
  let majorIdx := recVal.getMajorIdx
  trace[Smt.reduce.rec] "{recVal.name} with args (#{majorIdx} major){indentD recArgs}"
  if h : majorIdx < recArgs.size then
    let cont (major : Expr) : ReductionM (Option Expr) := do
      let mut major := major
      if recVal.k then
        major ← toCtorWhenK recVal major
      major := toCtorIfLit major
      major ← toCtorWhenStructure recVal.getInduct major
      let some rule := getRecRuleFor recVal major | return none
      let majorArgs := major.getAppArgs
      guard (recLvls.length == recVal.levelParams.length)
      let rhs := rule.rhs.instantiateLevelParams recVal.levelParams recLvls
      -- Apply parameters, motives and minor premises from recursor application.
      let rhs := mkAppRange rhs 0 (recVal.numParams+recVal.numMotives+recVal.numMinors) recArgs
      /- The number of parameters in the constructor is not necessarily
        equal to the number of parameters in the recursor when we have
        nested inductive types. -/
      let nparams := majorArgs.size - rule.nfields
      let rhs := mkAppRange rhs nparams majorArgs.size majorArgs
      let rhs := mkAppRange rhs (majorIdx + 1) recArgs.size recArgs
      return rhs

    let cont' : Option Expr → ReductionM α
      | some res => do
        trace[Smt.reduce.rec] "⤳ {res}"
        successK res
      | none => do
        trace[Smt.reduce.rec] "failed."
        failK ()

    let major ← whnf <| recArgs.get ⟨majorIdx, h⟩
    if (← read).letPushElim then
      letTelescopeAbstracting major fun _ major abs => do
        let e' ← cont major
        let e' ← e'.mapM fun e => abs e
        cont' e'
    else
      cont' (← cont major)
  else
    failK ()

/- ===========================
   Helper functions for reducing Quot.lift and Quot.ind
   =========================== -/

/-- Auxiliary function for reducing `Quot.lift` and `Quot.ind` applications. -/
private def reduceQuotRec (recVal  : QuotVal) (recLvls : List Level) (recArgs : Array Expr)
    (failK : Unit → ReductionM α) (successK : Expr → ReductionM α)
    : ReductionM α :=
  let process (majorPos argPos : Nat) : ReductionM α :=
    if h : majorPos < recArgs.size then do
      let major := recArgs.get ⟨majorPos, h⟩
      let major ← whnf major
      match major with
      | Expr.app (Expr.app (Expr.app (Expr.const majorFn _) _) _) majorArg => do
        let some (ConstantInfo.quotInfo { kind := QuotKind.ctor, .. }) ← getConstNoEx? majorFn | failK ()
        let f := recArgs[argPos]!
        let r := mkApp f majorArg
        let recArity := majorPos + 1
        successK <| mkAppRange r recArity recArgs.size recArgs
      | _ => failK ()
    else
      failK ()
  match recVal.kind with
  | QuotKind.lift => process 5 3
  | QuotKind.ind  => process 4 3
  | _             => failK ()

/- ===========================
   Helper function for extracting "stuck term"
   =========================== -/

mutual
  private partial def isRecStuck? (recVal : RecursorVal) (recArgs : Array Expr) : ReductionM (Option MVarId) :=
    if recVal.k then
      -- TODO: improve this case
      return none
    else do
      let majorIdx := recVal.getMajorIdx
      if h : majorIdx < recArgs.size then do
        let major := recArgs.get ⟨majorIdx, h⟩
        let major ← whnf major
        getStuckMVar? major
      else
        return none

  private partial def isQuotRecStuck? (recVal : QuotVal) (recArgs : Array Expr) : ReductionM (Option MVarId) :=
    let process? (majorPos : Nat) : ReductionM (Option MVarId) :=
      if h : majorPos < recArgs.size then do
        let major := recArgs.get ⟨majorPos, h⟩
        let major ← whnf major
        getStuckMVar? major
      else
        return none
    match recVal.kind with
    | QuotKind.lift => process? 5
    | QuotKind.ind  => process? 4
    | _             => return none

  /-- Return `some (Expr.mvar mvarId)` if metavariable `mvarId` is blocking reduction. -/
  partial def getStuckMVar? (e : Expr) : ReductionM (Option MVarId) := do
    match e with
    | Expr.mdata _ e  => getStuckMVar? e
    | Expr.proj _ _ e => getStuckMVar? (← whnf e)
    | Expr.mvar .. => do
      let e ← instantiateMVars e
      match e with
      | Expr.mvar mvarId => pure (some mvarId)
      | _ => getStuckMVar? e
    | Expr.app f .. =>
      let f := f.getAppFn
      match f with
      | Expr.mvar mvarId   => return some mvarId
      | Expr.const fName _ =>
        let cinfo? ← getConstNoEx? fName
        match cinfo? with
        | some $ ConstantInfo.recInfo recVal  => isRecStuck? recVal e.getAppArgs
        | some $ ConstantInfo.quotInfo recVal => isQuotRecStuck? recVal e.getAppArgs
        | _                                => return none
      | Expr.proj _ _ e => getStuckMVar? (← whnf e)
      | _ => return none
    | _ => return none
end

/- ===========================
   Weak Head Normal Form auxiliary combinators
   =========================== -/

/-- Auxiliary combinator for handling easy WHNF cases. It takes a function for handling the "hard" cases as an argument -/
@[specialize] partial def whnfEasyCases (e : Expr) (k : Expr → ReductionM Expr) : ReductionM Expr := do
  match e with
  | Expr.forallE ..    => return e
  | Expr.lam ..        => return e
  | Expr.sort ..       => return e
  | Expr.lit ..        => return e
  | Expr.bvar ..       => unreachable!
  | Expr.letE ..       => k e
  | Expr.const ..      => k e
  | Expr.app ..        => k e
  | Expr.proj ..       => k e
  | Expr.mdata ..      => k e
  | Expr.fvar fvarId   =>
    let decl ← fvarId.getDecl
    match decl with
    | LocalDecl.cdecl .. => return e
    | LocalDecl.ldecl (value := v) (nonDep := nonDep) .. =>
      let cfg ← getConfig
      if nonDep && !cfg.zetaNonDep then
        return e
      else
        if cfg.trackZeta then
          modify fun s => { s with zetaFVarIds := s.zetaFVarIds.insert fvarId }
        whnfEasyCases v k
  | Expr.mvar mvarId   =>
    match (← getExprMVarAssignment? mvarId) with
    | some v => whnfEasyCases v k
    | none   => return e

@[specialize] private def deltaDefinition (c : ConstantInfo) (lvls : List Level)
    (failK : Unit → MetaM α) (successK : Expr → MetaM α) : MetaM α := do
  if c.levelParams.length != lvls.length then
    failK ()
  else
    successK (← instantiateValueLevelParams c lvls)

@[specialize] private def deltaBetaDefinition (c : ConstantInfo) (lvls : List Level) (revArgs : Array Expr)
    (failK : Unit → ReductionM α) (successK : Expr → ReductionM α) (preserveMData := false) : ReductionM α := do
  if c.levelParams.length != lvls.length then
    failK ()
  else
    let val ← instantiateValueLevelParams c lvls
    let val := val.betaRev revArgs (preserveMData := preserveMData)
    successK val

inductive ReduceMatcherResult where
  | reduced (val : Expr)
  | stuck   (val : Expr)
  | notMatcher
  | partialApp

/--
  The "match" compiler uses `if-then-else` expressions and other auxiliary declarations to compile match-expressions such as
  ```
  match v with
  | 'a' => 1
  | 'b' => 2
  | _   => 3
  ```
  because it is more efficient than using `casesOn` recursors.
  The method `reduceMatcher?` fails if these auxiliary definitions (e.g., `ite`) cannot be unfolded in the current
  transparency setting. This is problematic because tactics such as `simp` use `TransparencyMode.reducible`, and
  most users assume that expressions such as
  ```
  match 0 with
  | 0 => 1
  | 100 => 2
  | _ => 3
  ```
  should reduce in any transparency mode.
  Thus, we define a custom `canUnfoldAtMatcher` predicate for `whnfMatcher`.

  This solution is not very modular because modications at the `match` compiler require changes here.
  We claim this is defensible because it is reducing the auxiliary declaration defined by the `match` compiler.

  Alternative solution: tactics that use `TransparencyMode.reducible` should rely on the equations we generated for match-expressions.
  This solution is also not perfect because the match-expression above will not reduce during type checking when we are not using
  `TransparencyMode.default` or `TransparencyMode.all`.
-/
def canUnfoldAtMatcher
    (prevUnfoldAt? : Option (Meta.Config → ConstantInfo → CoreM Bool))
    (cfg : Meta.Config) (info : ConstantInfo) : CoreM Bool := do
  if let some prevUnfoldAt := prevUnfoldAt? then
    prevUnfoldAt cfg info
  else match cfg.transparency with
  | TransparencyMode.all     => return true
  | TransparencyMode.default => return true
  | _ =>
    if (← isReducible info.name) || isGlobalInstance (← getEnv) info.name then
      return true
    else if hasMatchPatternAttribute (← getEnv) info.name then
      return true
    else
      return info.name == ``ite
       || info.name == ``dite
       || info.name == ``decEq
       || info.name == ``Nat.decEq
       || info.name == ``Char.ofNat   || info.name == ``Char.ofNatAux
       || info.name == ``String.decEq || info.name == ``List.hasDecEq
       || info.name == ``Fin.ofNat
       || info.name == ``UInt8.ofNat  || info.name == ``UInt8.decEq
       || info.name == ``UInt16.ofNat || info.name == ``UInt16.decEq
       || info.name == ``UInt32.ofNat || info.name == ``UInt32.decEq
       || info.name == ``UInt64.ofNat || info.name == ``UInt64.decEq
       /- Remark: we need to unfold the following two definitions because they are used for `Fin`, and
          lazy unfolding at `isDefEq` does not unfold projections.  -/
       || info.name == ``HMod.hMod || info.name == ``Mod.mod

private def whnfMatcher (e : Expr) : ReductionM Expr := do
  /- When reducing `match` expressions, if the reducibility setting is at `TransparencyMode.reducible`,
     we increase it to `TransparencyMode.instance`. We use the `TransparencyMode.reducible` in many places (e.g., `simp`),
     and this setting prevents us from reducing `match` expressions where the discriminants are terms such as `OfNat.ofNat α n inst`.
     For example, `simp [Int.div]` will not unfold the application `Int.div 2 1` occuring in the target.

     TODO: consider other solutions; investigate whether the solution above produces counterintuitive behavior.  -/
  let mut transparency ← getTransparency
  if transparency == TransparencyMode.reducible then
    transparency := TransparencyMode.instances
  withTransparency transparency <|
    withTheReader Meta.Context (fun ctx => { ctx with canUnfold? := canUnfoldAtMatcher ctx.canUnfold? }) do
      whnf e

def reduceMatcher? (e : Expr) : ReductionM ReduceMatcherResult := do
  trace[Smt.reduce.matcher] "{e}"
  match e.getAppFn with
  | Expr.const declName declLevels =>
    let some info ← getMatcherInfo? declName
      | do
        trace[Smt.reduce.matcher] "not a matcher."
        return ReduceMatcherResult.notMatcher
    let args := e.getAppArgs
    let prefixSz := info.numParams + 1 + info.numDiscrs
    if args.size < prefixSz + info.numAlts then
      trace[Smt.reduce.matcher] "partial app."
      return ReduceMatcherResult.partialApp
    else
      let constInfo ← getConstInfo declName
      let f ← instantiateValueLevelParams constInfo declLevels
      let auxApp := mkAppN f args[0:prefixSz]
      let auxAppType ← inferType auxApp
      forallBoundedTelescope auxAppType info.numAlts fun hs _ => do
        let auxApp ← whnfMatcher (mkAppN auxApp hs)

        let cont (auxApp : Expr) : ReductionM ReduceMatcherResult := do
          let auxAppFn := auxApp.getAppFn
          let mut i := prefixSz
          for h in hs do
            if auxAppFn == h then
              let result := mkAppN args[i]! auxApp.getAppArgs
              let result := mkAppN result args[prefixSz + info.numAlts:args.size]
              let res := result.headBeta
              trace[Smt.reduce.matcher] "⤳ {res}"
              return ReduceMatcherResult.reduced res
            i := i + 1
          trace[Smt.reduce.matcher] "stuck at {auxApp}"
          return ReduceMatcherResult.stuck auxApp

        if (← read).letPushElim then
          letTelescopeAbstracting auxApp fun _ auxApp abs => do
            match ← cont auxApp with
            | .reduced e => return .reduced (← abs e)
            | .stuck e   => return .stuck (← abs e)
            | res        => return res
        else cont auxApp
  | _ => do
    trace[Smt.reduce.matcher] "not a matcher."
    return ReduceMatcherResult.notMatcher

private def projectCore? (e : Expr) (i : Nat) : MetaM (Option Expr) := do
  let e := toCtorIfLit e
  matchConstCtor e.getAppFn (fun _ => pure none) fun ctorVal _ =>
    let numArgs := e.getAppNumArgs
    let idx := ctorVal.numParams + i
    if idx < numArgs then
      return some (e.getArg! idx)
    else
      return none

def project? (e : Expr) (i : Nat) : ReductionM (Option Expr) := do
  projectCore? (← whnf e) i

/-- Reduce kernel projection `Expr.proj ..` expression. -/
def reduceProj? (e : Expr) : ReductionM (Option Expr) := do
  match e with
  | Expr.proj _ i c => project? c i
  | _               => return none

/--
  Auxiliary method for reducing terms of the form `?m t_1 ... t_n` where `?m` is delayed assigned.
  Recall that we can only expand a delayed assignment when all holes/metavariables in the assigned value have been "filled".
-/
private def whnfDelayedAssigned? (f' : Expr) (e : Expr) : MetaM (Option Expr) := do
  if f'.isMVar then
    match (← getDelayedMVarAssignment? f'.mvarId!) with
    | none => return none
    | some { fvars, mvarIdPending } =>
      let args := e.getAppArgs
      if fvars.size > args.size then
        -- Insufficient number of argument to expand delayed assignment
        return none
      else
        let newVal ← instantiateMVars (mkMVar mvarIdPending)
        if newVal.hasExprMVar then
           -- Delayed assignment still contains metavariables
           return none
        else
           let newVal := newVal.abstract fvars
           let result := newVal.instantiateRevRange 0 fvars.size args
           return mkAppRange result fvars.size args.size args
  else
    return none

def traceReduce [Monad m] (e : Expr) (e' : Except ε Expr) : m MessageData :=
  return m!"{e} ⤳ " ++ match e' with
    | .ok e'   => m!"{e'}"
    | .error _ => m!"{bombEmoji}"

/--
  Apply beta-reduction, zeta-reduction (i.e., unfold let local-decls), iota-reduction,
  expand let-expressions, expand assigned meta-variables.

  The parameter `deltaAtProj` controls how to reduce projections `s.i`. If `deltaAtProj == true`,
  then delta reduction is used to reduce `s` (i.e., `whnf` is used), otherwise `whnfCore`.
  We only set this flag to `false` when implementing `isDefEq`.
-/
partial def whnfCore (e : Expr) (deltaAtProj : Bool := true) : ReductionM Expr :=
  go e
where
  go (e : Expr) : ReductionM Expr := withTraceNode `Smt.reduce.whnfCore (traceReduce e ·) <| do
    whnfEasyCases e fun e => do
      match e with
      | Expr.const ..  => pure e
      | Expr.letE _ _ v b _ => do
        -- NOTE(WN): Should core Lean do a `zetaNonDep` check here?
        if (← readThe Smt.Config).zeta then go <| b.instantiate1 v
        else return e
      | Expr.app f ..       =>
        let f := f.getAppFn
        let f ← go f
        -- NOTE(WN): We make a significant change to the evaluation order by not only WHNFing
        -- arguments eagerly, CBV-style, but also doing so with the full procedure rather than
        -- just `whnfCore` (so that a lack of delta-unfolding does not block let-lifting).
        let revArgs ← e.getAppRevArgs.mapM whnf

        let mut k (f : Expr) (revArgs : Array Expr) : ReductionM Expr := do
          let e := mkAppRev f revArgs
          if f.isLambda then
            go <| f.betaRev revArgs
          else if let some eNew ← whnfDelayedAssigned? f e then
            go eNew
          else
            -- Is this just an optimization?
            -- let e := if f == f' then e else e.updateFn f'
            match (← reduceMatcher? e) with
            | ReduceMatcherResult.reduced eNew => go eNew
            | ReduceMatcherResult.partialApp   => pure e
            | ReduceMatcherResult.stuck _      => pure e
            | ReduceMatcherResult.notMatcher   =>
              matchConstAux f (fun _ => return e) fun cinfo lvls =>
                match cinfo with
                | ConstantInfo.recInfo rec    => reduceRec rec lvls revArgs.reverse (fun _ => return e) go
                | ConstantInfo.quotInfo rec   => reduceQuotRec rec lvls revArgs.reverse (fun _ => return e) go
                | c@(ConstantInfo.defnInfo _) => do
                  if (← isAuxDef c.name) then
                    deltaBetaDefinition c lvls revArgs (fun _ => return e) go
                  else
                    return e
                | _ => return e

        if (← read).letPushElim then
          for arg in revArgs.reverse do
            k := fun f acc => do
              letTelescopeAbstracting arg fun _ arg absFn => do
                let res ← k f (acc.push arg)
                absFn res

          letTelescopeAbstracting f fun _ f absFn => do
            let res ← k f #[]
            absFn res
        else
          k f revArgs

      | Expr.proj pNm i c =>
        let c ← if deltaAtProj then whnf c else whnfCore c

        if (← read).letPushElim then
        -- if false then
          letTelescopeAbstracting c fun _ c absFn => do
            match (← projectCore? c i) with
            | some e => absFn e
            | none => absFn (Expr.proj pNm i c)
        else match (← projectCore? c i) with
        | some e => go e
        | none => return e
      | Expr.mdata md (Expr.letE nm t v b nonDep) =>
        let zeta := md.getBool `zeta (← read).zeta
        if zeta then go <| b.instantiate1 v
        else
          let t' ← go t
          let v' ← go v
          let nm ← bumpNameIfUsed nm
          let b' ← withLocalDeclD nm t' fun x => do
            let b' ← go (b.instantiate1 x)
            return b'.abstract #[x]
          return Expr.mdata md (Expr.letE nm t' v' b' nonDep)
      | Expr.mdata _ e => go e
      | _ => unreachable!

/--
  Recall that `_sunfold` auxiliary definitions contains the markers: `markSmartUnfoldingMatch` (*) and `markSmartUnfoldingMatchAlt` (**).
  For example, consider the following definition
  ```
  def r (i j : Nat) : Nat :=
    i +
      match j with
      | Nat.zero => 1
      | Nat.succ j =>
        i + match j with
            | Nat.zero => 2
            | Nat.succ j => r i j
  ```
  produces the following `_sunfold` auxiliary definition with the markers
  ```
  def r._sunfold (i j : Nat) : Nat :=
    i +
      (*) match j with
      | Nat.zero => (**) 1
      | Nat.succ j =>
        i + (*) match j with
            | Nat.zero => (**) 2
            | Nat.succ j => (**) r i j
  ```

  `match` expressions marked with `markSmartUnfoldingMatch` (*) must be reduced, otherwise the resulting term is not definitionally
   equal to the given expression. The recursion may be interrupted as soon as the annotation `markSmartUnfoldingAlt` (**) is reached.

  For example, the term `r i j.succ.succ` reduces to the definitionally equal term `i + i * r i j`
-/
partial def smartUnfoldingReduce? (e : Expr) : ReductionM (Option Expr) := do
  trace[Smt.reduce.smartUnfoldingReduce] "{e}"
  match ← go e |>.run with
  | some e' =>
    trace[Smt.reduce.smartUnfoldingReduce] "⤳ {e'}"
    return some e'
  | none =>
    trace[Smt.reduce.smartUnfoldingReduce] "failed."
    return none

where
  go (e : Expr) : OptionT ReductionM Expr := do
    match e with
    | Expr.letE n t v b _ => withLetDecl n t (← go v) fun x => do mkLetFVars #[x] (← go (b.instantiate1 x))
    | Expr.lam .. => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← go b)
    | Expr.app f a .. => return mkApp (← go f) (← go a)
    | Expr.proj _ _ s => return e.updateProj! (← go s)
    | Expr.mdata _ b  =>
      if let some m := smartUnfoldingMatch? e then
        goMatch m
      else
        return e.updateMData! (← go b)
    | _ => return e

  goMatch (e : Expr) : OptionT ReductionM Expr := do
    match (← reduceMatcher? e) with
    | ReduceMatcherResult.reduced e =>
      if let some alt := smartUnfoldingMatchAlt? e then
        return alt
      else
        go e
    | ReduceMatcherResult.stuck e' =>
      let mvarId ← getStuckMVar? e'
      /- Try to "unstuck" by resolving pending TC problems -/
      if (← Meta.synthPending mvarId) then
        goMatch e
      else
        failure
    | _ => failure

def shouldUnfold (ci : ConstantInfo) : ReductionM Bool := do
  let some canUnfold := (← readThe Meta.Context).canUnfold? | return true
  let cfg := (← readThe Meta.Context).config
  canUnfold cfg ci

mutual

  /--
    Auxiliary method for unfolding a class projection.
  -/
  partial def unfoldProjInst? (e : Expr) : ReductionM (Option Expr) := do
    match e.getAppFn with
    | Expr.const declName .. =>
      match (← getProjectionFnInfo? declName) with
      | some { fromClass := true, .. } =>
        match (← withDefault <| unfoldDefinition? e) with
        | none   => return none
        | some e =>
          match (← withReducibleAndInstances <| reduceProj? e.getAppFn) with
          | none   => return none
          | some r => return mkAppN r e.getAppArgs |>.headBeta
      | _ => return none
    | _ => return none

  /--
    Auxiliary method for unfolding a class projection. when transparency is set to `TransparencyMode.instances`.
    Recall that class instance projections are not marked with `[reducible]` because we want them to be
    in "reducible canonical form".
  -/
  partial def unfoldProjInstWhenIntances? (e : Expr) : ReductionM (Option Expr) := do
    if (← getTransparency) != TransparencyMode.instances then
      return none
    else
      unfoldProjInst? e

  /-- Unfold definition using "smart unfolding" if possible. -/
  partial def unfoldDefinition? (e : Expr) : ReductionM (Option Expr) :=
    match e with
    | Expr.app f _ =>
      matchConstAux f.getAppFn (fun _ => unfoldProjInstWhenIntances? e) fun fInfo fLvls => do
        -- NOTE(WN): this not being checked might be a Lean bug
        unless ← shouldUnfold fInfo do return none
        if fInfo.levelParams.length != fLvls.length then
          return none
        else
          let unfoldDefault (_ : Unit) : ReductionM (Option Expr) :=
            if fInfo.hasValue then
              deltaBetaDefinition fInfo fLvls e.getAppRevArgs (fun _ => pure none) (fun e => pure (some e))
            else
              return none
          if smartUnfolding.get (← getOptions) then
            match ((← getEnv).find? (mkSmartUnfoldingNameFor fInfo.name)) with
            | some fAuxInfo@(ConstantInfo.defnInfo _) =>
              -- We use `preserveMData := true` to make sure the smart unfolding annotation are not erased in an over-application.
              deltaBetaDefinition fAuxInfo fLvls e.getAppRevArgs (preserveMData := true) (fun _ => pure none) fun e₁ => do
                let some r ← smartUnfoldingReduce? e₁ | return none
                /-
                  If `smartUnfoldingReduce?` succeeds, we should still check whether the argument the
                  structural recursion is recursing on reduces to a constructor.
                  This extra check is necessary in definitions (see issue #1081) such as
                  ```
                  inductive Vector (α : Type u) : Nat → Type u where
                    | nil  : Vector α 0
                    | cons : α → Vector α n → Vector α (n+1)

                  def Vector.insert (a: α) (i : Fin (n+1)) (xs : Vector α n) : Vector α (n+1) :=
                    match i, xs with
                    | ⟨0,   _⟩,        xs => cons a xs
                    | ⟨i+1, h⟩, cons x xs => cons x (xs.insert a ⟨i, Nat.lt_of_succ_lt_succ h⟩)
                  ```
                  The structural recursion is being performed using the vector `xs`. That is, we used `Vector.brecOn` to define
                  `Vector.insert`. Thus, an application `xs.insert a ⟨0, h⟩` is **not** definitionally equal to
                  `Vector.cons a xs` because `xs` is not a constructor application (the `Vector.brecOn` application is blocked).

                  Remark 1: performing structural recursion on `Fin (n+1)` is not an option here because it is a `Subtype` and
                  and the repacking in recursive applications confuses the structural recursion module.

                  Remark 2: the match expression reduces reduces to `cons a xs` when the discriminants are `⟨0, h⟩` and `xs`.

                  Remark 3: this check is unnecessary in most cases, but we don't need dependent elimination to trigger the issue
                  fixed by this extra check. Here is another example that triggers the issue fixed by this check.
                  ```
                  def f : Nat → Nat → Nat
                    | 0,   y   => y
                    | x+1, y+1 => f (x-2) y
                    | x+1, 0   => 0

                  theorem ex : f 0 y = y := rfl
                  ```

                  Remark 4: the `return some r` in the following `let` is not a typo. Binport generated .olean files do not
                  store the position of recursive arguments for definitions using structural recursion.
                  Thus, we should keep `return some r` until Mathlib has been ported to Lean 3.
                  Note that the `Vector` example above does not even work in Lean 3.
                -/
                let some recArgPos ← getStructuralRecArgPos? fInfo.name | return some r
                let numArgs := e.getAppNumArgs
                if recArgPos >= numArgs then return none
                let recArg := e.getArg! recArgPos numArgs
                if !(← whnfMatcher recArg).isConstructorApp (← getEnv) then return none
                return some r
            | _ =>
              if (← getMatcherInfo? fInfo.name).isSome then
                -- Recall that `whnfCore` tries to reduce "matcher" applications.
                return none
              else
                unfoldDefault ()
          else
            unfoldDefault ()
    | Expr.const declName lvls => do
      if smartUnfolding.get (← getOptions) && (← getEnv).contains (mkSmartUnfoldingNameFor declName) then
        return none
      else
        let (some (cinfo@(ConstantInfo.defnInfo _))) ← getConstNoEx? declName | pure none
        deltaDefinition cinfo lvls
          (fun _ => pure none)
          (fun e => pure (some e))
    | _ => return none
end

def unfoldDefinition (e : Expr) : ReductionM Expr := do
  let some e ← unfoldDefinition? e | throwError "failed to unfold definition{indentExpr e}"
  return e

@[specialize] partial def whnfHeadPred (e : Expr) (pred : Expr → ReductionM Bool) : ReductionM Expr :=
  whnfEasyCases e fun e => do
    let e ← whnfCore e
    if (← pred e) then
        match (← unfoldDefinition? e) with
        | some e => whnfHeadPred e pred
        | none   => return e
    else
      return e

def whnfUntil (e : Expr) (declName : Name) : ReductionM (Option Expr) := do
  let e ← whnfHeadPred e (fun e => return !e.isAppOf declName)
  if e.isAppOf declName then
    return e
  else
    return none

/-- Try to reduce matcher/recursor/quot applications. We say they are all "morally" recursor applications. -/
def reduceRecMatcher? (e : Expr) : ReductionM (Option Expr) := do
  if !e.isApp then
    return none
  else match (← reduceMatcher? e) with
    | ReduceMatcherResult.reduced e => return e
    | _ => matchConstAux e.getAppFn (fun _ => pure none) fun cinfo lvls => do
      match cinfo with
      | ConstantInfo.recInfo «rec»  => reduceRec «rec» lvls e.getAppArgs (fun _ => pure none) (fun e => pure (some e))
      | ConstantInfo.quotInfo «rec» => reduceQuotRec «rec» lvls e.getAppArgs (fun _ => pure none) (fun e => pure (some e))
      | c@(ConstantInfo.defnInfo _) =>
        if (← isAuxDef c.name) then
          deltaBetaDefinition c lvls e.getAppRevArgs (fun _ => pure none) (fun e => pure (some e))
        else
          return none
      | _ => return none

def reduceNative? (e : Expr) : MetaM (Option Expr) :=
  match e with
  | Expr.app (Expr.const fName _) (Expr.const argName _) =>
    if fName == ``Lean.reduceBool then do
      return toExpr (← reduceBoolNative argName)
    else if fName == ``Lean.reduceNat then do
      return toExpr (← reduceNatNative argName)
    else
      return none
  | _ =>
    return none

@[inline] def withNatValue {α} (a : Expr) (k : Nat → ReductionM (Option α)) : ReductionM (Option α) := do
  let a ← whnf a
  match a with
  | Expr.const `Nat.zero _      => k 0
  | Expr.lit (Literal.natVal v) => k v
  | _                           => return none

def reduceUnaryNatOp (f : Nat → Nat) (a : Expr) : ReductionM (Option Expr) :=
  withNatValue a fun a =>
  return mkRawNatLit <| f a

def reduceBinNatOp (f : Nat → Nat → Nat) (a b : Expr) : ReductionM (Option Expr) :=
  withNatValue a fun a =>
  withNatValue b fun b => do
  trace[Meta.isDefEq.whnf.reduceBinOp] "{a} op {b}"
  return mkRawNatLit <| f a b

def reduceBinNatPred (f : Nat → Nat → Bool) (a b : Expr) : ReductionM (Option Expr) := do
  withNatValue a fun a =>
  withNatValue b fun b =>
  return toExpr <| f a b

def reduceNat? (e : Expr) : ReductionM (Option Expr) :=
  if e.hasFVar || e.hasMVar then
    return none
  else match e with
    | Expr.app (Expr.const fn _) a                =>
      if fn == ``Nat.succ then
        reduceUnaryNatOp Nat.succ a
      else
        return none
    | Expr.app (Expr.app (Expr.const fn _) a1) a2 =>
      if fn == ``Nat.add then reduceBinNatOp Nat.add a1 a2
      else if fn == ``Nat.sub then reduceBinNatOp Nat.sub a1 a2
      else if fn == ``Nat.mul then reduceBinNatOp Nat.mul a1 a2
      else if fn == ``Nat.div then reduceBinNatOp Nat.div a1 a2
      else if fn == ``Nat.mod then reduceBinNatOp Nat.mod a1 a2
      else if fn == ``Nat.beq then reduceBinNatPred Nat.beq a1 a2
      else if fn == ``Nat.ble then reduceBinNatPred Nat.ble a1 a2
      else return none
    | _ =>
      return none

@[inline] private def useWHNFCache (_ : Expr) : MetaM Bool := do
  -- Can't straightforwardly use the WHNF cache with configurable rules.
  return false
  -- We cache only closed terms without expr metavars.
  -- Potential refinement: cache if `e` is not stuck at a metavariable
  -- if e.hasFVar || e.hasExprMVar || (← read).canUnfold?.isSome then
  --   return false
  -- else
  --   match (← getConfig).transparency with
  --   | TransparencyMode.default => return true
  --   | TransparencyMode.all     => return true
  --   | _                        => return false

@[inline] private def cached? (useCache : Bool) (e : Expr) : MetaM (Option Expr) := do
  if useCache then
    match (← getConfig).transparency with
    | TransparencyMode.default => return (← get).cache.whnfDefault.find? e
    | TransparencyMode.all     => return (← get).cache.whnfAll.find? e
    | _                        => unreachable!
  else
    return none

private def cache (useCache : Bool) (e r : Expr) : MetaM Expr := do
  if useCache then
    match (← getConfig).transparency with
    | TransparencyMode.default => modify fun s => { s with cache.whnfDefault := s.cache.whnfDefault.insert e r }
    | TransparencyMode.all     => modify fun s => { s with cache.whnfAll     := s.cache.whnfAll.insert e r }
    | _                        => unreachable!
  return r

partial def whnfImp (e : Expr) : ReductionM Expr :=
  withIncRecDepth <| withTraceNode `Smt.reduce.whnf  (traceReduce e ·) <| whnfEasyCases e fun e => do
    checkMaxHeartbeats "Smt.whnf"
    let useCache ← useWHNFCache e
    let e' ← match (← cached? useCache e) with
    | some e' => pure e'
    | none    =>
      let e' ← whnfCore e
      match (← reduceNat? e') with
      | some v => cache useCache e v
      | none   =>
        match (← reduceNative? e') with
        | some v => cache useCache e v
        | none   =>
          match (← unfoldDefinition? e') with
          | some e => whnfImp e
          | none   => cache useCache e e'
    return e'

/-- If `e` is a projection function that satisfies `p`, then reduce it -/
def reduceProjOf? (e : Expr) (p : Name → Bool) : MetaM (Option Expr) := do
  if !e.isApp then
    pure none
  else match e.getAppFn with
    | Expr.const name .. => do
      let env ← getEnv
      match env.getProjectionStructureName? name with
      | some structName =>
        if p structName then
          Meta.unfoldDefinition? e
        else
          pure none
      | none => pure none
    | _ => pure none

partial def reduce (e : Expr) (explicitOnly skipTypes skipProofs := true) : ReductionM Expr :=
  let rec visit (e : Expr) : MonadCacheT Expr Expr ReductionM Expr :=
    checkCache e fun _ => Core.withIncRecDepth <| withTraceNode `Smt.reduce (traceReduce e ·) do
      if (← (pure skipTypes <&&> isType e)) then
        return e
      else if (← (pure skipProofs <&&> isProof e)) then
        return e
      else
        let e ← whnf e
        let e' ← match e with
        | Expr.app .. =>
          -- This case happens when the application was not substituted by WHNF,
          -- meaning that it must be stuck.
          let f     ← visit e.getAppFn
          let nargs := e.getAppNumArgs
          let finfo ← getFunInfoNArgs f nargs
          let mut args  := e.getAppArgs
          for i in [:args.size] do
            if i < finfo.paramInfo.size then
              let info := finfo.paramInfo[i]!
              if !explicitOnly || info.isExplicit then
                args ← args.modifyM i visit
            else
              args ← args.modifyM i visit
          if f.isConstOf ``Nat.succ && args.size == 1 && args[0]!.isNatLit then
            pure <| mkRawNatLit (args[0]!.natLit?.get! + 1)
          else
            pure <| mkAppN f args
        -- `let`-bindings are normally substituted by WHNF, but they are left alone when `zeta` is off,
        -- so we must reduce their subterms here.
        | Expr.letE nm t v b nonDep => do
          let t' ← visit t
          -- Reduce body with the let-bound name in context to avoid name shadowing
          let v' ← withLocalDeclD nm t <| fun _ => visit v
          let nm ← bumpNameIfUsed nm
          -- TODO: we use an opaque `cdecl` since this case only runs when `zeta` is off anyway.
          -- Is this correct?
          let b' ← withLocalDeclD nm t' fun x => do
            let b' ← visit (b.instantiate1 x)
            pure <| b'.abstract #[x]
          let e' := Expr.letE nm t' v' b' nonDep
          pure e'
        | Expr.lam ..        => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← visit b)
        | Expr.forallE ..    => forallTelescope e fun xs b => do mkForallFVars xs (← visit b)
        | Expr.proj n i s .. => pure <| mkProj n i (← visit s)
        -- TODO: this case is pretty awkward; what we really want is a positional mdata context, I think
        | Expr.mdata md (Expr.letE nm t v b nonDep) => do
          let t' ← visit t
          -- Reduce body with the let-bound name in context to avoid name shadowing
          let v' ← withLocalDeclD nm t <| fun _ => visit v
          let nm ← bumpNameIfUsed nm
          let b' ← withLocalDeclD nm t' fun x => do
            let b' ← visit (b.instantiate1 x)
            pure <| b'.abstract #[x]
          let e' := Expr.letE nm t' v' b' nonDep
          pure <| mkMData md e'
        | _                  => pure e
        return e'
  visit e |>.run

initialize
  registerTraceClass `Smt.reduce
  registerTraceClass `Smt.reduce.whnf
  registerTraceClass `Smt.reduce.whnfCore
  registerTraceClass `Smt.reduce.rec
  registerTraceClass `Smt.reduce.matcher
  registerTraceClass `Smt.reduce.smartUnfoldingReduce

end Smt

initialize Smt.whnfRef.set Smt.whnfImp


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module tactic.simpa
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.DocCommands

open Interactive

open Interactive.Types

namespace Tactic

namespace Interactive

open Expr Lean.Parser

-- mathport name: parser.optional
local postfix:1024 "?" => optional

/-- This is a "finishing" tactic modification of `simp`. It has two forms.

* `simpa [rules, ...] using e` will simplify the goal and the type of
  `e` using `rules`, then try to close the goal using `e`.

  Simplifying the type of `e` makes it more likely to match the goal
  (which has also been simplified). This construction also tends to be
  more robust under changes to the simp lemma set.

* `simpa [rules, ...]` will simplify the goal and the type of a
  hypothesis `this` if present in the context, then try to close the goal using
  the `assumption` tactic. -/
unsafe def simpa (use_iota_eqn : parse <| (tk "!")?) (trace_lemmas : parse <| (tk "?")?)
    (no_dflt : parse only_flag) (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
    (tgt : parse (tk "using" *> texpr)?) (cfg : simp_config_ext := { }) : tactic Unit :=
  let simp_at (lc) (close_tac : tactic Unit) :=
    focus1 <|
      simp use_iota_eqn trace_lemmas no_dflt hs attr_names (Loc.ns lc)
          { cfg with failIfUnchanged := false } >>
        ((close_tac <|> trivial) >> done <|> fail "simpa failed")
  match tgt with
  | none => get_local `this >> simp_at [some `this, none] assumption <|> simp_at [none] assumption
  | some e =>
    focus1 do
      let e ←
        i_to_expr e <|> do
            let ty ← target
            let e
              ←-- for positional error messages, we don't care about the result
                  i_to_expr_strict
                  ``(($(e) : $(ty)))
            let pty ← pp ty
            let ptgt ← pp e
            -- Fail deliberately, to advise regarding `simp; exact` usage
                fail
                ("simpa failed, 'using' expression type not directly " ++
                          "inferrable. Try:\n\nsimpa ... using\nshow " ++
                        to_fmt pty ++
                      ",\nfrom " ++
                    ptgt :
                  format)
      match e with
        | local_const _ lc _ _ => simp_at [some lc, none] (get_local lc >>= tactic.exact)
        | e => do
          let t ← infer_type e
          assertv `this t e
          simp_at [some `this, none] (get_local `this >>= tactic.exact)
          all_goals (try apply_instance)
#align tactic.interactive.simpa tactic.interactive.simpa

add_tactic_doc
  { Name := "simpa"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.simpa]
    tags := ["simplification"] }

end Interactive

end Tactic