/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ProjFns
import Lean.Meta.WHNF
import Lean.Meta.InferType
import Lean.Meta.FunInfo
import Lean.Meta.LevelDefEq
import Lean.Meta.Check
import Lean.Meta.Offset
import Lean.Meta.ForEachExpr
import Lean.Meta.UnificationHint

namespace Lean.Meta

/--
  Try to solve `a := (fun x => t) =?= b` by eta-expanding `b`.

  Remark: eta-reduction is not a good alternative even in a system without universe cumulativity like Lean.
  Example:
    ```
    (fun x : A => f ?m) =?= f
    ```
    The left-hand side of the constraint above it not eta-reduced because `?m` is a metavariable. -/
private def isDefEqEta (a b : Expr) : MetaM Bool := do
  if a.isLambda && !b.isLambda then
    let bType ← inferType b
    let bType ← whnfD bType
    match bType with
    | Expr.forallE n d _ c =>
      let b' := mkLambda n c.binderInfo d (mkApp b (mkBVar 0))
      checkpointDefEq <| Meta.isExprDefEqAux a b'
    | _ => pure false
  else
    pure false

/-- Support for `Lean.reduceBool` and `Lean.reduceNat` -/
def isDefEqNative (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  let s? ← reduceNative? s
  let t? ← reduceNative? t
  match s?, t? with
  | some s, some t => isDefEq s t
  | some s, none   => isDefEq s t
  | none,   some t => isDefEq s t
  | none,   none   => pure LBool.undef

/-- Support for reducing Nat basic operations. -/
def isDefEqNat (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  if s.hasFVar || s.hasMVar || t.hasFVar || t.hasMVar then
    pure LBool.undef
  else
    let s? ← reduceNat? s
    let t? ← reduceNat? t
    match s?, t? with
    | some s, some t => isDefEq s t
    | some s, none   => isDefEq s t
    | none,   some t => isDefEq s t
    | none,   none   => pure LBool.undef

/-- Support for constraints of the form `("..." =?= String.mk cs)` -/
def isDefEqStringLit (s t : Expr) : MetaM LBool := do
  let isDefEq (s t) : MetaM LBool := toLBoolM <| Meta.isExprDefEqAux s t
  if s.isStringLit && t.isAppOf `String.mk then
    isDefEq (toCtorIfLit s) t
  else if s.isAppOf `String.mk && t.isStringLit then
    isDefEq s (toCtorIfLit t)
  else
    pure LBool.undef

/--
  Return `true` if `e` is of the form `fun (x_1 ... x_n) => ?m x_1 ... x_n)`, and `?m` is unassigned.
  Remark: `n` may be 0. -/
def isEtaUnassignedMVar (e : Expr) : MetaM Bool := do
  match e.etaExpanded? with
  | some (Expr.mvar mvarId _) =>
    if (← isReadOnlyOrSyntheticOpaqueExprMVar mvarId) then
      pure false
    else if (← isExprMVarAssigned mvarId) then
      pure false
    else
      pure true
  | _   => pure false

/-
  First pass for `isDefEqArgs`. We unify explicit arguments, *and* easy cases
  Here, we say a case is easy if it is of the form

       ?m =?= t
       or
       t  =?= ?m

  where `?m` is unassigned.

  These easy cases are not just an optimization. When
  `?m` is a function, by assigning it to t, we make sure
  a unification constraint (in the explicit part)
  ```
  ?m t =?= f s
  ```
  is not higher-order.

  We also handle the eta-expanded cases:
  ```
  fun x₁ ... xₙ => ?m x₁ ... xₙ =?= t
  t =?= fun x₁ ... xₙ => ?m x₁ ... xₙ
  ```
  This is important because type inference often produces
  eta-expanded terms, and without this extra case, we could
  introduce counter intuitive behavior.

  Pre: `paramInfo.size <= args₁.size = args₂.size`
-/
private partial def isDefEqArgsFirstPass
    (paramInfo : Array ParamInfo) (args₁ args₂ : Array Expr) : MetaM (Option (Array Nat)) := do
  let rec loop (i : Nat) (postponed : Array Nat) := do
    if h : i < paramInfo.size then
      let info := paramInfo.get ⟨i, h⟩
      let a₁ := args₁[i]
      let a₂ := args₂[i]
      if info.implicit || info.instImplicit then
        if (← isEtaUnassignedMVar a₁ <||> isEtaUnassignedMVar a₂) then
          if (← Meta.isExprDefEqAux a₁ a₂) then
            loop (i+1) postponed
          else
            pure none
        else
          loop (i+1) (postponed.push i)
      else if (← Meta.isExprDefEqAux a₁ a₂) then
        loop (i+1) postponed
      else
        pure none
    else
      pure (some postponed)
  loop 0 #[]

@[specialize] private def trySynthPending (e : Expr) : MetaM Bool := do
  let mvarId? ← getStuckMVar? e
  match mvarId? with
  | some mvarId => Meta.synthPending mvarId
  | none        => pure false

private partial def isDefEqArgs (f : Expr) (args₁ args₂ : Array Expr) : MetaM Bool :=
  if h : args₁.size = args₂.size then do
    let finfo ← getFunInfoNArgs f args₁.size
    let (some postponed) ← isDefEqArgsFirstPass finfo.paramInfo args₁ args₂ | pure false
    let rec processOtherArgs (i : Nat) : MetaM Bool := do
      if h₁ : i < args₁.size then
        let a₁ := args₁.get ⟨i, h₁⟩
        let a₂ := args₂.get ⟨i, Eq.subst h h₁⟩
        if (← Meta.isExprDefEqAux a₁ a₂) then
          processOtherArgs (i+1)
        else
          pure false
      else
        pure true
    if (← processOtherArgs finfo.paramInfo.size) then
      postponed.allM fun i => do
        /- Second pass: unify implicit arguments.
           In the second pass, we make sure we are unfolding at
           least non reducible definitions (default setting). -/
        let a₁   := args₁[i]
        let a₂   := args₂[i]
        let info := finfo.paramInfo[i]
        if info.instImplicit then
          discard <| trySynthPending a₁
          discard <| trySynthPending a₂
        withAtLeastTransparency TransparencyMode.default <| Meta.isExprDefEqAux a₁ a₂
    else
      pure false
  else
    pure false

/--
  Check whether the types of the free variables at `fvars` are
  definitionally equal to the types at `ds₂`.

  Pre: `fvars.size == ds₂.size`

  This method also updates the set of local instances, and invokes
  the continuation `k` with the updated set.

  We can't use `withNewLocalInstances` because the `isDeq fvarType d₂`
  may use local instances. -/
@[specialize] partial def isDefEqBindingDomain (fvars : Array Expr) (ds₂ : Array Expr) (k : MetaM Bool) : MetaM Bool :=
  let rec loop (i : Nat) := do
    if h : i < fvars.size then do
      let fvar := fvars.get ⟨i, h⟩
      let fvarDecl ← getFVarLocalDecl fvar
      let fvarType := fvarDecl.type
      let d₂       := ds₂[i]
      if (← Meta.isExprDefEqAux fvarType d₂) then
        match (← isClass? fvarType) with
        | some className => withNewLocalInstance className fvar <| loop (i+1)
        | none           => loop (i+1)
      else
        pure false
    else
      k
  loop 0

/- Auxiliary function for `isDefEqBinding` for handling binders `forall/fun`.
   It accumulates the new free variables in `fvars`, and declare them at `lctx`.
   We use the domain types of `e₁` to create the new free variables.
   We store the domain types of `e₂` at `ds₂`. -/
private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr) (e₁ e₂ : Expr) (ds₂ : Array Expr) : MetaM Bool :=
  let process (n : Name) (d₁ d₂ b₁ b₂ : Expr) : MetaM Bool := do
    let d₁     := d₁.instantiateRev fvars
    let d₂     := d₂.instantiateRev fvars
    let fvarId ← mkFreshId
    let lctx   := lctx.mkLocalDecl fvarId n d₁
    let fvars  := fvars.push (mkFVar fvarId)
    isDefEqBindingAux lctx fvars b₁ b₂ (ds₂.push d₂)
  match e₁, e₂ with
  | Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
  | Expr.lam     n d₁ b₁ _, Expr.lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
  | _,                      _                      =>
    withReader (fun ctx => { ctx with lctx := lctx }) do
      isDefEqBindingDomain fvars ds₂ do
        Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)

@[inline] private def isDefEqBinding (a b : Expr) : MetaM Bool := do
  let lctx ← getLCtx
  isDefEqBindingAux lctx #[] a b #[]

private def checkTypesAndAssign (mvar : Expr) (v : Expr) : MetaM Bool :=
  traceCtx `Meta.isDefEq.assign.checkTypes do
    if !mvar.isMVar then
      trace[Meta.isDefEq.assign.final] "metavariable expected at {mvar} := {v}"
      return false
    else
      -- must check whether types are definitionally equal or not, before assigning and returning true
      let mvarType ← inferType mvar
      let vType ← inferType v
      if (← withTransparency TransparencyMode.default <| Meta.isExprDefEqAux mvarType vType) then
        trace[Meta.isDefEq.assign.final] "{mvar} := {v}"
        assignExprMVar mvar.mvarId! v
        pure true
      else
        trace[Meta.isDefEq.assign.typeMismatch] "{mvar} : {mvarType} := {v} : {vType}"
        pure false

/--
  Auxiliary method for solving constraints of the form `?m xs := v`.
  It creates a lambda using `mkLambdaFVars ys v`, where `ys` is a superset of `xs`.
  `ys` is often equal to `xs`. It is a bigger when there are let-declaration dependencies in `xs`.
  For example, suppose we have `xs` of the form `#[a, c]` where
  ```
  a : Nat
  b : Nat := f a
  c : b = a
  ```
  In this scenario, the type of `?m` is `(x1 : Nat) -> (x2 : f x1 = x1) -> C[x1, x2]`,
  and type of `v` is `C[a, c]`. Note that, `?m a c` is type correct since `f a = a` is definitionally equal
  to the type of `c : b = a`, and the type of `?m a c` is equal to the type of `v`.
  Note that `fun xs => v` is the term `fun (x1 : Nat) (x2 : b = x1) => v` which has type
  `(x1 : Nat) -> (x2 : b = x1) -> C[x1, x2]` which is not definitionally equal to the type of `?m`,
  and may not even be type correct.
  The issue here is that we are not capturing the `let`-declarations.

  This method collects let-declarations `y` occurring between `xs[0]` and `xs.back` s.t.
  some `x` in `xs` depends on `y`.
  `ys` is the `xs` with these extra let-declarations included.

  In the example above, `ys` is `#[a, b, c]`, and `mkLambdaFVars ys v` produces
  `fun a => let b := f a; fun (c : b = a) => v` which has a type definitionally equal to the type of `?m`.

  Recall that the method `checkAssignment` ensures `v` does not contain offending `let`-declarations.

  This method assumes that for any `xs[i]` and `xs[j]` where `i < j`, we have that `index of xs[i]` < `index of xs[j]`.
  where the index is the position in the local context.
-/
private partial def mkLambdaFVarsWithLetDeps (xs : Array Expr) (v : Expr) : MetaM (Option Expr) := do
  if not (← hasLetDeclsInBetween) then
    mkLambdaFVars xs v
  else
    let ys ← addLetDeps
    trace[Meta.debug] "ys: {ys}, v: {v}"
    mkLambdaFVars ys v

where
  /- Return true if there are let-declarions between `xs[0]` and `xs[xs.size-1]`.
     We use it a quick-check to avoid the more expensive collection procedure. -/
  hasLetDeclsInBetween : MetaM Bool := do
    let check (lctx : LocalContext) : Bool := do
      let start := lctx.getFVar! xs[0] |>.index
      let stop  := lctx.getFVar! xs.back |>.index
      for i in [start+1:stop] do
        match lctx.getAt? i with
        | some localDecl =>
          if localDecl.isLet then
            return true
        | _ => pure ()
      return false
    if xs.size <= 1 then
      pure false
    else
      check (← getLCtx)

  /- Traverse `e` and stores in the state `NameHashSet` any let-declaration with index greater than `(← read)`.
     The context `Nat` is the position of `xs[0]` in the local context. -/
  collectLetDeclsFrom (e : Expr) : ReaderT Nat (StateRefT NameHashSet MetaM) Unit := do
    let rec visit (e : Expr) : MonadCacheT Expr Unit (ReaderT Nat (StateRefT NameHashSet MetaM)) Unit :=
      checkCache e fun _ => do
        match e with
        | Expr.forallE _ d b _   => visit d; visit b
        | Expr.lam _ d b _       => visit d; visit b
        | Expr.letE _ t v b _    => visit t; visit v; visit b
        | Expr.app f a _         => visit f; visit a
        | Expr.mdata _ b _       => visit b
        | Expr.proj _ _ b _      => visit b
        | Expr.fvar fvarId _     =>
          let localDecl ← getLocalDecl fvarId
          if localDecl.isLet && localDecl.index > (← read) then
            modify fun s => s.insert localDecl.fvarId
        | _ => pure ()
    visit (← instantiateMVars e) |>.run

  /-
    Auxiliary definition for traversing all declarations between `xs[0]` ... `xs.back` backwards.
    The `Nat` argument is the current position in the local context being visited, and it is less than
    or equal to the position of `xs.back` in the local context.
    The `Nat` context `(← read)` is the position of `xs[0]` in the local context.
  -/
  collectLetDepsAux : Nat → ReaderT Nat (StateRefT NameHashSet MetaM) Unit
    | 0   => return ()
    | i+1 => do
      if i+1 == (← read) then
        return ()
      else
        match (← getLCtx).getAt? (i+1) with
        | none => collectLetDepsAux i
        | some localDecl =>
          if (← get).contains localDecl.fvarId then
            collectLetDeclsFrom localDecl.type
            match localDecl.value? with
            | some val => collectLetDeclsFrom val
            | _ =>  pure ()
          collectLetDepsAux i

  /- Computes the set `ys`. It is a set of `FVarId`s, -/
  collectLetDeps : MetaM NameHashSet := do
    let lctx ← getLCtx
    let start := lctx.getFVar! xs[0] |>.index
    let stop  := lctx.getFVar! xs.back |>.index
    let s := xs.foldl (init := {}) fun s x => s.insert x.fvarId!
    let (_, s) ← collectLetDepsAux stop |>.run start |>.run s
    return s

  /- Computes the array `ys` containing let-decls between `xs[0]` and `xs.back` that
     some `x` in `xs` depends on. -/
  addLetDeps : MetaM (Array Expr) := do
    let lctx ← getLCtx
    let s ← collectLetDeps
    /- Convert `s` into the array `ys` -/
    let start := lctx.getFVar! xs[0] |>.index
    let stop  := lctx.getFVar! xs.back |>.index
    let mut ys := #[]
    for i in [start:stop+1] do
      match lctx.getAt? i with
      | none => pure ()
      | some localDecl =>
        if s.contains localDecl.fvarId then
          ys := ys.push localDecl.toExpr
    return ys

/-
  Each metavariable is declared in a particular local context.
  We use the notation `C |- ?m : t` to denote a metavariable `?m` that
  was declared at the local context `C` with type `t` (see `MetavarDecl`).
  We also use `?m@C` as a shorthand for `C |- ?m : t` where `t` is the type of `?m`.

  The following method process the unification constraint

       ?m@C a₁ ... aₙ =?= t

  We say the unification constraint is a pattern IFF

    1) `a₁ ... aₙ` are pairwise distinct free variables that are *not* let-variables.
    2) `a₁ ... aₙ` are not in `C`
    3) `t` only contains free variables in `C` and/or `{a₁, ..., aₙ}`
    4) For every metavariable `?m'@C'` occurring in `t`, `C'` is a subprefix of `C`
    5) `?m` does not occur in `t`

  Claim: we don't have to check free variable declarations. That is,
  if `t` contains a reference to `x : A := v`, we don't need to check `v`.
  Reason: The reference to `x` is a free variable, and it must be in `C` (by 1 and 3).
  If `x` is in `C`, then any metavariable occurring in `v` must have been defined in a strict subprefix of `C`.
  So, condition 4 and 5 are satisfied.

  If the conditions above have been satisfied, then the
  solution for the unification constrain is

    ?m := fun a₁ ... aₙ => t

  Now, we consider some workarounds/approximations.

 A1) Suppose `t` contains a reference to `x : A := v` and `x` is not in `C` (failed condition 3)
     (precise) solution: unfold `x` in `t`.

 A2) Suppose some `aᵢ` is in `C` (failed condition 2)
     (approximated) solution (when `config.ctxApprox` is set to true) :
     ignore condition and also use

        ?m := fun a₁ ... aₙ => t

   Here is an example where this approximation fails:
   Given `C` containing `a : nat`, consider the following two constraints
         ?m@C a =?= a
         ?m@C b =?= a

   If we use the approximation in the first constraint, we get
         ?m := fun x => x
   when we apply this solution to the second one we get a failure.

   IMPORTANT: When applying this approximation we need to make sure the
   abstracted term `fun a₁ ... aₙ => t` is type correct. The check
   can only be skipped in the pattern case described above. Consider
   the following example. Given the local context

      (α : Type) (a : α)

   we try to solve

     ?m α =?= @id α a

   If we use the approximation above we obtain:

     ?m := (fun α' => @id α' a)

   which is a type incorrect term. `a` has type `α` but it is expected to have
   type `α'`.

   The problem occurs because the right hand side contains a free variable
   `a` that depends on the free variable `α` being abstracted. Note that
   this dependency cannot occur in patterns.

   We can address this by type checking
   the term after abstraction. This is not a significant performance
   bottleneck because this case doesn't happen very often in practice
   (262 times when compiling stdlib on Jan 2018). The second example
   is trickier, but it also occurs less frequently (8 times when compiling
   stdlib on Jan 2018, and all occurrences were at Init/Control when
   we define monads and auxiliary combinators for them).
   We considered three options for the addressing the issue on the second example:

 A3) `a₁ ... aₙ` are not pairwise distinct (failed condition 1).
   In Lean3, we would try to approximate this case using an approach similar to A2.
   However, this approximation complicates the code, and is never used in the
   Lean3 stdlib and mathlib.

 A4) `t` contains a metavariable `?m'@C'` where `C'` is not a subprefix of `C`.
   If `?m'` is assigned, we substitute.
   If not, we create an auxiliary metavariable with a smaller scope.
   Actually, we let `elimMVarDeps` at `MetavarContext.lean` to perform this step.

 A5) If some `aᵢ` is not a free variable,
     then we use first-order unification (if `config.foApprox` is set to true)

       ?m a_1 ... a_i a_{i+1} ... a_{i+k} =?= f b_1 ... b_k

   reduces to

       ?M a_1 ... a_i =?= f
       a_{i+1}        =?= b_1
       ...
       a_{i+k}        =?= b_k

 A6) If (m =?= v) is of the form

        ?m a_1 ... a_n =?= ?m b_1 ... b_k

     then we use first-order unification (if `config.foApprox` is set to true)

 A7) When `foApprox`, we may use another approximation (`constApprox`) for solving constraints of the form
     ```
     ?m s₁ ... sₙ =?= t
     ```
     where `s₁ ... sₙ` are arbitrary terms. We solve them by assigning the constant function to `?m`.
     ```
     ?m := fun _ ... _ => t
     ```

     In general, this approximation may produce bad solutions, and may prevent coercions from being tried.
     For example, consider the term `pure (x > 0)` with inferred type `?m Prop` and expected type `IO Bool`.
     In this situation, the
     elaborator generates the unification constraint
     ```
     ?m Prop =?= IO Bool
     ```
     It is not a higher-order pattern, nor first-order approximation is applicable. However, constant approximation
     produces the bogus solution `?m := fun _ => IO Bool`, and prevents the system from using the coercion from
     the decidable proposition `x > 0` to `Bool`.

     On the other hand, the constant approximation is desirable for elaborating the term
     ```
     let f (x : _) := pure "hello"; f ()
     ```
     with expected type `IO String`.
     In this example, the following unification contraint is generated.
     ```
     ?m () String =?= IO String
     ```
     It is not a higher-order pattern, first-order approximation reduces it to
     ```
     ?m () =?= IO
     ```
     which fails to be solved. However, constant approximation solves it by assigning
     ```
     ?m := fun _ => IO
     ```
     Note that `f`s type is `(x : ?α) -> ?m x String`. The metavariable `?m` may depend on `x`.
     If `constApprox` is set to true, we use constant approximation. Otherwise, we use a heuristic to decide
     whether we should apply it or not. The heuristic is based on observing where the constraints above come from.
     In the first example, the constraint `?m Prop =?= IO Bool` come from polymorphic method where `?m` is expected to
     be a **function** of type `Type -> Type`. In the second example, the first argument of `?m` is used to model
     a **potential** dependency on `x`. By using constant approximation here, we are just saying the type of `f`
     does **not** depend on `x`. We claim this is a reasonable approximation in practice. Moreover, it is expected
     by any functional programmer used to non-dependently type languages (e.g., Haskell).
     We distinguish the two cases above by using the field `numScopeArgs` at `MetavarDecl`. This fiels tracks
     how many metavariable arguments are representing dependencies.
-/

def mkAuxMVar (lctx : LocalContext) (localInsts : LocalInstances) (type : Expr) (numScopeArgs : Nat := 0) : MetaM Expr := do
  mkFreshExprMVarAt lctx localInsts type MetavarKind.natural Name.anonymous numScopeArgs

namespace CheckAssignment

builtin_initialize checkAssignmentExceptionId : InternalExceptionId ← registerInternalExceptionId `checkAssignment
builtin_initialize outOfScopeExceptionId : InternalExceptionId ← registerInternalExceptionId `outOfScope

structure State where
  cache : ExprStructMap Expr := {}

structure Context where
  mvarId        : MVarId
  mvarDecl      : MetavarDecl
  fvars         : Array Expr
  hasCtxLocals  : Bool
  rhs           : Expr

abbrev CheckAssignmentM := ReaderT Context $ StateRefT State MetaM

def throwCheckAssignmentFailure : CheckAssignmentM α :=
  throw <| Exception.internal checkAssignmentExceptionId

def throwOutOfScopeFVar : CheckAssignmentM α :=
  throw <| Exception.internal outOfScopeExceptionId

private def findCached? (e : Expr) : CheckAssignmentM (Option Expr) := do
  return (← get).cache.find? e

private def cache (e r : Expr) : CheckAssignmentM Unit := do
  modify fun s => { s with cache := s.cache.insert e r }

instance : MonadCache Expr Expr CheckAssignmentM where
  findCached? := findCached?
  cache       := cache

@[inline] private def visit (f : Expr → CheckAssignmentM Expr) (e : Expr) : CheckAssignmentM Expr :=
  if !e.hasExprMVar && !e.hasFVar then pure e else checkCache e (fun _ => f e)

private def addAssignmentInfo (msg : MessageData) : CheckAssignmentM MessageData := do
  let ctx ← read
  return m!"{msg} @ {mkMVar ctx.mvarId} {ctx.fvars} := {ctx.rhs}"

@[inline] def run (x : CheckAssignmentM Expr) (mvarId : MVarId) (fvars : Array Expr) (hasCtxLocals : Bool) (v : Expr) : MetaM (Option Expr) := do
  let mvarDecl ← getMVarDecl mvarId
  let ctx := { mvarId := mvarId, mvarDecl := mvarDecl, fvars := fvars, hasCtxLocals := hasCtxLocals, rhs := v : Context }
  let x : CheckAssignmentM (Option Expr) :=
    catchInternalIds [outOfScopeExceptionId, checkAssignmentExceptionId]
      (do let e ← x; return some e)
      (fun _ => pure none)
  x.run ctx |>.run' {}

mutual

  partial def checkFVar (fvar : Expr) : CheckAssignmentM Expr := do
    let ctxMeta ← readThe Meta.Context
    let ctx ← read
    if ctx.mvarDecl.lctx.containsFVar fvar then
      pure fvar
    else
      let lctx := ctxMeta.lctx
      match lctx.findFVar? fvar with
      | some (LocalDecl.ldecl (value := v) ..) => visit check v
      | _ =>
        if ctx.fvars.contains fvar then pure fvar
        else
          traceM `Meta.isDefEq.assign.outOfScopeFVar do addAssignmentInfo fvar
          throwOutOfScopeFVar

  partial def checkMVar (mvar : Expr) : CheckAssignmentM Expr := do
    let mvarId := mvar.mvarId!
    let ctx  ← read
    let mctx ← getMCtx
    if mvarId == ctx.mvarId then
      traceM `Meta.isDefEq.assign.occursCheck <| addAssignmentInfo "occurs check failed"
      throwCheckAssignmentFailure
    else match mctx.getExprAssignment? mvarId with
      | some v => check v
      | none   =>
        match mctx.findDecl? mvarId with
        | none          => throwUnknownMVar mvarId
        | some mvarDecl =>
          if ctx.hasCtxLocals then
            throwCheckAssignmentFailure -- It is not a pattern, then we fail and fall back to FO unification
          else if mvarDecl.lctx.isSubPrefixOf ctx.mvarDecl.lctx ctx.fvars then
            /- The local context of `mvar` - free variables being abstracted is a subprefix of the metavariable being assigned.
               We "substract" variables being abstracted because we use `elimMVarDeps` -/
            pure mvar
          else if mvarDecl.depth != mctx.depth || mvarDecl.kind.isSyntheticOpaque then
            traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
            throwCheckAssignmentFailure
          else
            let ctxMeta ← readThe Meta.Context
            if ctxMeta.config.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx then
              /- Create an auxiliary metavariable with a smaller context and "checked" type.
                 Note that `mvarType` may be different from `mvarDecl.type`. Example: `mvarType` contains
                 a metavariable that we also need to reduce the context.

                 We remove from `ctx.mvarDecl.lctx` any variable that is not in `mvarDecl.lctx`
                 or in `ctx.fvars`. We don't need to remove the ones in `ctx.fvars` because
                 `elimMVarDeps` will take care of them.

                 First, we collect `toErase` the variables that need to be erased.
                 Notat that if a variable is `ctx.fvars`, but it depends on variable at `toErase`,
                 we must also erase it.
              -/
              let toErase := mvarDecl.lctx.foldl (init := #[]) fun toErase localDecl =>
                if ctx.mvarDecl.lctx.contains localDecl.fvarId then
                  toErase
                else if ctx.fvars.any fun fvar => fvar.fvarId! == localDecl.fvarId then
                  if mctx.findLocalDeclDependsOn localDecl fun fvarId => toErase.contains fvarId then
                    -- localDecl depends on a variable that will be erased. So, we must add it to `toErase` too
                    toErase.push localDecl.fvarId
                  else
                    toErase
                else
                  toErase.push localDecl.fvarId
              let lctx := toErase.foldl (init := mvarDecl.lctx) fun lctx toEraseFVar =>
                lctx.erase toEraseFVar
              /- Compute new set of local instances. -/
              let localInsts := mvarDecl.localInstances.filter fun localInst => toErase.contains localInst.fvar.fvarId!
              let mvarType ← check mvarDecl.type
              let newMVar ← mkAuxMVar lctx localInsts mvarType mvarDecl.numScopeArgs
              modifyThe Meta.State fun s => { s with mctx := s.mctx.assignExpr mvarId newMVar }
              pure newMVar
            else
              traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
              throwCheckAssignmentFailure

  /-
    Auxiliary function used to "fix" subterms of the form `?m x_1 ... x_n` where `x_i`s are free variables,
    and one of them is out-of-scope.
    See `Expr.app` case at `check`.
    If `ctxApprox` is true, then we solve this case by creating a fresh metavariable ?n with the correct scope,
    an assigning `?m := fun _ ... _ => ?n` -/
  partial def assignToConstFun (mvar : Expr) (numArgs : Nat) (newMVar : Expr) : MetaM Bool := do
    let mvarType ← inferType mvar
    forallBoundedTelescope mvarType numArgs fun xs _ => do
      if xs.size != numArgs then pure false
      else
        let some v ← mkLambdaFVarsWithLetDeps xs newMVar | return false
        match (← checkAssignmentAux mvar.mvarId! #[] false v) with
        | some v => checkTypesAndAssign mvar v
        | none   => return false

  -- See checkAssignment
  partial def checkAssignmentAux (mvarId : MVarId) (fvars : Array Expr) (hasCtxLocals : Bool) (v : Expr) : MetaM (Option Expr) := do
    run (check v) mvarId fvars hasCtxLocals v

  partial def checkApp (e : Expr) : CheckAssignmentM Expr :=
    e.withApp fun f args => do
      let ctxMeta ← readThe Meta.Context
      if f.isMVar && ctxMeta.config.ctxApprox && args.all Expr.isFVar then
        let f ← visit checkMVar f
        catchInternalId outOfScopeExceptionId
          (do
            let args ← args.mapM (visit check)
            return mkAppN f args)
          (fun ex => do
            if !f.isMVar then
              throw ex
            else if (← isDelayedAssigned f.mvarId!) then
              throw ex
            else
              let eType ← inferType e
              let mvarType ← check eType
              /- Create an auxiliary metavariable with a smaller context and "checked" type, assign `?f := fun _ => ?newMVar`
                    Note that `mvarType` may be different from `eType`. -/
              let ctx ← read
              let newMVar ← mkAuxMVar ctx.mvarDecl.lctx ctx.mvarDecl.localInstances mvarType
              if (← assignToConstFun f args.size newMVar) then
                pure newMVar
              else
                throw ex)
      else
        let f ← visit check f
        let args ← args.mapM (visit check)
        return mkAppN f args

  partial def check (e : Expr) : CheckAssignmentM Expr := do
    match e with
    | Expr.mdata _ b _     => return e.updateMData! (← visit check b)
    | Expr.proj _ _ s _    => return e.updateProj! (← visit check s)
    | Expr.lam _ d b _     => return e.updateLambdaE! (← visit check d) (← visit check b)
    | Expr.forallE _ d b _ => return e.updateForallE! (← visit check d) (← visit check b)
    | Expr.letE _ t v b _  => return e.updateLet! (← visit check t) (← visit check v) (← visit check b)
    | Expr.bvar ..         => return e
    | Expr.sort ..         => return e
    | Expr.const ..        => return e
    | Expr.lit ..          => return e
    | Expr.fvar ..         => visit checkFVar e
    | Expr.mvar ..         => visit checkMVar e
    | Expr.app ..          =>
      checkApp e
      -- TODO: investigate whether the following feature is too expensive or not
      /-
      catchInternalIds [checkAssignmentExceptionId, outOfScopeExceptionId]
        (checkApp e)
        fun ex => do
          let e' ← whnfR e
          if e != e' then
            check e'
          else
            throw ex
      -/
end

end CheckAssignment

namespace CheckAssignmentQuick

partial def check
    (hasCtxLocals ctxApprox : Bool)
    (mctx : MetavarContext) (lctx : LocalContext) (mvarDecl : MetavarDecl) (mvarId : MVarId) (fvars : Array Expr) (e : Expr) : Bool :=
  let rec visit (e : Expr) : Bool :=
    if !e.hasExprMVar && !e.hasFVar then
      true
    else match e with
    | Expr.mdata _ b _     => visit b
    | Expr.proj _ _ s _    => visit s
    | Expr.app f a _       => visit f && visit a
    | Expr.lam _ d b _     => visit d && visit b
    | Expr.forallE _ d b _ => visit d && visit b
    | Expr.letE _ t v b _  => visit t && visit v && visit b
    | Expr.bvar ..         => true
    | Expr.sort ..         => true
    | Expr.const ..        => true
    | Expr.lit ..          => true
    | Expr.fvar fvarId ..  =>
      if mvarDecl.lctx.contains fvarId then true
      else match lctx.find? fvarId with
        | some (LocalDecl.ldecl (value := v) ..) => false -- need expensive CheckAssignment.check
        | _ =>
          if fvars.any fun x => x.fvarId! == fvarId then true
          else false -- We could throw an exception here, but we would have to use ExceptM. So, we let CheckAssignment.check do it
    | Expr.mvar mvarId' _  =>
      match mctx.getExprAssignment? mvarId' with
      | some _ => false -- use CheckAssignment.check to instantiate
      | none   =>
        if mvarId' == mvarId then false -- occurs check failed, use CheckAssignment.check to throw exception
        else match mctx.findDecl? mvarId' with
          | none           => false
          | some mvarDecl' =>
            if hasCtxLocals then false -- use CheckAssignment.check
            else if mvarDecl'.lctx.isSubPrefixOf mvarDecl.lctx fvars then true
            else false -- use CheckAssignment.check
  visit e

end CheckAssignmentQuick

/--
  Auxiliary function for handling constraints of the form `?m a₁ ... aₙ =?= v`.
  It will check whether we can perform the assignment
  ```
  ?m := fun fvars => v
  ```
  The result is `none` if the assignment can't be performed.
  The result is `some newV` where `newV` is a possibly updated `v`. This method may need
  to unfold let-declarations. -/
def checkAssignment (mvarId : MVarId) (fvars : Array Expr) (v : Expr) : MetaM (Option Expr) := do
  /- Check whether `mvarId` occurs in the type of `fvars` or not. If it does, return `none`
     to prevent us from creating the cyclic assignment `?m := fun fvars => v` -/
  for fvar in fvars do
    unless (← occursCheck mvarId (← inferType fvar)) do
      return none
  if !v.hasExprMVar && !v.hasFVar then
    pure (some v)
  else
    let mvarDecl ← getMVarDecl mvarId
    let hasCtxLocals := fvars.any fun fvar => mvarDecl.lctx.containsFVar fvar
    let ctx ← read
    let mctx ← getMCtx
    if CheckAssignmentQuick.check hasCtxLocals ctx.config.ctxApprox mctx ctx.lctx mvarDecl mvarId fvars v then
      pure (some v)
    else
      let v ← instantiateMVars v
      CheckAssignment.checkAssignmentAux mvarId fvars hasCtxLocals v

private def processAssignmentFOApproxAux (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
  match v with
  | Expr.app f a _ =>
    if args.isEmpty then
      pure false
    else
      Meta.isExprDefEqAux args.back a <&&> Meta.isExprDefEqAux (mkAppRange mvar 0 (args.size - 1) args) f
  | _              => pure false

/-
  Auxiliary method for applying first-order unification. It is an approximation.
  Remark: this method is trying to solve the unification constraint:

      ?m a₁ ... aₙ =?= v

   It is uses processAssignmentFOApproxAux, if it fails, it tries to unfold `v`.

   We have added support for unfolding here because we want to be able to solve unification problems such as

      ?m Unit =?= ITactic

   where `ITactic` is defined as

   def ITactic := Tactic Unit
-/
private partial def processAssignmentFOApprox (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
  let rec loop (v : Expr) := do
    let cfg ← getConfig
    if !cfg.foApprox then
      pure false
    else
      trace[Meta.isDefEq.foApprox] "{mvar} {args} := {v}"
      let v := v.headBeta
      if (← checkpointDefEq <| processAssignmentFOApproxAux mvar args v) then
        pure true
      else
        match (← unfoldDefinition? v) with
        | none   => pure false
        | some v => loop v
  loop v

private partial def simpAssignmentArgAux : Expr → MetaM Expr
  | Expr.mdata _ e _       => simpAssignmentArgAux e
  | e@(Expr.fvar fvarId _) => do
    let decl ← getLocalDecl fvarId
    match decl.value? with
    | some value => simpAssignmentArgAux value
    | _          => pure e
  | e => pure e

/- Auxiliary procedure for processing `?m a₁ ... aₙ =?= v`.
   We apply it to each `aᵢ`. It instantiates assigned metavariables if `aᵢ` is of the form `f[?n] b₁ ... bₘ`,
   and then removes metadata, and zeta-expand let-decls. -/
private def simpAssignmentArg (arg : Expr) : MetaM Expr := do
  let arg ← if arg.getAppFn.hasExprMVar then instantiateMVars arg else pure arg
  simpAssignmentArgAux arg

/- Assign `mvar := fun a_1 ... a_{numArgs} => v`.
   We use it at `processConstApprox` and `isDefEqMVarSelf` -/
private def assignConst (mvar : Expr) (numArgs : Nat) (v : Expr) : MetaM Bool := do
  let mvarDecl ← getMVarDecl mvar.mvarId!
  forallBoundedTelescope mvarDecl.type numArgs fun xs _ => do
    if xs.size != numArgs then
      pure false
    else
      let some v ← mkLambdaFVarsWithLetDeps xs v | pure false
      match (← checkAssignment mvar.mvarId! #[] v) with
      | none   => pure false
      | some v =>
        trace[Meta.isDefEq.constApprox] "{mvar} := {v}"
        checkTypesAndAssign mvar v

private def processConstApprox (mvar : Expr) (numArgs : Nat) (v : Expr) : MetaM Bool := do
  let cfg ← getConfig
  let mvarId := mvar.mvarId!
  let mvarDecl ← getMVarDecl mvarId
  if mvarDecl.numScopeArgs == numArgs || cfg.constApprox then
    assignConst mvar numArgs v
  else
    pure false

/-- Tries to solve `?m a₁ ... aₙ =?= v` by assigning `?m`.
    It assumes `?m` is unassigned. -/
private partial def processAssignment (mvarApp : Expr) (v : Expr) : MetaM Bool :=
  traceCtx `Meta.isDefEq.assign do
    trace[Meta.isDefEq.assign] "{mvarApp} := {v}"
    let mvar := mvarApp.getAppFn
    let mvarDecl ← getMVarDecl mvar.mvarId!
    let rec process (i : Nat) (args : Array Expr) (v : Expr) := do
      let cfg ← getConfig
      let useFOApprox (args : Array Expr) : MetaM Bool :=
        processAssignmentFOApprox mvar args v <||> processConstApprox mvar args.size v
      if h : i < args.size then
        let arg := args.get ⟨i, h⟩
        let arg ← simpAssignmentArg arg
        let args := args.set ⟨i, h⟩ arg
        match arg with
        | Expr.fvar fvarId _ =>
          if args[0:i].any fun prevArg => prevArg == arg then
            useFOApprox args
          else if mvarDecl.lctx.contains fvarId && !cfg.quasiPatternApprox then
            useFOApprox args
          else
            process (i+1) args v
        | _ =>
          useFOApprox args
      else
        let v ← instantiateMVars v -- enforce A4
        if v.getAppFn == mvar then
          -- using A6
          useFOApprox args
        else
          let mvarId := mvar.mvarId!
          match (← checkAssignment mvarId args v) with
          | none   => useFOApprox args
          | some v => do
            trace[Meta.isDefEq.assign.beforeMkLambda] "{mvar} {args} := {v}"
            let some v ← mkLambdaFVarsWithLetDeps args v | return false
            if args.any (fun arg => mvarDecl.lctx.containsFVar arg) then
              /- We need to type check `v` because abstraction using `mkLambdaFVars` may have produced
                 a type incorrect term. See discussion at A2 -/
              if (← isTypeCorrect v) then
                checkTypesAndAssign mvar v
              else
                trace[Meta.isDefEq.assign.typeError] "{mvar} := {v}"
                useFOApprox args
            else
              checkTypesAndAssign mvar v
    process 0 mvarApp.getAppArgs v

/--
  Similar to processAssignment, but if it fails, compute v's whnf and try again.
  This helps to solve constraints such as `?m =?= { α := ?m, ... }.α`
  Note this is not perfect solution since we still fail occurs check for constraints such as
  ```lean
    ?m =?= List { α := ?m, β := Nat }.β
  ```
-/
private def processAssignment' (mvarApp : Expr) (v : Expr) : MetaM Bool := do
  if (← processAssignment mvarApp v) then
    return true
  else
    let vNew ← whnf v
    if vNew != v then
      if mvarApp == vNew then
        return true
      else
        processAssignment mvarApp vNew
    else
      return false

private def isDeltaCandidate? (t : Expr) : MetaM (Option ConstantInfo) := do
  match t.getAppFn with
  | Expr.const c _ _ =>
    match (← getConst? c) with
    | r@(some info) => if info.hasValue then return r else return none
    | _             => return none
  | _ => pure none

/-- Auxiliary method for isDefEqDelta -/
private def isListLevelDefEq (us vs : List Level) : MetaM LBool :=
  toLBoolM <| isListLevelDefEqAux us vs

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqLeft (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldLeft] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqRight (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldRight] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Auxiliary method for isDefEqDelta -/
private def isDefEqLeftRight (fn : Name) (t s : Expr) : MetaM LBool := do
  trace[Meta.isDefEq.delta.unfoldLeftRight] fn
  toLBoolM <| Meta.isExprDefEqAux t s

/-- Try to solve `f a₁ ... aₙ =?= f b₁ ... bₙ` by solving `a₁ =?= b₁, ..., aₙ =?= bₙ`.

    Auxiliary method for isDefEqDelta -/
private def tryHeuristic (t s : Expr) : MetaM Bool :=
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  traceCtx `Meta.isDefEq.delta do
    /-
      We process arguments before universe levels to reduce a source of brittleness in the TC procedure.

      In the TC procedure, we can solve problems containing metavariables.
      If the TC procedure tries to assign one of these metavariables, it interrupts the search
      using a "stuck" exception. The elaborator catches it, and "interprets" it as "we should try again later".
      Now suppose we have a TC problem, and there are two "local" candidate instances we can try: "bad" and "good".
      The "bad" candidate is stuck because of a universe metavariable in the TC problem.
      If we try "bad" first, the TC procedure is interrupted. Moreover, if we have ignored the exception,
      "bad" would fail anyway trying to assign two different free variables `α =?= β`.
      Example: `Preorder.{?u} α =?= Preorder.{?v} β`, where `?u` and `?v` are universe metavariables that were
      not created by the TC procedure.
      The key issue here is that we have an `isDefEq t s` invocation that is interrupted by the "stuck" exception,
      but it would have failed anyway if we had continued processing it.
      By solving the arguments first, we make the example above fail without throwing the "stuck" exception.

      TODO: instead of throwing an exception as soon as we get stuck, we should just set a flag.
      Then the entry-point for `isDefEq` checks the flag before returning `true`.
    -/
    checkpointDefEq do
      let b ← isDefEqArgs tFn t.getAppArgs s.getAppArgs
              <&&>
              isListLevelDefEqAux tFn.constLevels! sFn.constLevels!
      unless b do
        trace[Meta.isDefEq.delta] "heuristic failed {t} =?= {s}"
      pure b

/-- Auxiliary method for isDefEqDelta -/
private abbrev unfold (e : Expr) (failK : MetaM α) (successK : Expr → MetaM α) : MetaM α := do
  match (← unfoldDefinition? e) with
  | some e => successK e
  | none   => failK

/-- Auxiliary method for isDefEqDelta -/
private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
  match t, s with
  | Expr.const _ ls₁ _, Expr.const _ ls₂ _ => isListLevelDefEq ls₁ ls₂
  | Expr.app _ _ _,     Expr.app _ _ _     =>
    if (← tryHeuristic t s) then
      pure LBool.true
    else
      unfold t
       (unfold s (pure LBool.false) (fun s => isDefEqRight fn t s))
       (fun t => unfold s (isDefEqLeft fn t s) (fun s => isDefEqLeftRight fn t s))
  | _, _ => pure LBool.false

private def sameHeadSymbol (t s : Expr) : Bool :=
  match t.getAppFn, s.getAppFn with
  | Expr.const c₁ _ _, Expr.const c₂ _ _ => true
  | _,                 _                 => false

/--
  - If headSymbol (unfold t) == headSymbol s, then unfold t
  - If headSymbol (unfold s) == headSymbol t, then unfold s
  - Otherwise unfold t and s if possible.

  Auxiliary method for isDefEqDelta -/
private def unfoldComparingHeadsDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool :=
  unfold t
    (unfold s
      (pure LBool.undef) -- `t` and `s` failed to be unfolded
      (fun s => isDefEqRight sInfo.name t s))
    (fun tNew =>
      if sameHeadSymbol tNew s then
        isDefEqLeft tInfo.name tNew s
      else
        unfold s
          (isDefEqLeft tInfo.name tNew s)
          (fun sNew =>
            if sameHeadSymbol t sNew then
              isDefEqRight sInfo.name t sNew
            else
              isDefEqLeftRight tInfo.name tNew sNew))

/-- If `t` and `s` do not contain metavariables, then use
    kernel definitional equality heuristics.
    Otherwise, use `unfoldComparingHeadsDefEq`.

    Auxiliary method for isDefEqDelta -/
private def unfoldDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool :=
  if !t.hasExprMVar && !s.hasExprMVar then
    /- If `t` and `s` do not contain metavariables,
       we simulate strategy used in the kernel. -/
    if tInfo.hints.lt sInfo.hints then
      unfold t (unfoldComparingHeadsDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
    else if sInfo.hints.lt tInfo.hints then
      unfold s (unfoldComparingHeadsDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
    else
      unfoldComparingHeadsDefEq tInfo sInfo t s
  else
    unfoldComparingHeadsDefEq tInfo sInfo t s

/--
  When `TransparencyMode` is set to `default` or `all`.
  If `t` is reducible and `s` is not ==> `isDefEqLeft  (unfold t) s`
  If `s` is reducible and `t` is not ==> `isDefEqRight t (unfold s)`

  Otherwise, use `unfoldDefEq`

  Auxiliary method for isDefEqDelta -/
private def unfoldReducibeDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := do
  if (← shouldReduceReducibleOnly) then
    unfoldDefEq tInfo sInfo t s
  else
    let tReducible ← isReducible tInfo.name
    let sReducible ← isReducible sInfo.name
    if tReducible && !sReducible then
      unfold t (unfoldDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
    else if !tReducible && sReducible then
      unfold s (unfoldDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
    else
      unfoldDefEq tInfo sInfo t s

/--
  If `t` is a projection function application and `s` is not ==> `isDefEqRight t (unfold s)`
  If `s` is a projection function application and `t` is not ==> `isDefEqRight (unfold t) s`

  Otherwise, use `unfoldReducibeDefEq`

  Auxiliary method for isDefEqDelta -/
private def unfoldNonProjFnDefEq (tInfo sInfo : ConstantInfo) (t s : Expr) : MetaM LBool := do
  let tProj? ← isProjectionFn tInfo.name
  let sProj? ← isProjectionFn sInfo.name
  if tProj? && !sProj? then
    unfold s (unfoldDefEq tInfo sInfo t s) fun s => isDefEqRight sInfo.name t s
  else if !tProj? && sProj? then
    unfold t (unfoldDefEq tInfo sInfo t s) fun t => isDefEqLeft tInfo.name t s
  else
    unfoldReducibeDefEq tInfo sInfo t s

/--
  isDefEq by lazy delta reduction.
  This method implements many different heuristics:
  1- If only `t` can be unfolded => then unfold `t` and continue
  2- If only `s` can be unfolded => then unfold `s` and continue
  3- If `t` and `s` can be unfolded and they have the same head symbol, then
     a) First try to solve unification by unifying arguments.
     b) If it fails, unfold both and continue.
     Implemented by `unfoldBothDefEq`
  4- If `t` is a projection function application and `s` is not => then unfold `s` and continue.
  5- If `s` is a projection function application and `t` is not => then unfold `t` and continue.
  Remark: 4&5 are implemented by `unfoldNonProjFnDefEq`
  6- If `t` is reducible and `s` is not => then unfold `t` and continue.
  7- If `s` is reducible and `t` is not => then unfold `s` and continue
  Remark: 6&7 are implemented by `unfoldReducibeDefEq`
  8- If `t` and `s` do not contain metavariables, then use heuristic used in the Kernel.
     Implemented by `unfoldDefEq`
  9- If `headSymbol (unfold t) == headSymbol s`, then unfold t and continue.
  10- If `headSymbol (unfold s) == headSymbol t`, then unfold s
  11- Otherwise, unfold `t` and `s` and continue.
  Remark: 9&10&11 are implemented by `unfoldComparingHeadsDefEq` -/
private def isDefEqDelta (t s : Expr) : MetaM LBool := do
  let tInfo? ← isDeltaCandidate? t.getAppFn
  let sInfo? ← isDeltaCandidate? s.getAppFn
  match tInfo?, sInfo? with
  | none,       none       => pure LBool.undef
  | some tInfo, none       => unfold t (pure LBool.undef) fun t => isDefEqLeft tInfo.name t s
  | none,       some sInfo => unfold s (pure LBool.undef) fun s => isDefEqRight sInfo.name t s
  | some tInfo, some sInfo =>
    if tInfo.name == sInfo.name then
      unfoldBothDefEq tInfo.name t s
    else
      unfoldNonProjFnDefEq tInfo sInfo t s

private def isAssigned : Expr → MetaM Bool
  | Expr.mvar mvarId _ => isExprMVarAssigned mvarId
  | _                  => pure false

private def isDelayedAssignedHead (tFn : Expr) (t : Expr) : MetaM Bool := do
  match tFn with
  | Expr.mvar mvarId _ =>
    if (← isDelayedAssigned mvarId) then
      let tNew ← instantiateMVars t
      return tNew != t
    else
      pure false
  | _ => pure false

private def isSynthetic : Expr → MetaM Bool
  | Expr.mvar mvarId _ => do
    let mvarDecl ← getMVarDecl mvarId
    match mvarDecl.kind with
    | MetavarKind.synthetic       => pure true
    | MetavarKind.syntheticOpaque => pure true
    | MetavarKind.natural         => pure false
  | _                  => pure false

private def isAssignable : Expr → MetaM Bool
  | Expr.mvar mvarId _ => do let b ← isReadOnlyOrSyntheticOpaqueExprMVar mvarId; pure (!b)
  | _                  => pure false

private def etaEq (t s : Expr) : Bool :=
  match t.etaExpanded? with
  | some t => t == s
  | none   => false

private def isLetFVar (fvarId : FVarId) : MetaM Bool := do
  let decl ← getLocalDecl fvarId
  pure decl.isLet

private def isDefEqProofIrrel (t s : Expr) : MetaM LBool := do
  let status ← isProofQuick t
  match status with
  | LBool.false =>
    pure LBool.undef
  | LBool.true  =>
    let tType ← inferType t
    let sType ← inferType s
    toLBoolM <| Meta.isExprDefEqAux tType sType
  | LBool.undef =>
    let tType ← inferType t
    if (← isProp tType) then
      let sType ← inferType s
      toLBoolM <| Meta.isExprDefEqAux tType sType
    else
      pure LBool.undef

/- Try to solve constraint of the form `?m args₁ =?= ?m args₂`.
   - First try to unify `args₁` and `args₂`, and return true if successful
   - Otherwise, try to assign `?m` to a constant function of the form `fun x_1 ... x_n => ?n`
     where `?n` is a fresh metavariable. See `processConstApprox`. -/
private def isDefEqMVarSelf (mvar : Expr) (args₁ args₂ : Array Expr) : MetaM Bool := do
  if args₁.size != args₂.size then
    pure false
  else if (← isDefEqArgs mvar args₁ args₂) then
    pure true
  else if !(← isAssignable mvar) then
    pure false
  else
    let cfg ← getConfig
    let mvarId := mvar.mvarId!
    let mvarDecl ← getMVarDecl mvarId
    if mvarDecl.numScopeArgs == args₁.size || cfg.constApprox then
      let type ← inferType (mkAppN mvar args₁)
      let auxMVar ← mkAuxMVar mvarDecl.lctx mvarDecl.localInstances type
      assignConst mvar args₁.size auxMVar
    else
      pure false

/- Remove unnecessary let-decls -/
private def consumeLet : Expr → Expr
  | e@(Expr.letE _ _ _ b _) => if b.hasLooseBVars then e else consumeLet b
  | e                       => e

mutual

private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
  let t := consumeLet t
  let s := consumeLet s
  match t, s with
  | Expr.lit  l₁ _,      Expr.lit l₂ _       => return (l₁ == l₂).toLBool
  | Expr.sort u _,       Expr.sort v _       => toLBoolM <| isLevelDefEqAux u v
  | Expr.lam ..,         Expr.lam ..         => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
  | Expr.forallE ..,     Expr.forallE ..     => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
  | Expr.mdata _ t _,    s                   => isDefEqQuick t s
  | t,                   Expr.mdata _ s _    => isDefEqQuick t s
  | Expr.fvar fvarId₁ _, Expr.fvar fvarId₂ _ => do
    if (← isLetFVar fvarId₁ <||> isLetFVar fvarId₂) then
      pure LBool.undef
    else if fvarId₁ == fvarId₂ then
      pure LBool.true
    else
      isDefEqProofIrrel t s
  | t, s =>
    isDefEqQuickOther t s

private partial def isDefEqQuickOther (t s : Expr) : MetaM LBool := do
  if t == s then
    pure LBool.true
  else if etaEq t s || etaEq s t then
    pure LBool.true  -- t =?= (fun xs => t xs)
  else
    let tFn := t.getAppFn
    let sFn := s.getAppFn
    if !tFn.isMVar && !sFn.isMVar then
      pure LBool.undef
    else if (← isAssigned tFn) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isAssigned sFn) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if (← isDelayedAssignedHead tFn t) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isDelayedAssignedHead sFn s) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if (← isSynthetic tFn <&&> trySynthPending tFn) then
      let t ← instantiateMVars t
      isDefEqQuick t s
    else if (← isSynthetic sFn <&&> trySynthPending sFn) then
      let s ← instantiateMVars s
      isDefEqQuick t s
    else if tFn.isMVar && sFn.isMVar && tFn == sFn then
      Bool.toLBool <$> isDefEqMVarSelf tFn t.getAppArgs s.getAppArgs
    else
      let tAssign? ← isAssignable tFn
      let sAssign? ← isAssignable sFn
      let assignableMsg (b : Bool) := if b then "[assignable]" else "[nonassignable]"
      trace[Meta.isDefEq] "{t} {assignableMsg tAssign?} =?= {s} {assignableMsg sAssign?}"
      if tAssign? && !sAssign? then
        toLBoolM <| processAssignment' t s
      else if !tAssign? && sAssign? then
        toLBoolM <| processAssignment' s t
      else if !tAssign? && !sAssign? then
        if tFn.isMVar || sFn.isMVar then
          let ctx ← read
          if ctx.config.isDefEqStuckEx then do
            trace[Meta.isDefEq.stuck] "{t} =?= {s}"
            Meta.throwIsDefEqStuck
          else
            pure LBool.false
        else
          pure LBool.undef
      else
        isDefEqQuickMVarMVar t s

-- Both `t` and `s` are terms of the form `?m ...`
private partial def isDefEqQuickMVarMVar (t s : Expr) : MetaM LBool := do
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  let tMVarDecl ← getMVarDecl tFn.mvarId!
  let sMVarDecl ← getMVarDecl sFn.mvarId!
  if s.isMVar && !t.isMVar then
     /- Solve `?m t =?= ?n` by trying first `?n := ?m t`.
        Reason: this assignment is precise. -/
     if (← checkpointDefEq (processAssignment s t)) then
       pure LBool.true
     else
       toLBoolM <| processAssignment t s
  else
     if (← checkpointDefEq (processAssignment t s)) then
       pure LBool.true
     else
       toLBoolM <| processAssignment s t

end

@[inline] def whenUndefDo (x : MetaM LBool) (k : MetaM Bool) : MetaM Bool := do
  let status ← x
  match status with
  | LBool.true  => pure true
  | LBool.false => pure false
  | LBool.undef => k

@[specialize] private def unstuckMVar (e : Expr) (successK : Expr → MetaM Bool) (failK : MetaM Bool): MetaM Bool := do
  match (← getStuckMVar? e) with
  | some mvarId =>
    trace[Meta.isDefEq.stuckMVar] "found stuck MVar {mkMVar mvarId} : {← inferType (mkMVar mvarId)}"
    if (← Meta.synthPending mvarId) then
      let e ← instantiateMVars e
      successK e
    else
      failK
  | none   => failK

private def isDefEqOnFailure (t s : Expr) : MetaM Bool :=
  unstuckMVar t (fun t => Meta.isExprDefEqAux t s) <|
  unstuckMVar s (fun s => Meta.isExprDefEqAux t s) <|
  tryUnificationHints t s <||> tryUnificationHints s t

private def isDefEqProj : Expr → Expr → MetaM Bool
  | Expr.proj _ i t _, Expr.proj _ j s _ => pure (i == j) <&&> Meta.isExprDefEqAux t s
  | _, _ => pure false

/-
  Given applications `t` and `s` that are in WHNF (modulo the current transparency setting),
  check whether they are definitionally equal or not.
-/
private def isDefEqApp (t s : Expr) : MetaM Bool := do
  let tFn := t.getAppFn
  let sFn := s.getAppFn
  if tFn.isConst && sFn.isConst && tFn.constName! == sFn.constName! then
    /- See comment at `tryHeuristic` explaining why we processe arguments before universe levels. -/
    if (← checkpointDefEq (isDefEqArgs tFn t.getAppArgs s.getAppArgs <&&> isListLevelDefEqAux tFn.constLevels! sFn.constLevels!)) then
      return true
    else
      isDefEqOnFailure t s
  else if (← checkpointDefEq (Meta.isExprDefEqAux tFn s.getAppFn <&&> isDefEqArgs tFn t.getAppArgs s.getAppArgs)) then
    return true
  else
    isDefEqOnFailure t s

partial def isExprDefEqAuxImpl (t : Expr) (s : Expr) : MetaM Bool := do
  trace[Meta.isDefEq.step] "{t} =?= {s}"
  checkMaxHeartbeats "isDefEq"
  withNestedTraces do
  whenUndefDo (isDefEqQuick t s) do
  whenUndefDo (isDefEqProofIrrel t s) do
  let t' ← whnfCore t
  let s' ← whnfCore s
  if t != t' || s != s' then
    isExprDefEqAuxImpl t' s'
  else do
    if (← (isDefEqEta t s <||> isDefEqEta s t)) then pure true else
    if (← isDefEqProj t s) then pure true else
    whenUndefDo (isDefEqNative t s) do
    whenUndefDo (isDefEqNat t s) do
    whenUndefDo (isDefEqOffset t s) do
    whenUndefDo (isDefEqDelta t s) do
    if t.isConst && s.isConst then
      if t.constName! == s.constName! then isListLevelDefEqAux t.constLevels! s.constLevels! else pure false
    else if t.isApp && s.isApp then
      isDefEqApp t s
    else
      whenUndefDo (isDefEqStringLit t s) do
      isDefEqOnFailure t s

builtin_initialize
  isExprDefEqAuxRef.set isExprDefEqAuxImpl

builtin_initialize
  registerTraceClass `Meta.isDefEq
  registerTraceClass `Meta.isDefEq.foApprox
  registerTraceClass `Meta.isDefEq.constApprox
  registerTraceClass `Meta.isDefEq.delta
  registerTraceClass `Meta.isDefEq.step
  registerTraceClass `Meta.isDefEq.assign

end Lean.Meta


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop

structure MyTrue₁
structure MyTrue₂

@[aesop safe]
structure MyTrue₃ where
  tt : MyTrue₁

example : MyTrue₃ := by
  aesop
  apply MyTrue₁.mk

@[aesop safe]
structure MyFalse where
  falso : False

example : MyFalse := by
  aesop

example : MyFalse := by
  fail_if_success aesop (options := { terminal := true })

example : MyFalse := by
  aesop (options := { warnOnNonterminal := false })

@[aesop safe]
structure MyFalse₂ where
  falso : False
  tt : MyTrue₃

example : MyFalse₂ := by
  aesop


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Standard identity and composition functors
-/
import tactic.ext tactic.cache category.basic

universe variables u v w

section functor

variables {F : Type u → Type v}
variables {α β γ : Type u}
variables [functor F] [is_lawful_functor F]

lemma functor.map_id : (<$>) id = (id : F α → F α) :=
by apply funext; apply id_map

lemma functor.map_comp_map (f : α → β) (g : β → γ) :
  ((<$>) g ∘ (<$>) f : F α → F γ) = (<$>) (g ∘ f) :=
by apply funext; intro; rw comp_map

theorem functor.ext {F} : ∀ {F1 : functor F} {F2 : functor F}
  [@is_lawful_functor F F1] [@is_lawful_functor F F2]
  (H : ∀ α β (f : α → β) (x : F α),
    @functor.map _ F1 _ _ f x = @functor.map _ F2 _ _ f x),
  F1 = F2
| ⟨m, mc⟩ ⟨m', mc'⟩ H1 H2 H :=
begin
  cases show @m = @m', by funext α β f x; apply H,
  congr, funext α β,
  have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1,
  have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2,
  exact E1.trans E2.symm
end

end functor

def id.mk {α : Sort u} : α → id α := id

namespace functor

def const (α : Type*) (β : Type*) := α

@[pattern] def const.mk {α β} (x : α) : const α β := x

def const.mk' {α} (x : α) : const α punit := x

def const.run {α β} (x : const α β) : α := x

namespace const

protected lemma ext {α β} {x y : const α β} (h : x.run = y.run) : x = y := h

protected def map {γ α β} (f : α → β) (x : const γ β) : const γ α := x

instance {γ} : functor (const γ) :=
{ map := @const.map γ }

instance {γ} : is_lawful_functor (const γ) :=
by constructor; intros; refl

end const

def add_const (α : Type*) := const α

@[pattern]
def add_const.mk {α β} (x : α) : add_const α β := x

def add_const.run {α β} : add_const α β → α := id

instance add_const.functor {γ} : functor (add_const γ) :=
@const.functor γ

instance add_const.is_lawful_functor {γ} : is_lawful_functor (add_const γ) :=
@const.is_lawful_functor γ

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
F $ G α

@[pattern] def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : F (G α)) : comp F G α := x

def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : comp F G α) : F (G α) := x

namespace comp

variables {F : Type u → Type w} {G : Type v → Type u}

protected lemma ext
  {α} {x y : comp F G α} : x.run = y.run → x = y := id

variables [functor F] [functor G]

protected def map {α β : Type v} (h : α → β) : comp F G α → comp F G β
| (comp.mk x) := comp.mk ((<$>) h <$> x)

instance : functor (comp F G) := { map := @comp.map F G _ _ }

@[functor_norm] lemma map_mk {α β} (h : α → β) (x : F (G α)) :
  h <$> comp.mk x = comp.mk ((<$>) h <$> x) := rfl

variables [is_lawful_functor F] [is_lawful_functor G]
variables {α β γ : Type v}

protected lemma id_map : ∀ (x : comp F G α), comp.map id x = x
| (comp.mk x) := by simp [comp.map, functor.map_id]

protected lemma comp_map (g' : α → β) (h : β → γ) : ∀ (x : comp F G α),
           comp.map (h ∘ g') x = comp.map h (comp.map g' x)
| (comp.mk x) := by simp [comp.map, functor.map_comp_map g' h] with functor_norm

@[simp] protected lemma run_map (h : α → β) (x : comp F G α) :
  (h <$> x).run = (<$>) h <$> x.run := rfl

instance : is_lawful_functor (comp F G) :=
{ id_map := @comp.id_map F G _ _ _ _,
  comp_map := @comp.comp_map F G _ _ _ _ }

theorem functor_comp_id {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor F id _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor F id _ _ _ _) _ (λ α β f x, rfl)

theorem functor_id_comp {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor id F _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor id F _ _ _ _) _ (λ α β f x, rfl)

end comp

end functor

namespace ulift

instance : functor ulift :=
{ map := λ α β f, up ∘ f ∘ down }

end ulift


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen

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

/-!
# The `simp_rw` tactic

This module defines a tactic `simp_rw` which functions as a mix of `simp` and
`rw`. Like `rw`, it applies each rewrite rule in the given order, but like
`simp` it repeatedly applies these rules and also under binders like `∀ x, ...`,
`∃ x, ...` and `λ x, ...`.

## Implementation notes

The tactic works by taking each rewrite rule in turn and applying `simp only` to
it. Arguments to `simp_rw` are of the format used by `rw` and are translated to
their equivalents for `simp`.
-/

namespace Tactic.Interactive

open Interactive Interactive.Types Tactic

/-- `simp_rw` functions as a mix of `simp` and `rw`. Like `rw`, it applies each
rewrite rule in the given order, but like `simp` it repeatedly applies these
rules and also under binders like `∀ x, ...`, `∃ x, ...` and `λ x, ...`.

Usage:
  - `simp_rw [lemma_1, ..., lemma_n]` will rewrite the goal by applying the
    lemmas in that order. A lemma preceded by `←` is applied in the reverse direction.
  - `simp_rw [lemma_1, ..., lemma_n] at h₁ ... hₙ` will rewrite the given hypotheses.
  - `simp_rw [...] at ⊢ h₁ ... hₙ` rewrites the goal as well as the given hypotheses.
  - `simp_rw [...] at *` rewrites in the whole context: all hypotheses and the goal.

Lemmas passed to `simp_rw` must be expressions that are valid arguments to `simp`.

For example, neither `simp` nor `rw` can solve the following, but `simp_rw` can:
```lean
example {α β : Type} {f : α → β} {t : set β} :
  (∀ s, f '' s ⊆ t) = ∀ s : set α, ∀ x ∈ s, x ∈ f ⁻¹' t :=
by simp_rw [set.image_subset_iff, set.subset_def]
```
-/
unsafe def simp_rw (q : parse rw_rules) (l : parse location) : tactic Unit :=
  q.rules.mapM' fun rule => do
    let simp_arg :=
      if rule.symm then simp_arg_type.symm_expr rule.rule else simp_arg_type.expr rule.rule
    save_info rule
    simp none none tt [simp_arg] [] l
#align tactic.interactive.simp_rw tactic.interactive.simp_rw

-- equivalent to `simp only [rule] at l`
add_tactic_doc
  { Name := "simp_rw"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.simp_rw]
    tags := ["simplification"] }

end Tactic.Interactive


import .tab

open tactic
variable {p : Prop}

example : p :=
by do proof_by_contradiction

#exit

#check @classical.by_contradiction

example : p :=
by do refine ``(classical.by_contradiction _),
      -- trace "After refine : ", trace_state,
      intro `_,
      -- trace "After intro : ", trace_state,
      skip


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

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

open Tactic

namespace Tactic.Interactive

/-- `show_term { tac }` runs the tactic `tac`,
and then prints the term that was constructed.

This is useful for
* constructing term mode proofs from tactic mode proofs, and
* understanding what tactics are doing, and how metavariables are handled.

As an example, in
```
example {P Q R : Prop} (h₁ : Q → P) (h₂ : R) (h₃ : R → Q) : P ∧ R :=
by show_term { tauto }
```
the term mode proof `⟨h₁ (h₃ h₂), eq.mpr rfl h₂⟩` produced by `tauto` will be printed.

As another example, if the goal is `ℕ × ℕ`, `show_term { split, exact 0 }` will
print `refine (0, _)`, and afterwards there will be one remaining goal (of type `ℕ`).
This indicates that `split, exact 0` partially filled in the original metavariable,
but created a new metavariable for the resulting sub-goal.
-/
unsafe def show_term (t : itactic) : itactic := do
  let g :: _ ← get_goals
  t
  let g ← tactic_statement g
  trace g
#align tactic.interactive.show_term tactic.interactive.show_term

add_tactic_doc
  { Name := "show_term"
    category := DocCategory.tactic
    declNames := [`` show_term]
    tags := ["debugging"] }

end Tactic.Interactive


/-!
# Functor

A `Functor` is any type that can act as a generic container that allows you to transform the
underlying values inside the container using a function, so that the values are all updated, but the
structure of the container is the same. This is called "mapping".

A List is one of the most basic examples of a `Functor`.

A list contains zero or more elements of the same, underlying type.  When you `map` a function over
a list, you create a new list with the same number of elements, where each has been transformed by
the function:
-/
#eval List.map (λ x => toString x) [1,2,3] -- ["1", "2", "3"]

-- you can also write this using dot notation on the List object
#eval [1,2,3].map (λ x => toString x)  -- ["1", "2", "3"]

/-!
Here we converted a list of natural numbers (Nat) to a list of strings where the lambda function
here used `toString` to do the transformation of each element. Notice that when you apply `map` the
"structure" of the object remains the same, in this case the result is always a `List` of the same
size.

Note that in Lean a lambda function can be written using `fun` keyword or the unicode
symbol `λ` which you can type in VS code using `\la `.

List has a specialized version of `map` defined as follows:
-/
def map (f : α → β) : List α → List β
  | []    => []
  | a::as => f a :: map f as

/-!
This is a very generic `map` function that can take any function that converts `(α → β)` and use it
to convert `List α → List β`. Notice the function call `f a` above, this application of `f` is
producing the converted items for the new list.

Let's look at some more examples:

-/
-- List String → List Nat
#eval ["elephant", "tiger", "giraffe"].map (fun s => s.length)
-- [8, 5, 7]

-- List Nat → List Float
#eval [1,2,3,4,5].map (fun s => (s.toFloat) ^ 3.0)
-- [1.000000, 8.000000, 27.000000, 64.000000, 125.000000]

--- List String → List String
#eval ["chris", "david", "mark"].map (fun s => s.capitalize)
-- ["Chris", "David", "Mark"]
/-!

Another example of a functor is the `Option` type. Option contains a value or nothing and is handy
for code that has to deal with optional values, like optional command line arguments.

Remember you can construct an Option using the type constructors `some` or `none`:

-/
#check some 5 -- Option Nat
#eval some 5  -- some 5
#eval (some 5).map (fun x => x + 1) -- some 6
#eval (some 5).map (fun x => toString x) -- some "5"
/-!

Lean also provides a convenient short hand syntax for `(fun x => x + 1)`, namely `(· + 1)`
using the middle dot unicode character which you can type in VS code using `\. `.

-/
#eval (some 4).map (· * 5)  -- some 20
/-!

The `map` function preserves the `none` state of the Option, so again
map preserves the structure of the object.

-/
def x : Option Nat := none
#eval x.map (fun x => toString x) -- none
#check x.map (fun x => toString x) -- Option String
/-!

Notice that even in the `none` case it has transformed `Option Nat` into `Option String` as
you see in the `#check` command.

## How to make a Functor Instance?

The `List` type is made an official `Functor` by the following type class instance:

-/
instance : Functor List where
  map := List.map
/-!

Notice all you need to do is provide the `map` function implementation.  For a quick
example, let's supposed you create a new type describing the measurements of a home
or apartment:

-/
structure LivingSpace (α : Type) where
  totalSize : α
  numBedrooms : Nat
  masterBedroomSize : α
  livingRoomSize : α
  kitchenSize : α
  deriving Repr, BEq
/-!

Now you can construct a `LivingSpace` in square feet using floating point values:
-/
abbrev SquareFeet := Float

def mySpace : LivingSpace SquareFeet :=
  { totalSize := 1800, numBedrooms := 4, masterBedroomSize := 500,
    livingRoomSize := 900, kitchenSize := 400 }
/-!

Now, suppose you want anyone to be able to map a `LivingSpace` from one type of measurement unit to
another.  Then you would provide a `Functor` instance as follows:

-/
def LivingSpace.map (f : α → β) (s : LivingSpace α) : LivingSpace β :=
  { totalSize := f s.totalSize
    numBedrooms := s.numBedrooms
    masterBedroomSize := f s.masterBedroomSize
    livingRoomSize := f s.livingRoomSize
    kitchenSize := f s.kitchenSize }

instance : Functor LivingSpace where
  map := LivingSpace.map
/-!

Notice this functor instance takes `LivingSpace` and not the fully qualified type `LivingSpace SquareFeet`.
Notice below that `LivingSpace` is a function from Type to Type.  For example, if you give it type `SquareFeet`
it gives you back the fully qualified type `LivingSpace SquareFeet`.

-/
#check LivingSpace -- Type → Type
/-!

So the `instance : Functor` then is operating on the more abstract, or generic `LivingSpace` saying
for the whole family of types `LivingSpace α` you can map to `LivingSpace β` using the generic
`LivingSpace.map` map function by simply providing a function that does the more primitive mapping
from `(f : α → β)`.  So `LivingSpace.map` is a sort of function applicator.
This is called a "higher order function" because it takes a function as input
`(α → β)` and returns another function as output `F α → F β`.

Notice that `LivingSpace.map` applies a function `f` to convert the units of all the LivingSpace
fields, except for `numBedrooms` which is a count (and therefore is not a measurement that needs
converting).

So now you can define a simple conversion function, let's say you want square meters instead:

-/
abbrev SquareMeters := Float
def squareFeetToMeters (ft : SquareFeet ) : SquareMeters := (ft / 10.7639104)
/-!

and now bringing it all together you can use the simple function `squareFeetToMeters` to map
`mySpace` to square meters:

-/
#eval mySpace.map squareFeetToMeters
/-
{ totalSize := 167.225472,
  numBedrooms := 4,
  masterBedroomSize := 46.451520,
  livingRoomSize := 83.612736,
  kitchenSize := 37.161216 }
  -/
/-!

Lean also defines custom infix operator `<$>` for `Functor.map` which allows you to write this:
-/
#eval (fun s => s.length) <$> ["elephant", "tiger", "giraffe"] -- [8, 5, 7]
#eval (fun x => x + 1) <$> (some 5) -- some 6
/-!

Note that the infix operator is left associative which means it binds more tightly to the
function on the left than to the expression on the right, this means you can often drop the
parentheses on the right like this:

-/
#eval (fun x => x + 1) <$> some 5 -- some 6
/-!

Note that Lean lets you define your own syntax, so `<$>` is nothing special.
You can define your own infix operator like this:

-/
infixr:100 " doodle " => Functor.map

#eval (· * 5) doodle [1, 2, 3]  -- [5, 10, 15]

/-!
Wow, this is pretty powerful.  By providing a functor instance on `LivingSpace` with an
implementation of the `map` function it is now super easy for anyone to come along and
transform the units of a `LivingSpace` using very simple functions like `squareFeetToMeters`. Notice
that squareFeetToMeters knows nothing about `LivingSpace`.

## How do Functors help with Monads ?

Functors are an abstract mathematical structure that is represented in Lean with a type class. The
Lean functor defines both `map` and a special case for working on constants more efficiently called
`mapConst`:

```lean
class Functor (f : Type u → Type v) : Type (max (u+1) v) where
  map : {α β : Type u} → (α → β) → f α → f β
  mapConst : {α β : Type u} → α → f β → f α
```

Note that `mapConst` has a default implementation, namely:
`mapConst : {α β : Type u} → α → f β → f α := Function.comp map (Function.const _)` in the `Functor`
type class.  So you can use this default implementation and you only need to replace it if
your functor has a more specialized variant than this (usually the custom version is more performant).

In general then, a functor is a function on types `F : Type u → Type v` equipped with an operator
called `map` such that if you have a function `f` of type `α → β` then `map f` will convert your
container type from `F α → F β`. This corresponds to the category-theory notion of
[functor](https://en.wikipedia.org/wiki/Functor) in the special case where the category is the
category of types and functions between them.

Understanding abstract mathematical structures is a little tricky for most people. So it helps to
start with a simpler idea like functors before you try to understand monads.  Building on
functors is the next abstraction called [Applicatives](applicatives.lean.md).
-/


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.coherence

/-!
# Monoidal opposites

We write `Cᵐᵒᵖ` for the monoidal opposite of a monoidal category `C`.
-/

universes v₁ v₂ u₁ u₂

variables {C : Type u₁}

namespace category_theory

open category_theory.monoidal_category

/-- A type synonym for the monoidal opposite. Use the notation `Cᴹᵒᵖ`. -/
@[nolint has_inhabited_instance]
def monoidal_opposite (C : Type u₁) := C

namespace monoidal_opposite

notation C `ᴹᵒᵖ`:std.prec.max_plus := monoidal_opposite C

/-- Think of an object of `C` as an object of `Cᴹᵒᵖ`. -/
@[pp_nodot]
def mop (X : C) : Cᴹᵒᵖ := X

/-- Think of an object of `Cᴹᵒᵖ` as an object of `C`. -/
@[pp_nodot]
def unmop (X : Cᴹᵒᵖ) : C := X

lemma op_injective : function.injective (mop : C → Cᴹᵒᵖ) := λ _ _, id
lemma unop_injective : function.injective (unmop : Cᴹᵒᵖ → C) := λ _ _, id

@[simp] lemma op_inj_iff (x y : C) : mop x = mop y ↔ x = y := iff.rfl
@[simp] lemma unop_inj_iff (x y : Cᴹᵒᵖ) : unmop x = unmop y ↔ x = y := iff.rfl

attribute [irreducible] monoidal_opposite

@[simp] lemma mop_unmop (X : Cᴹᵒᵖ) : mop (unmop X) = X := rfl
@[simp] lemma unmop_mop (X : C) : unmop (mop X) = X := rfl

instance monoidal_opposite_category [I : category.{v₁} C] : category Cᴹᵒᵖ :=
{ hom := λ X Y, unmop X ⟶ unmop Y,
  id := λ X, 𝟙 (unmop X),
  comp := λ X Y Z f g, f ≫ g, }

end monoidal_opposite

end category_theory

open category_theory
open category_theory.monoidal_opposite

variables [category.{v₁} C]

/-- The monoidal opposite of a morphism `f : X ⟶ Y` is just `f`, thought of as `mop X ⟶ mop Y`. -/
def quiver.hom.mop {X Y : C} (f : X ⟶ Y) : @quiver.hom Cᴹᵒᵖ _ (mop X) (mop Y) := f
/-- We can think of a morphism `f : mop X ⟶ mop Y` as a morphism `X ⟶ Y`. -/
def quiver.hom.unmop {X Y : Cᴹᵒᵖ} (f : X ⟶ Y) : unmop X ⟶ unmop Y := f

namespace category_theory

lemma mop_inj {X Y : C} :
  function.injective (quiver.hom.mop : (X ⟶ Y) → (mop X ⟶ mop Y)) :=
λ _ _ H, congr_arg quiver.hom.unmop H

lemma unmop_inj {X Y : Cᴹᵒᵖ} :
  function.injective (quiver.hom.unmop : (X ⟶ Y) → (unmop X ⟶ unmop Y)) :=
λ _ _ H, congr_arg quiver.hom.mop H

@[simp] lemma unmop_mop {X Y : C} {f : X ⟶ Y} : f.mop.unmop = f := rfl
@[simp] lemma mop_unmop {X Y : Cᴹᵒᵖ} {f : X ⟶ Y} : f.unmop.mop = f := rfl

@[simp] lemma mop_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).mop = f.mop ≫ g.mop := rfl
@[simp] lemma mop_id {X : C} : (𝟙 X).mop = 𝟙 (mop X) := rfl

@[simp] lemma unmop_comp {X Y Z : Cᴹᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unmop = f.unmop ≫ g.unmop := rfl
@[simp] lemma unmop_id {X : Cᴹᵒᵖ} : (𝟙 X).unmop = 𝟙 (unmop X) := rfl

@[simp] lemma unmop_id_mop {X : C} : (𝟙 (mop X)).unmop = 𝟙 X := rfl
@[simp] lemma mop_id_unmop {X : Cᴹᵒᵖ} : (𝟙 (unmop X)).mop = 𝟙 X := rfl

namespace iso

variables {X Y : C}

/-- An isomorphism in `C` gives an isomorphism in `Cᴹᵒᵖ`. -/
@[simps]
def mop (f : X ≅ Y) : mop X ≅ mop Y :=
{ hom := f.hom.mop,
  inv := f.inv.mop,
  hom_inv_id' := unmop_inj f.hom_inv_id,
  inv_hom_id' := unmop_inj f.inv_hom_id }

end iso

variables [monoidal_category.{v₁} C]

open opposite monoidal_category

instance monoidal_category_op : monoidal_category Cᵒᵖ :=
{ tensor_obj := λ X Y, op (unop X ⊗ unop Y),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (f.unop ⊗ g.unop).op,
  tensor_unit := op (𝟙_ C),
  associator := λ X Y Z, (α_ (unop X) (unop Y) (unop Z)).symm.op,
  left_unitor := λ X, (λ_ (unop X)).symm.op,
  right_unitor := λ X, (ρ_ (unop X)).symm.op,
  associator_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  left_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  right_unitor_naturality' := by { intros, apply quiver.hom.unop_inj, simp, },
  triangle' := by { intros, apply quiver.hom.unop_inj, coherence, },
  pentagon' := by { intros, apply quiver.hom.unop_inj, coherence, }, }

lemma op_tensor_obj (X Y : Cᵒᵖ) : X ⊗ Y = op (unop X ⊗ unop Y) := rfl
lemma op_tensor_unit : (𝟙_ Cᵒᵖ) = op (𝟙_ C) := rfl

instance monoidal_category_mop : monoidal_category Cᴹᵒᵖ :=
{ tensor_obj := λ X Y, mop (unmop Y ⊗ unmop X),
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, (g.unmop ⊗ f.unmop).mop,
  tensor_unit := mop (𝟙_ C),
  associator := λ X Y Z, (α_ (unmop Z) (unmop Y) (unmop X)).symm.mop,
  left_unitor := λ X, (ρ_ (unmop X)).mop,
  right_unitor := λ X, (λ_ (unmop X)).mop,
  associator_naturality' := by { intros, apply unmop_inj, simp, },
  left_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  right_unitor_naturality' := by { intros, apply unmop_inj, simp, },
  triangle' := by { intros, apply unmop_inj, coherence, },
  pentagon' := by { intros, apply unmop_inj, coherence, }, }

lemma mop_tensor_obj (X Y : Cᴹᵒᵖ) : X ⊗ Y = mop (unmop Y ⊗ unmop X) := rfl
lemma mop_tensor_unit : (𝟙_ Cᴹᵒᵖ) = mop (𝟙_ C) := rfl

end category_theory


import tidy.lib.pretty_print
import tidy.lib.name
import tidy.lib.expr
import tidy.lib.parser

open lean.parser
open interactive

open exceptional
open declaration

namespace tidy.command

namespace rfl_lemma

structure config :=
(attrs : list string := ["simp"])
(priv  : bool := ff)
(trace : bool := ff)

open tactic

meta def handle_defn (lemma_name : string) (conf : config) (e : environment) (fn_name : name) (fn_us : list name) (fn_type : expr) (fn_val : expr) (field : name) : tactic string := do
  (obj_name, obj_name_levels, fn_type_app_vars) ← app.chop $ prod.snd fn_type.unroll_pi_binders,
  (fn_val_params, fn_val_core) ← pure fn_val.unroll_lam_binders,

  let proj_name := obj_name ++ field,
  let proj_prime_name := obj_name ++ field.append_suffix "'",

  pi ← e.is_projection proj_prime_name
    <|> e.is_projection proj_name
    <|> fail format!"There are no projections: {proj_prime_name}', nor {proj_prime_name}",
  (field_params, field_val) ← expr.unroll_lam_binders <$> structure_instance.extract_field fn_val_core pi,

  field_proj ← mk_const proj_name >>= infer_type
    <|> fail format!"There is no identifier: {proj_name}",
  let field_proj_params := (prod.fst field_proj.unroll_pi_binders).drop (pi.nparams + 1),
  let field_params := field_params.zip_with binder.set_binder_info (field_proj_params.map binder.binder_info),

  let lemma_params := fn_val_params ++ field_params,
  args ← binder.list_to_args lemma_params,
  st_value ← pretty_print (binder.instantiate field_val lemma_params) ff tt,

  attrs ← if ¬(conf.attrs.length = 0) then
            pp format!"@[{string.lconcat (conf.attrs.intersperse \", \")}] "
          else
            return "",
  let mods := if conf.priv then "private " else "",

  code ← pp format!"{attrs}{mods}lemma {lemma_name} {args} : ({fn_name} {binder.list_to_invocation fn_val_params}).{field} {binder.list_to_invocation field_params} = {st_value} := rfl",

  if conf.trace then
    tactic.trace code
  else skip,
  return code.to_string

meta def assert_not_declared (n : string) : tactic unit := do
  ret ← try_core $ resolve_constant $ mk_simple_name n,
  match ret with
  | some _ := tactic.fail format!"There is already an identifier \"{n}\" in the environment!"
  | none   := return ()
  end

meta def handle (conf : config) (obj_def : name) (field : name) : tactic string := do
  e ← tactic.get_env,
  obj_def ← tactic.resolve_constant obj_def
  <|> interaction_monad.fail format!"Could not resolve the identifier \"{obj_def}\"",
  match e.get obj_def with
  | exception _ f := do
    interaction_monad.fail format!"Could not retrieve the declaration associated with \"{obj_def}\" from the environment!"
  | success decl :=
    match decl with
    | defn n us type val _ _ := do
      n ← n.get_suffix,
      lemma_name ← to_string <$> pp format!"{n}_{field}",
      assert_not_declared lemma_name,
      handle_defn lemma_name conf e n us type val field
    | _ := interaction_monad.fail format!"\"{obj_def}\" must be a definition, not a lemma, theorem, or axiom!"
    end
  end

end rfl_lemma

meta def rfl_lemma_core (conf : rfl_lemma.config) : lean.parser unit := do
  obj_def ← ident,
  field ← ident,
  lean.parser.of_tactic_safe (rfl_lemma.handle conf obj_def field) >>= emit_code_here

@[user_command]
meta def rfl_lemma_cmd (d : decl_meta_info) (_ : parse $ tk "rfl_lemma") : lean.parser unit :=
  rfl_lemma_core {}

@[user_command]
meta def rfl_lemma_private_cmd (d : decl_meta_info) (_ : parse $ tk "private rfl_lemma") : lean.parser unit :=
  rfl_lemma_core {priv := tt}

@[user_command]
meta def rfl_lemma_question_cmd (d : decl_meta_info) (_ : parse $ tk "rfl_lemma?") : lean.parser unit :=
  rfl_lemma_core {trace := tt}

@[user_command]
meta def rfl_lemma_question_private_cmd (d : decl_meta_info) (_ : parse $ tk "private rfl_lemma?") : lean.parser unit :=
  rfl_lemma_core {trace := tt, priv := tt}

end tidy.command


lemma subsingleton_injective {α β : Sort*} [subsingleton α] (f : α → β) :
  function.injective f :=
by { intros _ _, cc }


theorem P_implies_P (P : Prop) : P → P :=
begin
  sorry,
end


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.oracle_append

/-!
# Coercions Between Simulation Oracles With Target Spec Coercions

This file provides a number of `has_coe` instances for `sim_oracle`, when the
target `oracle_spec` already defines computations with coercions,
using the coercion to respond to oracle queries in the new set of oracles.
-/

namespace oracle_comp

open oracle_spec

variables (spec spec' spec'' spec''' : oracle_spec)
  (coe_spec coe_spec' coe_spec'' coe_spec''' : oracle_spec)
  (S S' : Type) {α : Type}

section coe_sim_oracle

/-- Use a coercion on the resulting type of a simulation to coerce the simulation oracle itself.
  This allows for greater flexibility when specifying the simulation oracle when
    both the initial and final `oracle_spec` are some appended set of oracles -/
instance [coe_spec ⊂ₒ coe_spec'] :
  has_coe (sim_oracle spec coe_spec S) (sim_oracle spec coe_spec' S) :=
{ coe := λ so, {default_state := so.default_state, o := λ i x, ↑(so i x)} }

/-- Coerce a simulation oracle to include an additional number of resulting oracles -/
example (so : sim_oracle coe_spec coe_spec' S) :
  sim_oracle coe_spec (coe_spec' ++ spec ++ spec') S := ↑so

/-- Can use coercions to seperately simulate both sides of appended oracle specs -/
example (so : sim_oracle spec spec'' S) (so' : sim_oracle spec' spec''' S') :
  sim_oracle (spec ++ spec') (spec'' ++ spec''') (S × S') :=
↑so ++ₛ ↑so'

end coe_sim_oracle

end oracle_comp


-- Copyright (c) Microsoft Corporation. All rights reserved.
-- Licensed under the MIT license.

import .spec
import .lemmas
import ..irsem

namespace spec

open irsem
/-
 - Lemmas about regfile.
 -/

-- Induction principle of regfile.
lemma regfile.induction: ∀ {sem} {P: regfile sem → Prop}
    {HP0: P (@regfile.empty sem)}
    {HPU: ∀ rf, P rf → ∀ n v, P (regfile.update sem rf n v)},
  ∀ rf, P rf
:= begin
  intros,
  induction rf,
  { apply HP0 },
  {
    cases rf_hd,
    unfold regfile.update at HPU,
    apply HPU, assumption
  }
end

-- regfile.get returns none on regfile.empty
lemma regfile.empty_get_none: ∀ {sem} rname,
  regfile.get sem (regfile.empty sem) rname = none
:= begin
  intros,
  unfold regfile.empty,
  unfold regfile.get,
  simp,
  unfold regfile.get._match_1
end

lemma regfile.empty_apply_empty: ∀ {sem} f,
  regfile.apply_to_values sem (regfile.empty sem) f = regfile.empty sem
:= begin
  intros,
  unfold regfile.empty,
  refl
end

-- regfile.get returns the value which is updated just before
-- if rname = rname2
lemma regfile.update_get_match: ∀ {sem} (rname rname2:string) vp rf
    (Hnameeq: rname2 = rname),
  regfile.get sem (regfile.update sem rf rname vp) rname2 = some vp
:= begin
  intros,
  unfold regfile.get,
  unfold regfile.update,
  rw list.filter_cons_of_pos,
  { unfold regfile.get._match_1 },
  { simp, assumption }
end

-- Updating a register file does not affect the result
-- of regfile.get if rname ≠ rname2
lemma regfile.update_get_nomatch: ∀ {sem} (rname rname2:string) vp rf
    (Hnameeq: rname2 ≠ rname),
  regfile.get sem (regfile.update sem rf rname vp) rname2 =
  regfile.get sem rf rname2
:= begin
  intros,
  unfold regfile.get,
  unfold regfile.update,
  rw list.filter_cons_of_neg,
  { simp, assumption },
end

lemma regfile.regnames_empty: ∀ {sem} n,
  n ∉ regfile.regnames sem (regfile.empty sem)
:= begin
  intros,
  unfold regfile.regnames,
  unfold regfile.empty,
  simp
end

lemma regfile.reg_in_regnames_update: ∀ {sem} rf n n' v
    (H: n ∈ regfile.regnames sem rf),
  n ∈ regfile.regnames sem (regfile.update sem rf n' v)
:= begin
  intros,
  unfold regfile.update,
  unfold regfile.regnames at *,
  simp,
  right, apply H
end

lemma regfile.reg_in_regnames_update2: ∀ {sem} rf n v,
  n ∈ regfile.regnames sem (regfile.update sem rf n v)
:= begin
  intros,
  unfold regfile.update,
  unfold regfile.regnames at *,
  simp
end

lemma regfile.reg_in_regnames_update3: ∀ {sem} rf n n' v
    (H: n ∈ regfile.regnames sem (regfile.update sem rf n' v))
    (HNEQ: n ≠ n'),
  n ∈ regfile.regnames sem rf
:= begin
  intros,
  unfold regfile.update at H,
  unfold regfile.regnames at *,
  simp at *,
  cases H,
  { exfalso, apply HNEQ, assumption },
  assumption
end

lemma regfile.reg_notin_regnames_get_none: ∀ {sem} (rname:string) (f:regfile sem),
  regfile.get sem f rname = none ↔ rname ∉ regfile.regnames sem f
:= begin
  intros,
  split,
  {
    intros H,
    induction f,
    { unfold regfile.regnames, simp },
    {
      unfold regfile.get at H,
      unfold regfile.regnames,
      cases f_hd with n1 v1, unfold list.filter at H,
      simp,
      have H0: decidable (n1 = rname), apply_instance,
      cases H0,
      {
        rw if_neg at H,
        { intros H1,
          cases H1,
          { rw H1 at H0, apply H0, refl },
          { apply f_ih, apply H, apply H1 }
        },
        {
          simp, apply neq_symm, apply H0
        }
      },
      {
        rw if_pos at H,
        unfold regfile.get._match_1 at H, cases H,
        simp, rw H0
      }
    }
  },
  {
    intros H,
    induction f,
    {
      unfold regfile.get,
      simp, unfold regfile.get._match_1
    },
    {
      unfold regfile.regnames at H,
      simp at H,
      rw ← list.mem_cons_iff at H,
      rw list.notmem_and at H,
      unfold regfile.get,
      have H: decidable (f_hd.fst = rname), apply_instance,
      cases H,
      { -- first element is not rname
        unfold list.filter,
        rw if_neg, apply f_ih,
        cases H, apply H_right,
        intros H', rw H' at H_1, apply H_1, refl
      },
      {
        cases H, rw H_1 at H_left, exfalso, apply H_left, refl
      }
    }
  }
end

lemma regfile.reg_in_regnames_get_some: ∀ {sem} (rname:string) (f:regfile sem),
  (∃ v, regfile.get sem f rname = some v) ↔ rname ∈ regfile.regnames sem f
:= begin
  intros,
  split,
  {
    apply regfile.induction f,
    {
      intros H, cases H,
      rw regfile.empty_get_none at H_h,
      cases H_h
    },
    {
      intros s Hind n v H,
      have HN:decidable (n = rname), apply_instance,
      cases HN,
      {
        rw regfile.update_get_nomatch at H,
        have H := Hind H,
        apply regfile.reg_in_regnames_update, assumption,
        apply neq_symm, assumption
      },
      {
        rw HN,
        apply regfile.reg_in_regnames_update2
      }
    }
  },
  {
    apply regfile.induction f,
    { intros H, cases H },
    {
      intros rf Hind n v H,
      have HN:decidable (n = rname), apply_instance,
      cases HN,
      {
        rw regfile.update_get_nomatch,
        apply Hind,
        apply regfile.reg_in_regnames_update3,
        { apply H },
        any_goals { apply neq_symm, assumption },
      },
      {
        rw HN,
        apply exists.intro v,
        apply regfile.update_get_match, refl
      }
    }
  }
end

lemma regfile.apply_update_comm: ∀ {sem} f n v rf,
  regfile.apply_to_values sem (regfile.update sem rf n v) f =
    regfile.update sem (regfile.apply_to_values sem rf f) n (f v)
:= begin
  intros, unfold regfile.apply_to_values, unfold regfile.update, refl
end

-- Note: reverse direction does not hold!
lemma regfile.reg_apply_some: ∀ {sem} (rf:regfile sem) (f:valty sem → valty sem) v n
    (H:regfile.get sem rf n = some v),
  regfile.get sem (regfile.apply_to_values sem rf f) n = some (f v)
:= begin
  intros,
  revert H,
  apply regfile.induction rf,
  { intros H, rw regfile.empty_get_none at H, cases H },
  {
    intros rf Hind n1 v1 H,
    have HNAME: decidable(n1 = n), apply_instance,
    cases HNAME,
    {
      rw regfile.update_get_nomatch at H,
      have H' := Hind H,
      rw regfile.apply_update_comm,
      rw regfile.update_get_nomatch, assumption,
      any_goals { apply neq_symm, assumption }
    },
    {
      rw regfile.update_get_match at H,
      injection H, subst h_1,
      rw regfile.apply_update_comm,
      rw regfile.update_get_match,
      any_goals { rw HNAME }
    }
  }
end

lemma regfile.reg_apply_none: ∀ {sem} (rf:regfile sem) (f:valty sem → valty sem) n,
  regfile.get sem rf n = none ↔ regfile.get sem (regfile.apply_to_values sem rf f) n = none
:= begin
  intros,
  split,
  {
    apply regfile.induction rf,
    {
      intros H, rw regfile.empty_apply_empty, assumption
    },
    {
      intros rf Hind n1 v1 H,
      have HNAME: decidable(n1 = n), apply_instance,
      cases HNAME,
      {
        rw regfile.update_get_nomatch at H,
        have H' := Hind H,
        rw regfile.apply_update_comm,
        rw regfile.update_get_nomatch, assumption,
        any_goals { apply neq_symm, assumption }
      },
      {
        rw regfile.update_get_match at H,
        injection H, rw HNAME
      }
    }
  },
  {
    apply regfile.induction rf,
    {
      intros H, rw regfile.empty_apply_empty at H, assumption
    },
    {
      intros rf Hind n1 v1 H,
      have HNAME: decidable(n1 = n), apply_instance,
      cases HNAME,
      {
        rw regfile.apply_update_comm at H,
        rw regfile.update_get_nomatch at H,
        have H' := Hind H,
        rw regfile.update_get_nomatch, assumption,
        any_goals { apply neq_symm, assumption }
      },
      {
        rw regfile.apply_update_comm at H,
        rw regfile.update_get_match at H,
        injection H, rw HNAME
      }
    }
  }
end

lemma irstate.updatereg_getreg_match_smt: ∀ (rname rname2:string) v st
    (Hnameeq: rname2 = rname),
  irstate.getreg irsem_smt (irstate.updatereg irsem_smt st rname v) rname2 = some v
:= begin
  intros,
  unfold irstate.getreg,
  unfold irstate.updatereg,
  simp,
  apply regfile.update_get_match, assumption
end

lemma irstate.notin_regnames_getreg_smt: ∀ (rname:string) (s:irstate irsem_smt)
    (H:rname ∉ irstate.regnames irsem_smt s),
  irstate.getreg irsem_smt s rname = none
:= begin
  intros,
  unfold irstate.getreg,
  unfold irstate.regnames at *,
  cases s,
  simp,
  rw regfile.reg_notin_regnames_get_none,
  apply H
end

lemma irstate.getreg_diff_smt: ∀ ss (n1 n2:string) v
    (H1:  irstate.getreg irsem_smt ss n1 = none)
    (H2:  irstate.getreg irsem_smt ss n2 = some v),
  n1 ≠ n2
:= begin
  intros,
  intros HEQ,
  rw HEQ at H1,
  rw H1 at H2,
  cases H2
end

lemma irstate.updatereg_getreg_nomatch_smt: ∀ ss ss' (n1 n2:string) v v'
    (H1: irstate.getreg irsem_smt ss n1 = v)
    (H2: ss' = irstate.updatereg irsem_smt ss n2 v')
    (HDIFF:n1 ≠ n2),
  irstate.getreg irsem_smt ss' n1 = v
:= begin
  intros,
  rw H2,
  unfold irstate.getreg at *,
  unfold irstate.updatereg at *,
  simp,
  rw regfile.update_get_nomatch, assumption, assumption
end

lemma irstate.updatereg_getreg_nomatch_inv_smt: ∀ ss ss' (n1 n2:string) v v'
    (H1: irstate.getreg irsem_smt ss' n1 = v)
    (H2: ss' = irstate.updatereg irsem_smt ss n2 v')
    (HDIFF:n1 ≠ n2),
  irstate.getreg irsem_smt ss n1 = v
:= begin
  intros,
  rw H2 at H1,
  unfold irstate.getreg at *,
  unfold irstate.updatereg at *,
  simp at H1,
  rw regfile.update_get_nomatch at H1, assumption, assumption
end

lemma irstate.getreg_empty_none_smt: ∀ s n
    (H:irstate.regnames irsem_smt s = []),
  irstate.getreg irsem_smt s n = none
:= begin
  intros,
  cases s with ub rf,
  unfold irstate.regnames at H,
  unfold regfile.regnames at H,
  simp at H,
  have H' : rf = [],
  { apply list.map_nil, apply H },
  rw H', unfold irstate.getreg, unfold regfile.get, simp,
  delta regfile.get._match_1, simp
end

lemma irstate.getub_equiv: ∀ {ss:irstate_smt} {se:irstate_exec}
    {sret} {eret} (HSTEQ:irstate_equiv ss se)
    (HSSRET: sret = ss.getub irsem_smt)
    (HSERET: eret = se.getub irsem_exec),
  b_equiv sret eret
:= begin
  intros,
  cases HSTEQ,
  any_goals { -- irstate_equiv.noub
    unfold irstate.getub at HSSRET,
    unfold irstate.getub at HSERET,
    simp at HSSRET, simp at HSERET,
    subst HSSRET, subst HSERET, assumption
  }
end

lemma irstate.getub_updatereg_smt: ∀ (s:irstate irsem_smt) n v,
  irstate.getub irsem_smt (irstate.updatereg irsem_smt s n v) = irstate.getub irsem_smt s
:= begin
  intros,
  unfold irstate.updatereg,
  refl
end

lemma irstate.getreg_apply_some_smt: ∀ (s:irstate irsem_smt) (f:valty_smt → valty_smt) v n
    (H: irstate.getreg irsem_smt s n = some v),
  irstate.getreg irsem_smt (irstate.apply_to_values irsem_smt s f) n = some (f v)
:= begin
  intros,
  cases s,
  unfold irstate.apply_to_values,
  unfold irstate.getreg,
  apply regfile.reg_apply_some,
  apply H
end

lemma irstate.getreg_apply_none_smt: ∀ (s:irstate irsem_smt) (f:valty_smt → valty_smt) n,
  irstate.getreg irsem_smt s n = none ↔
  irstate.getreg irsem_smt (irstate.apply_to_values irsem_smt s f) n = none
:= begin
  intros,
  split,
  {
    intros H, cases s,
    unfold irstate.apply_to_values,
    unfold irstate.getreg,
    rw ← regfile.reg_apply_none,
    apply H
  },
  {
    intros H, cases s,
    unfold irstate.apply_to_values at H,
    unfold irstate.getreg,
    rw regfile.reg_apply_none,
    apply H
  }
end

lemma irstate.empty_apply_empty_smt: ∀ f,
  irstate.apply_to_values irsem_smt (irstate.empty irsem_smt) f = irstate.empty irsem_smt
:= begin
  intros,
  unfold irstate.empty,
  refl
end

lemma irstate.getub_apply_to_values: ∀ (s:irstate irsem_smt) f,
  irstate.getub irsem_smt (irstate.apply_to_values irsem_smt s f) =
    irstate.getub irsem_smt s
:= begin
  intros,
  unfold irstate.getub,
  unfold irstate.apply_to_values
end

lemma irstate.setub_apply_to_values: ∀ (s:irstate irsem_smt) f b,
  irstate.setub irsem_smt (irstate.apply_to_values irsem_smt s f) b =
    irstate.apply_to_values irsem_smt (irstate.setub irsem_smt s b) f
:= begin
  intros,
  unfold irstate.setub,
  unfold irstate.apply_to_values
end

end spec