/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Util.ForEachExprWhere
import Lean.Util.ReplaceLevel
import Lean.Util.ReplaceExpr
import Lean.Util.CollectLevelParams
import Lean.Meta.Constructions
import Lean.Meta.CollectFVars
import Lean.Meta.SizeOf
import Lean.Meta.Injective
import Lean.Meta.IndPredBelow
import Lean.Elab.Command
import Lean.Elab.ComputedFields
import Lean.Elab.DefView
import Lean.Elab.DeclUtil
import Lean.Elab.Deriving.Basic

namespace Lean.Elab.Command
open Meta

builtin_initialize
  registerTraceClass `Elab.inductive

def checkValidInductiveModifier [Monad m] [MonadError m] (modifiers : Modifiers) : m Unit := do
  if modifiers.isNoncomputable then
    throwError "invalid use of 'noncomputable' in inductive declaration"
  if modifiers.isPartial then
    throwError "invalid use of 'partial' in inductive declaration"

def checkValidCtorModifier [Monad m] [MonadError m] (modifiers : Modifiers) : m Unit := do
  if modifiers.isNoncomputable then
    throwError "invalid use of 'noncomputable' in constructor declaration"
  if modifiers.isPartial then
    throwError "invalid use of 'partial' in constructor declaration"
  if modifiers.isUnsafe then
    throwError "invalid use of 'unsafe' in constructor declaration"
  if modifiers.attrs.size != 0 then
    throwError "invalid use of attributes in constructor declaration"

structure CtorView where
  ref       : Syntax
  modifiers : Modifiers
  declName  : Name
  binders   : Syntax
  type?     : Option Syntax
  deriving Inhabited

structure ComputedFieldView where
  ref       : Syntax
  modifiers : Syntax
  fieldId   : Name
  type      : Syntax.Term
  matchAlts : TSyntax ``Parser.Term.matchAlts

structure InductiveView where
  ref             : Syntax
  declId          : Syntax
  modifiers       : Modifiers
  shortDeclName   : Name
  declName        : Name
  levelNames      : List Name
  binders         : Syntax
  type?           : Option Syntax
  ctors           : Array CtorView
  derivingClasses : Array DerivingClassView
  computedFields  : Array ComputedFieldView
  deriving Inhabited

structure ElabHeaderResult where
  view       : InductiveView
  lctx       : LocalContext
  localInsts : LocalInstances
  params     : Array Expr
  type       : Expr
  deriving Inhabited

private partial def elabHeaderAux (views : Array InductiveView) (i : Nat) (acc : Array ElabHeaderResult) : TermElabM (Array ElabHeaderResult) :=
  Term.withAutoBoundImplicitForbiddenPred (fun n => views.any (·.shortDeclName == n)) do
    if h : i < views.size then
      let view := views.get ⟨i, h⟩
      let acc ← Term.withAutoBoundImplicit <| Term.elabBinders view.binders.getArgs fun params => do
        match view.type? with
        | none         =>
          let u ← mkFreshLevelMVar
          let type := mkSort u
          Term.synthesizeSyntheticMVarsNoPostponing
          Term.addAutoBoundImplicits' params type fun params type => do
            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), params, type, view }
        | some typeStx =>
          let (type, _) ← Term.withAutoBoundImplicit do
            let type ← Term.elabType typeStx
            unless (← isTypeFormerType type) do
              throwErrorAt typeStx "invalid inductive type, resultant type is not a sort"
            Term.synthesizeSyntheticMVarsNoPostponing
            let indices ← Term.addAutoBoundImplicits #[]
            return (← mkForallFVars indices type, indices.size)
          Term.addAutoBoundImplicits' params type fun params type => do
            trace[Elab.inductive] "header params: {params}, type: {type}"
            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), params, type, view }
      elabHeaderAux views (i+1) acc
    else
      return acc

private def checkNumParams (rs : Array ElabHeaderResult) : TermElabM Nat := do
  let numParams := rs[0]!.params.size
  for r in rs do
    unless r.params.size == numParams do
      throwErrorAt r.view.ref "invalid inductive type, number of parameters mismatch in mutually inductive datatypes"
  return numParams

private def checkUnsafe (rs : Array ElabHeaderResult) : TermElabM Unit := do
  let isUnsafe := rs[0]!.view.modifiers.isUnsafe
  for r in rs do
    unless r.view.modifiers.isUnsafe == isUnsafe do
      throwErrorAt r.view.ref "invalid inductive type, cannot mix unsafe and safe declarations in a mutually inductive datatypes"

private def checkLevelNames (views : Array InductiveView) : TermElabM Unit := do
  if views.size > 1 then
    let levelNames := views[0]!.levelNames
    for view in views do
      unless view.levelNames == levelNames do
        throwErrorAt view.ref "invalid inductive type, universe parameters mismatch in mutually inductive datatypes"

private def mkTypeFor (r : ElabHeaderResult) : TermElabM Expr := do
  withLCtx r.lctx r.localInsts do
    mkForallFVars r.params r.type

private def throwUnexpectedInductiveType : TermElabM α :=
  throwError "unexpected inductive resulting type"

private def eqvFirstTypeResult (firstType type : Expr) : MetaM Bool :=
  forallTelescopeReducing firstType fun _ firstTypeResult => isDefEq firstTypeResult type

-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
private partial def checkParamsAndResultType (type firstType : Expr) (numParams : Nat) : TermElabM Unit := do
  try
    forallTelescopeCompatible type firstType numParams fun _ type firstType =>
    forallTelescopeReducing type fun _ type =>
    forallTelescopeReducing firstType fun _ firstType => do
      let type ← whnfD type
      match type with
      | .sort .. =>
        unless (← isDefEq firstType type) do
          throwError "resulting universe mismatch, given{indentExpr type}\nexpected type{indentExpr firstType}"
      | _ =>
        throwError "unexpected inductive resulting type"
  catch
    | Exception.error ref msg => throw (Exception.error ref m!"invalid mutually inductive types, {msg}")
    | ex => throw ex

-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
private def checkHeader (r : ElabHeaderResult) (numParams : Nat) (firstType? : Option Expr) : TermElabM Expr := do
  let type ← mkTypeFor r
  match firstType? with
  | none           => return type
  | some firstType =>
    withRef r.view.ref <| checkParamsAndResultType type firstType numParams
    return firstType

-- Auxiliary function for checking whether the types in mutually inductive declaration are compatible.
private partial def checkHeaders (rs : Array ElabHeaderResult) (numParams : Nat) (i : Nat) (firstType? : Option Expr) : TermElabM Unit := do
  if i < rs.size then
    let type ← checkHeader rs[i]! numParams firstType?
    checkHeaders rs numParams (i+1) type

private def elabHeader (views : Array InductiveView) : TermElabM (Array ElabHeaderResult) := do
  let rs ← elabHeaderAux views 0 #[]
  if rs.size > 1 then
    checkUnsafe rs
    let numParams ← checkNumParams rs
    checkHeaders rs numParams 0 none
  return rs

/-- Create a local declaration for each inductive type in `rs`, and execute `x params indFVars`, where `params` are the inductive type parameters and
   `indFVars` are the new local declarations.
   We use the local context/instances and parameters of rs[0].
   Note that this method is executed after we executed `checkHeaders` and established all
   parameters are compatible. -/
private partial def withInductiveLocalDecls (rs : Array ElabHeaderResult) (x : Array Expr → Array Expr → TermElabM α) : TermElabM α := do
  let namesAndTypes ← rs.mapM fun r => do
    let type ← mkTypeFor r
    pure (r.view.declName, r.view.shortDeclName, type)
  let r0     := rs[0]!
  let params := r0.params
  withLCtx r0.lctx r0.localInsts <| withRef r0.view.ref do
    let rec loop (i : Nat) (indFVars : Array Expr) := do
      if h : i < namesAndTypes.size then
        let (declName, shortDeclName, type) := namesAndTypes.get ⟨i, h⟩
        Term.withAuxDecl shortDeclName type declName fun indFVar => loop (i+1) (indFVars.push indFVar)
      else
        x params indFVars
    loop 0 #[]

private def isInductiveFamily (numParams : Nat) (indFVar : Expr) : TermElabM Bool := do
  let indFVarType ← inferType indFVar
  forallTelescopeReducing indFVarType fun xs _ =>
    return xs.size > numParams

private def getArrowBinderNames (type : Expr) : Array Name :=
  go type #[]
where
  go (type : Expr) (acc : Array Name) : Array Name :=
    match type with
    | .forallE n _ b _ => go b (acc.push n)
    | .mdata _ b       => go b acc
    | _ => acc

/--
  Replace binder names in `type` with `newNames`.
  Remark: we only replace the names for binder containing macroscopes.
-/
private def replaceArrowBinderNames (type : Expr) (newNames : Array Name) : Expr :=
  go type 0
where
  go (type : Expr) (i : Nat) : Expr :=
    if i < newNames.size then
      match type with
      | .forallE n d b bi =>
        if n.hasMacroScopes then
          mkForall newNames[i]! bi d (go b (i+1))
        else
          mkForall n bi d (go b (i+1))
      | _ => type
    else
      type

/--
  Reorder contructor arguments to improve the effectiveness of the `fixedIndicesToParams` method.

  The idea is quite simple. Given a constructor type of the form
  ```
  (a₁ : A₁) → ... → (aₙ : Aₙ) → C b₁ ... bₘ
  ```
  We try to find the longest prefix `b₁ ... bᵢ`, `i ≤ m` s.t.
  - each `bₖ` is in `{a₁, ..., aₙ}`
  - each `bₖ` only depends on variables in `{b₁, ..., bₖ₋₁}`

  Then, it moves this prefix `b₁ ... bᵢ` to the front.

  Remark: We only reorder implicit arguments that have macroscopes. See issue #1156.
  The macroscope test is an approximation, we could have restricted ourselves to auto-implicit arguments.
-/
private def reorderCtorArgs (ctorType : Expr) : MetaM Expr := do
  forallTelescopeReducing ctorType fun as type => do
    /- `type` is of the form `C ...` where `C` is the inductive datatype being defined. -/
    let bs := type.getAppArgs
    let mut as  := as
    let mut bsPrefix := #[]
    for b in bs do
      unless b.isFVar && as.contains b do
        break
      let localDecl ← getFVarLocalDecl b
      if localDecl.binderInfo.isExplicit then
        break
      unless localDecl.userName.hasMacroScopes do
        break
      if (← localDeclDependsOnPred localDecl fun fvarId => as.any fun p => p.fvarId! == fvarId) then
        break
      bsPrefix := bsPrefix.push b
      as := as.erase b
    if bsPrefix.isEmpty then
      return ctorType
    else
      let r ← mkForallFVars (bsPrefix ++ as) type
      /- `r` already contains the resulting type.
         To be able to produce more better error messages, we copy the first `bsPrefix.size` binder names from `C` to `r`.
         This is important when some of contructor parameters were inferred using the auto-bound implicit feature.
         For example, in the following declaration.
         ```
          inductive Member : α → List α → Type u
            | head : Member a (a::as)
            | tail : Member a bs → Member a (b::bs)
         ```
         if we do not copy the binder names
         ```
         #check @Member.head
         ```
         produces `@Member.head : {x : Type u_1} → {a : x} → {as : List x} → Member a (a :: as)`
         which is correct, but a bit confusing. By copying the binder names, we obtain
         `@Member.head : {α : Type u_1} → {a : α} → {as : List α} → Member a (a :: as)`
       -/
      let C := type.getAppFn
      let binderNames := getArrowBinderNames (← instantiateMVars (← inferType C))
      return replaceArrowBinderNames r binderNames[:bsPrefix.size]

/--
  Execute `k` with updated binder information for `xs`. Any `x` that is explicit becomes implicit.
-/
private def withExplicitToImplicit (xs : Array Expr) (k : TermElabM α) : TermElabM α := do
  let mut toImplicit := #[]
  for x in xs do
    if (← getFVarLocalDecl x).binderInfo.isExplicit then
      toImplicit := toImplicit.push (x.fvarId!, BinderInfo.implicit)
  withNewBinderInfos toImplicit k

/--
  Elaborate constructor types.

  Remark: we check whether the resulting type is correct, and the parameter occurrences are consistent, but
  we currently do not check for:
  - Positivity (it is a rare failure, and the kernel already checks for it).
  - Universe constraints (the kernel checks for it).
-/
private def elabCtors (indFVars : Array Expr) (indFVar : Expr) (params : Array Expr) (r : ElabHeaderResult) : TermElabM (List Constructor) := withRef r.view.ref do
  let indFamily ← isInductiveFamily params.size indFVar
  r.view.ctors.toList.mapM fun ctorView =>
    Term.withAutoBoundImplicit <| Term.elabBinders ctorView.binders.getArgs fun ctorParams =>
      withRef ctorView.ref do
        let rec elabCtorType (k : Expr → TermElabM Constructor) : TermElabM Constructor := do
          match ctorView.type? with
          | none          =>
            if indFamily then
              throwError "constructor resulting type must be specified in inductive family declaration"
            k <| mkAppN indFVar params
          | some ctorType =>
            let type ← Term.elabType ctorType
            trace[Elab.inductive] "elabType {ctorView.declName} : {type} "
            Term.synthesizeSyntheticMVars (mayPostpone := true)
            let type ← instantiateMVars type
            let type ← checkParamOccs type
            forallTelescopeReducing type fun _ resultingType => do
              unless resultingType.getAppFn == indFVar do
                throwError "unexpected constructor resulting type{indentExpr resultingType}"
              unless (← isType resultingType) do
                throwError "unexpected constructor resulting type, type expected{indentExpr resultingType}"
            k type
        elabCtorType fun type => do
          Term.synthesizeSyntheticMVarsNoPostponing
          let ctorParams ← Term.addAutoBoundImplicits ctorParams
          let except (mvarId : MVarId) := ctorParams.any fun ctorParam => ctorParam.isMVar && ctorParam.mvarId! == mvarId
          /-
            We convert metavariables in the resulting type info extra parameters. Otherwise, we would not be able to elaborate
            declarations such as
            ```
            inductive Palindrome : List α → Prop where
              | nil      : Palindrome [] -- We would get an error here saying "failed to synthesize implicit argument" at `@List.nil ?m`
              | single   : (a : α) → Palindrome [a]
              | sandwich : (a : α) → Palindrome as → Palindrome ([a] ++ as ++ [a])
            ```
            We used to also collect unassigned metavariables on `ctorParams`, but it produced counterintuitive behavior.
            For example, the following declaration used to be accepted.
            ```
            inductive Foo
            | bar (x)

            #check Foo.bar
            -- @Foo.bar : {x : Sort u_1} → x → Foo
            ```
            which is also inconsistent with the behavior of auto implicits in definitions. For example, the following example was never accepted.
            ```
            def bar (x) := 1
            ```
          -/
          let extraCtorParams ← Term.collectUnassignedMVars (← instantiateMVars type) #[] except
          trace[Elab.inductive] "extraCtorParams: {extraCtorParams}"
          /- We must abstract `extraCtorParams` and `ctorParams` simultaneously to make
             sure we do not create auxiliary metavariables. -/
          let type  ← mkForallFVars (extraCtorParams ++ ctorParams) type
          let type ← reorderCtorArgs type
          let type ← mkForallFVars params type
          trace[Elab.inductive] "{ctorView.declName} : {type}"
          return { name := ctorView.declName, type }
where
  checkParamOccs (ctorType : Expr) : MetaM Expr :=
    let visit (e : Expr) : MetaM TransformStep := do
      let f := e.getAppFn
      if indFVars.contains f then
        let mut args := e.getAppArgs
        unless args.size ≥ params.size do
          throwError "unexpected inductive type occurrence{indentExpr e}"
        for i in [:params.size] do
          let param := params[i]!
          let arg := args[i]!
          unless (← isDefEq param arg) do
            throwError "inductive datatype parameter mismatch{indentExpr arg}\nexpected{indentExpr param}"
          args := args.set! i param
        return TransformStep.done (mkAppN f args)
      else
        return .continue
    transform ctorType (pre := visit)

private def getResultingUniverse : List InductiveType → TermElabM Level
  | []           => throwError "unexpected empty inductive declaration"
  | indType :: _ => forallTelescopeReducing indType.type fun _ r => do
    let r ← whnfD r
    match r with
    | Expr.sort u => return u
    | _           => throwError "unexpected inductive type resulting type{indentExpr r}"

/--
  Return `some ?m` if `u` is of the form `?m + k`.
  Return none if `u` does not contain universe metavariables.
  Throw exception otherwise. -/
def shouldInferResultUniverse (u : Level) : TermElabM (Option LMVarId) := do
  let u ← instantiateLevelMVars u
  if u.hasMVar then
    match u.getLevelOffset with
    | Level.mvar mvarId => return some mvarId
    | _ =>
      throwError "cannot infer resulting universe level of inductive datatype, given level contains metavariables {mkSort u}, provide universe explicitly"
  else
    return none

/--
  Convert universe metavariables into new parameters. It skips `univToInfer?` (the inductive datatype resulting universe) because
  it should be inferred later using `inferResultingUniverse`.
-/
private def levelMVarToParam (indTypes : List InductiveType) (univToInfer? : Option LMVarId) : TermElabM (List InductiveType) :=
  indTypes.mapM fun indType => do
    let type  ← levelMVarToParam' indType.type
    let ctors ← indType.ctors.mapM fun ctor => do
      let ctorType ← levelMVarToParam' ctor.type
      return { ctor with type := ctorType }
    return { indType with ctors, type }
where
  levelMVarToParam' (type : Expr) : TermElabM Expr := do
    Term.levelMVarToParam type (except := fun mvarId => univToInfer? == some mvarId)

def mkResultUniverse (us : Array Level) (rOffset : Nat) : Level :=
  if us.isEmpty && rOffset == 0 then
    levelOne
  else
    let r := Level.mkNaryMax us.toList
    if rOffset == 0 && !r.isZero && !r.isNeverZero then
      mkLevelMax r levelOne |>.normalize
    else
      r.normalize

 /--
   Auxiliary function for `updateResultingUniverse`
   `accLevel u r rOffset` add `u` to state if it is not already there and
   it is different from the resulting universe level `r+rOffset`.

   If `u` is a `max`, then its components are recursively processed.
   If `u` is a `succ` and `rOffset > 0`, we process the `u`s child using `rOffset-1`.

   This method is used to infer the resulting universe level of an inductive datatype.
 -/
def accLevel (u : Level) (r : Level) (rOffset : Nat) : OptionT (StateT (Array Level) Id) Unit := do
  go u rOffset
where
  go (u : Level) (rOffset : Nat) : OptionT (StateT (Array Level) Id) Unit := do
    match u, rOffset with
    | .max u v,  rOffset   => go u rOffset; go v rOffset
    | .imax u v, rOffset   => go u rOffset; go v rOffset
    | .zero,     _         => return ()
    | .succ u,   rOffset+1 => go u rOffset
    | u,         rOffset   =>
      if rOffset == 0 && u == r then
        return ()
      else if r.occurs u  then
        failure
      else if rOffset > 0 then
        failure
      else if (← get).contains u then
        return ()
      else
        modify fun us => us.push u

/--
  Auxiliary function for `updateResultingUniverse`
  `accLevelAtCtor ctor ctorParam r rOffset` add `u` (`ctorParam`'s universe) to state if it is not already there and
  it is different from the resulting universe level `r+rOffset`.

  See `accLevel`.
-/
def accLevelAtCtor (ctor : Constructor) (ctorParam : Expr) (r : Level) (rOffset : Nat) : StateRefT (Array Level) TermElabM Unit := do
  let type ← inferType ctorParam
  let u ← instantiateLevelMVars (← getLevel type)
  match (← modifyGet fun s => accLevel u r rOffset |>.run |>.run s) with
  | some _ => pure ()
  | none =>
    let typeType ← inferType type
    let mut msg := m!"failed to compute resulting universe level of inductive datatype, constructor '{ctor.name}' has type{indentExpr ctor.type}\nparameter"
    let localDecl ← getFVarLocalDecl ctorParam
    unless localDecl.userName.hasMacroScopes do
      msg := msg ++ m!" '{ctorParam}'"
    msg := msg ++ m!" has type{indentD m!"{type} : {typeType}"}\ninductive type resulting type{indentExpr (mkSort (r.addOffset rOffset))}"
    if r.isMVar then
      msg := msg ++ "\nrecall that Lean only infers the resulting universe level automatically when there is a unique solution for the universe level constraints, consider explicitly providing the inductive type resulting universe level"
    throwError msg

/--
  Execute `k` using the `Syntax` reference associated with constructor `ctorName`.
-/
def withCtorRef [Monad m] [MonadRef m] (views : Array InductiveView) (ctorName : Name) (k : m α) : m α := do
  for view in views do
    for ctorView in view.ctors do
      if ctorView.declName == ctorName then
        return (← withRef ctorView.ref k)
  k

/-- Auxiliary function for `updateResultingUniverse` -/
private partial def collectUniverses (views : Array InductiveView) (r : Level) (rOffset : Nat) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (Array Level) := do
  let (_, us) ← go |>.run #[]
  return us
where
  go : StateRefT (Array Level) TermElabM Unit :=
    indTypes.forM fun indType => indType.ctors.forM fun ctor =>
      withCtorRef views ctor.name do
        forallTelescopeReducing ctor.type fun ctorParams _ =>
          for ctorParam in ctorParams[numParams:] do
            accLevelAtCtor ctor ctorParam r rOffset

private def updateResultingUniverse (views : Array InductiveView) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (List InductiveType) := do
  let r ← getResultingUniverse indTypes
  let rOffset : Nat   := r.getOffset
  let r       : Level := r.getLevelOffset
  unless r.isMVar do
    throwError "failed to compute resulting universe level of inductive datatype, provide universe explicitly: {r}"
  let us ← collectUniverses views r rOffset numParams indTypes
  trace[Elab.inductive] "updateResultingUniverse us: {us}, r: {r}, rOffset: {rOffset}"
  let rNew := mkResultUniverse us rOffset
  assignLevelMVar r.mvarId! rNew
  indTypes.mapM fun indType => do
    let type ← instantiateMVars indType.type
    let ctors ← indType.ctors.mapM fun ctor => return { ctor with type := (← instantiateMVars ctor.type) }
    return { indType with type, ctors }

register_builtin_option bootstrap.inductiveCheckResultingUniverse : Bool := {
    defValue := true,
    group    := "bootstrap",
    descr    := "by default the `inductive/structure commands report an error if the resulting universe is not zero, but may be zero for some universe parameters. Reason: unless this type is a subsingleton, it is hardly what the user wants since it can only eliminate into `Prop`. In the `Init` package, we define subsingletons, and we use this option to disable the check. This option may be deleted in the future after we improve the validator"
}

def checkResultingUniverse (u : Level) : TermElabM Unit := do
  if bootstrap.inductiveCheckResultingUniverse.get (← getOptions) then
    let u ← instantiateLevelMVars u
    if !u.isZero && !u.isNeverZero then
      throwError "invalid universe polymorphic type, the resultant universe is not Prop (i.e., 0), but it may be Prop for some parameter values (solution: use 'u+1' or 'max 1 u'{indentD u}"

private def checkResultingUniverses (views : Array InductiveView) (numParams : Nat) (indTypes : List InductiveType) : TermElabM Unit := do
  let u := (← instantiateLevelMVars (← getResultingUniverse indTypes)).normalize
  checkResultingUniverse u
  unless u.isZero do
    indTypes.forM fun indType => indType.ctors.forM fun ctor =>
      forallTelescopeReducing ctor.type fun ctorArgs _ => do
        for ctorArg in ctorArgs[numParams:] do
          let type ← inferType ctorArg
          let v := (← instantiateLevelMVars (← getLevel type)).normalize
          let rec check (v' : Level) (u' : Level) : TermElabM Unit :=
            match v', u' with
            | .succ v', .succ u' => check v' u'
            | .mvar id, .param ..  =>
              /- Special case:
                 The constructor parameter `v` is at unverse level `?v+k` and
                 the resulting inductive universe level is `u'+k`, where `u'` is a parameter (or zero).
                 Thus, `?v := u'` is the only choice for satisfying the universe contraint `?v+k <= u'+k`.
                 Note that, we still generate an error for cases where there is more than one of satisfying the constraint.
                 Examples:
                 -----------------------------------------------------------
                 | ctor universe level | inductive datatype universe level |
                 -----------------------------------------------------------
                 |   ?v                | max u w                           |
                 -----------------------------------------------------------
                 |   ?v                | u + 1                             |
                 -----------------------------------------------------------
              -/
              assignLevelMVar id u'
            | .mvar id, .zero => assignLevelMVar id u' -- TODO: merge with previous case
            | _, _ =>
              unless u.geq v do
                let mut msg := m!"invalid universe level in constructor '{ctor.name}', parameter"
                let localDecl ← getFVarLocalDecl ctorArg
                unless localDecl.userName.hasMacroScopes do
                  msg := msg ++ m!" '{ctorArg}'"
                msg := msg ++ m!" has type{indentExpr type}"
                msg := msg ++ m!"\nat universe level{indentD v}"
                msg := msg ++ m!"\nit must be smaller than or equal to the inductive datatype universe level{indentD u}"
                withCtorRef views ctor.name <| throwError msg
          check v u

private def collectUsed (indTypes : List InductiveType) : StateRefT CollectFVars.State MetaM Unit := do
  indTypes.forM fun indType => do
    indType.type.collectFVars
    indType.ctors.forM fun ctor =>
      ctor.type.collectFVars

private def removeUnused (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (LocalContext × LocalInstances × Array Expr) := do
  let (_, used) ← (collectUsed indTypes).run {}
  Meta.removeUnused vars used

private def withUsed {α} (vars : Array Expr) (indTypes : List InductiveType) (k : Array Expr → TermElabM α) : TermElabM α := do
  let (lctx, localInsts, vars) ← removeUnused vars indTypes
  withLCtx lctx localInsts <| k vars

private def updateParams (vars : Array Expr) (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
  indTypes.mapM fun indType => do
    let type ← mkForallFVars vars indType.type
    let ctors ← indType.ctors.mapM fun ctor => do
      let ctorType ← withExplicitToImplicit vars (mkForallFVars vars ctor.type)
      return { ctor with type := ctorType }
    return { indType with type, ctors }

private def collectLevelParamsInInductive (indTypes : List InductiveType) : Array Name := Id.run do
  let mut usedParams : CollectLevelParams.State := {}
  for indType in indTypes do
    usedParams := collectLevelParams usedParams indType.type
    for ctor in indType.ctors do
      usedParams := collectLevelParams usedParams ctor.type
  return usedParams.params

private def mkIndFVar2Const (views : Array InductiveView) (indFVars : Array Expr) (levelNames : List Name) : ExprMap Expr := Id.run do
  let levelParams := levelNames.map mkLevelParam;
  let mut m : ExprMap Expr := {}
  for i in [:views.size] do
    let view    := views[i]!
    let indFVar := indFVars[i]!
    m := m.insert indFVar (mkConst view.declName levelParams)
  return m

/-- Remark: `numVars <= numParams`. `numVars` is the number of context `variables` used in the inductive declaration,
   and `numParams` is `numVars` + number of explicit parameters provided in the declaration. -/
private def replaceIndFVarsWithConsts (views : Array InductiveView) (indFVars : Array Expr) (levelNames : List Name)
    (numVars : Nat) (numParams : Nat) (indTypes : List InductiveType) : TermElabM (List InductiveType) :=
  let indFVar2Const := mkIndFVar2Const views indFVars levelNames
  indTypes.mapM fun indType => do
    let ctors ← indType.ctors.mapM fun ctor => do
      let type ← forallBoundedTelescope ctor.type numParams fun params type => do
        let type := type.replace fun e =>
          if !e.isFVar then
            none
          else match indFVar2Const.find? e with
            | none   => none
            | some c => mkAppN c (params.extract 0 numVars)
        instantiateMVars (← mkForallFVars params type)
      return { ctor with type }
    return { indType with ctors }

private def mkAuxConstructions (views : Array InductiveView) : TermElabM Unit := do
  let env ← getEnv
  let hasEq   := env.contains ``Eq
  let hasHEq  := env.contains ``HEq
  let hasUnit := env.contains ``PUnit
  let hasProd := env.contains ``Prod
  for view in views do
    let n := view.declName
    mkRecOn n
    if hasUnit then mkCasesOn n
    if hasUnit && hasEq && hasHEq then mkNoConfusion n
    if hasUnit && hasProd then mkBelow n
    if hasUnit && hasProd then mkIBelow n
  for view in views do
    let n := view.declName;
    if hasUnit && hasProd then mkBRecOn n
    if hasUnit && hasProd then mkBInductionOn n

private def getArity (indType : InductiveType) : MetaM Nat :=
  forallTelescopeReducing indType.type fun xs _ => return xs.size

private def resetMaskAt (mask : Array Bool) (i : Nat) : Array Bool :=
  if h : i < mask.size then
    mask.set ⟨i, h⟩ false
  else
    mask

/--
  Compute a bit-mask that for `indType`. The size of the resulting array `result` is the arity of `indType`.
  The first `numParams` elements are `false` since they are parameters.
  For `i ∈ [numParams, arity)`, we have that `result[i]` if this index of the inductive family is fixed.
-/
private def computeFixedIndexBitMask (numParams : Nat) (indType : InductiveType) (indFVars : Array Expr) : MetaM (Array Bool) := do
  let arity ← getArity indType
  if arity ≤ numParams then
    return mkArray arity false
  else
    let maskRef ← IO.mkRef (mkArray numParams false ++ mkArray (arity - numParams) true)
    let rec go (ctors : List Constructor) : MetaM (Array Bool) := do
      match ctors with
      | [] => maskRef.get
      | ctor :: ctors =>
        forallTelescopeReducing ctor.type fun xs type => do
          let typeArgs := type.getAppArgs
          for i in [numParams:arity] do
            unless i < xs.size && xs[i]! == typeArgs[i]! do -- Remark: if we want to allow arguments to be rearranged, this test should be xs.contains typeArgs[i]
              maskRef.modify fun mask => mask.set! i false
          for x in xs[numParams:] do
            let xType ← inferType x
            let cond (e : Expr) := indFVars.any (fun indFVar => e.getAppFn == indFVar) && e.getAppNumArgs > numParams
            xType.forEachWhere cond fun e => do
              let eArgs := e.getAppArgs
              for i in [numParams:eArgs.size] do
                if i >= typeArgs.size then
                  maskRef.modify (resetMaskAt · i)
                else
                  unless eArgs[i]! == typeArgs[i]! do
                    maskRef.modify (resetMaskAt · i)
        go ctors
    go indType.ctors

/-- Return true iff `arrowType` is an arrow and its domain is defeq to `type` -/
private def isDomainDefEq (arrowType : Expr) (type : Expr) : MetaM Bool := do
  if !arrowType.isForall then
    return false
  else
    /-
      We used to use `withNewMCtxDepth` to make sure we do not assign universe metavariables,
      but it was not satisfactory. For example, in declarations such as
      ```
      inductive Eq : α → α → Prop where
      | refl (a : α) : Eq a a
      ```
      We want the first two indices to be promoted to parameters, and this will only
      happen if we can assign universe metavariables.
    -/
    isDefEq arrowType.bindingDomain! type

/--
  Convert fixed indices to parameters.
-/
private partial def fixedIndicesToParams (numParams : Nat) (indTypes : Array InductiveType) (indFVars : Array Expr) : MetaM Nat := do
  let masks ← indTypes.mapM (computeFixedIndexBitMask numParams · indFVars)
  if masks.all fun mask => !mask.contains true then
    return numParams
  trace[Elab.inductive] "masks: {masks}"
  -- We process just a non-fixed prefix of the indices for now. Reason: we don't want to change the order.
  -- TODO: extend it in the future. For example, it should be reasonable to change
  -- the order of indices generated by the auto implicit feature.
  let mask := masks[0]!
  forallBoundedTelescope indTypes[0]!.type numParams fun params type => do
    let otherTypes ← indTypes[1:].toArray.mapM fun indType => do whnfD (← instantiateForall indType.type params)
    let ctorTypes ← indTypes.toList.mapM fun indType => indType.ctors.mapM fun ctor => do whnfD (← instantiateForall ctor.type params)
    let typesToCheck := otherTypes.toList ++ ctorTypes.join
    let rec go (i : Nat) (type : Expr) (typesToCheck : List Expr) : MetaM Nat := do
      if i < mask.size then
        if !masks.all fun mask => i < mask.size && mask[i]! then
           return i
        if !type.isForall then
          return i
        let paramType := type.bindingDomain!
        if !(← typesToCheck.allM fun type => isDomainDefEq type paramType) then
          trace[Elab.inductive] "domain not def eq: {i}, {type} =?= {paramType}"
          return i
        withLocalDeclD `a paramType fun paramNew => do
          let typesToCheck ← typesToCheck.mapM fun type => whnfD (type.bindingBody!.instantiate1 paramNew)
          go (i+1) (type.bindingBody!.instantiate1 paramNew) typesToCheck
      else
        return i
    go numParams type typesToCheck

private def mkInductiveDecl (vars : Array Expr) (views : Array InductiveView) : TermElabM Unit := Term.withoutSavingRecAppSyntax do
  let view0 := views[0]!
  let scopeLevelNames ← Term.getLevelNames
  checkLevelNames views
  let allUserLevelNames := view0.levelNames
  let isUnsafe          := view0.modifiers.isUnsafe
  withRef view0.ref <| Term.withLevelNames allUserLevelNames do
    let rs ← elabHeader views
    withInductiveLocalDecls rs fun params indFVars => do
      trace[Elab.inductive] "indFVars: {indFVars}"
      let mut indTypesArray := #[]
      for i in [:views.size] do
        let indFVar := indFVars[i]!
        Term.addLocalVarInfo views[i]!.declId indFVar
        let r       := rs[i]!
        let type  ← mkForallFVars params r.type
        let ctors ← withExplicitToImplicit params (elabCtors indFVars indFVar params r)
        indTypesArray := indTypesArray.push { name := r.view.declName, type, ctors }
      Term.synthesizeSyntheticMVarsNoPostponing
      let numExplicitParams ← fixedIndicesToParams params.size indTypesArray indFVars
      trace[Elab.inductive] "numExplicitParams: {numExplicitParams}"
      let indTypes := indTypesArray.toList
      let u ← getResultingUniverse indTypes
      let univToInfer? ← shouldInferResultUniverse u
      withUsed vars indTypes fun vars => do
        let numVars   := vars.size
        let numParams := numVars + numExplicitParams
        let indTypes ← updateParams vars indTypes
        let indTypes ← if let some univToInfer := univToInfer? then
          updateResultingUniverse views numParams (← levelMVarToParam indTypes univToInfer)
        else
          checkResultingUniverses views numParams indTypes
          levelMVarToParam indTypes none
        let usedLevelNames := collectLevelParamsInInductive indTypes
        match sortDeclLevelParams scopeLevelNames allUserLevelNames usedLevelNames with
        | .error msg      => throwError msg
        | .ok levelParams => do
          let indTypes ← replaceIndFVarsWithConsts views indFVars levelParams numVars numParams indTypes
          let decl := Declaration.inductDecl levelParams numParams indTypes isUnsafe
          Term.ensureNoUnassignedMVars decl
          addDecl decl
          mkAuxConstructions views
    withSaveInfoContext do  -- save new env
      for view in views do
        Term.addTermInfo' view.ref[1] (← mkConstWithLevelParams view.declName) (isBinder := true)
        for ctor in view.ctors do
          Term.addTermInfo' ctor.ref[3] (← mkConstWithLevelParams ctor.declName) (isBinder := true)
        -- We need to invoke `applyAttributes` because `class` is implemented as an attribute.
        Term.applyAttributesAt view.declName view.modifiers.attrs .afterTypeChecking

private def applyDerivingHandlers (views : Array InductiveView) : CommandElabM Unit := do
  let mut processed : NameSet := {}
  for view in views do
    for classView in view.derivingClasses do
      let className := classView.className
      unless processed.contains className do
        processed := processed.insert className
        let mut declNames := #[]
        for view in views do
          if view.derivingClasses.any fun classView => classView.className == className then
            declNames := declNames.push view.declName
        classView.applyHandlers declNames

private def applyComputedFields (indViews : Array InductiveView) : CommandElabM Unit := do
  if indViews.all (·.computedFields.isEmpty) then return

  let mut computedFields := #[]
  let mut computedFieldDefs := #[]
  for indView@{declName, ..} in indViews do
    for {ref, fieldId, type, matchAlts, modifiers, ..} in indView.computedFields do
      computedFieldDefs := computedFieldDefs.push <| ← do
        let modifiers ← match modifiers with
          | `(Lean.Parser.Command.declModifiersT| $[$doc:docComment]? $[$attrs:attributes]? $[$vis]? $[noncomputable]?) =>
            `(Lean.Parser.Command.declModifiersT| $[$doc]? $[$attrs]? $[$vis]? noncomputable)
          | _ => do
            withRef modifiers do logError "unsupported modifiers for computed field"
            `(Parser.Command.declModifiersT| noncomputable)
        `($(⟨modifiers⟩):declModifiers
          def%$ref $(mkIdent <| `_root_ ++ declName ++ fieldId):ident : $type $matchAlts:matchAlts)
    let computedFieldNames := indView.computedFields.map fun {fieldId, ..} => declName ++ fieldId
    computedFields := computedFields.push (declName, computedFieldNames)
  withScope (fun scope => { scope with
      opts := scope.opts
        |>.setBool `bootstrap.genMatcherCode false
        |>.setBool `elaboratingComputedFields true}) <|
    elabCommand <| ← `(mutual $computedFieldDefs* end)

  liftTermElabM do Term.withDeclName indViews[0]!.declName do
    ComputedFields.setComputedFields computedFields

def elabInductiveViews (views : Array InductiveView) : CommandElabM Unit := do
  let view0 := views[0]!
  let ref := view0.ref
  runTermElabM fun vars => Term.withDeclName view0.declName do withRef ref do
    mkInductiveDecl vars views
    mkSizeOfInstances view0.declName
    Lean.Meta.IndPredBelow.mkBelow view0.declName
    for view in views do
      mkInjectiveTheorems view.declName
  applyComputedFields views -- NOTE: any generated code before this line is invalid
  applyDerivingHandlers views
  runTermElabM fun _ => Term.withDeclName view0.declName do withRef ref do
    for view in views do
      Term.applyAttributesAt view.declName view.modifiers.attrs .afterCompilation

end Lean.Elab.Command


example : (p ∨ p) → p := fun h => match


/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import tactic.core
/-!
## `protected` and `protect_proj` user attributes

`protected` is an attribute to protect a declaration.
If a declaration `foo.bar` is marked protected, then it must be referred to
by its full name `foo.bar`, even when the `foo` namespace is open.

`protect_proj` attribute to protect the projections of a structure.
If a structure `foo` is marked with the `protect_proj` user attribute, then
all of the projections become protected.

`protect_proj without bar baz` will protect all projections except for `bar` and `baz`.

# Examples

In this example all of `foo.bar`, `foo.baz` and `foo.qux` will be protected.
```
@[protect_proj] structure foo : Type :=
(bar : unit) (baz : unit) (qux : unit)
```

The following code example define the structure `foo`, and the projections `foo.qux`
will be protected, but not `foo.baz` or `foo.bar`

```
@[protect_proj without baz bar] structure foo : Type :=
(bar : unit) (baz : unit) (qux : unit)
```
-/
namespace tactic

/--
Attribute to protect a declaration.
If a declaration `foo.bar` is marked protected, then it must be referred to
by its full name `foo.bar`, even when the `foo` namespace is open.

Protectedness is a built in parser feature that is independent of this attribute.
A declaration may be protected even if it does not have the `@[protected]` attribute.
This provides a convenient way to protect many declarations at once.
-/
@[user_attribute] meta def protected_attr : user_attribute :=
{ name := "protected",
  descr := "Attribute to protect a declaration
    If a declaration `foo.bar` is marked protected, then it must be referred to
    by its full name `foo.bar`, even when the `foo` namespace is open.",
  after_set := some (λ n _ _, mk_protected n)  }

add_tactic_doc
{ name        := "protected",
  category    := doc_category.attr,
  decl_names  := [`tactic.protected_attr],
  tags        := ["parsing", "environment"] }

/-- Tactic that is executed when a structure is marked with the `protect_proj` attribute -/
meta def protect_proj_tac (n : name) (l : list name) : tactic unit :=
do env ← get_env,
match env.structure_fields_full n with
| none := fail "protect_proj failed: declaration is not a structure"
| some fields := fields.mmap' $ λ field,
    when (l.all $ λ m, bnot $ m.is_suffix_of field) $ mk_protected field
end

/--
Attribute to protect the projections of a structure.
If a structure `foo` is marked with the `protect_proj` user attribute, then
all of the projections become protected, meaning they must always be referred to by
their full name `foo.bar`, even when the `foo` namespace is open.

`protect_proj without bar baz` will protect all projections except for `bar` and `baz`.

```lean
@[protect_proj without baz bar] structure foo : Type :=
(bar : unit) (baz : unit) (qux : unit)
```
-/
@[user_attribute] meta def protect_proj_attr : user_attribute unit (list name) :=
{ name := "protect_proj",
  descr := "Attribute to protect the projections of a structure.
    If a structure `foo` is marked with the `protect_proj` user attribute, then
    all of the projections become protected, meaning they must always be referred to by
    their full name `foo.bar`, even when the `foo` namespace is open.

    `protect_proj without bar baz` will protect all projections except for bar and baz",
  after_set := some (λ n _ _, do l ← protect_proj_attr.get_param n,
    protect_proj_tac n l),
  parser := interactive.types.without_ident_list }

add_tactic_doc
{ name        := "protect_proj",
  category    := doc_category.attr,
  decl_names  := [`tactic.protect_proj_attr],
  tags        := ["parsing", "environment", "structures"] }

end tactic


import data.real.basic
import data.hashable
import data.tactic
import tactic
import tactic.linarith
import system.io

open io io.fs io.process parser

def sum.coe {m α} [monad m] [monad_fail m] : string ⊕ α → m α
| (sum.inl e) := monad_fail.fail $ "\n" ++ e
| (sum.inr e) := pure e

meta instance {α} : has_coe (string ⊕ α) (tactic α) := ⟨ sum.coe ⟩
instance sum.io_coe {α} : has_coe (string ⊕ α) (io α) := ⟨ sum.coe ⟩

meta instance int.reflect : has_reflect ℤ
| x :=
if x < 0 then cast undefined `(- %%(int.reflect x) : ℤ)
else if h₁ : x = 0 then cast (by rw h₁) `(0 : ℤ)
       else if h₂ : x = 1 then cast (by rw h₂) `(1 : ℤ)
       else if h₃ : x % 2 = 0 then cast undefined $ `(λ x : ℤ, bit0 x).subst (int.reflect (x / 2))
       else cast undefined `(bit1 %%(int.reflect (x / 2)) : ℤ)

meta def rat.has_reflect' : Π x : ℚ, Σ y : ℚ, Σ' h : x = y, reflected y
| ⟨x,y,h,h'⟩ := ⟨rat.mk_nat x y, by { rw [rat.num_denom',rat.mk_nat_eq] } , `(_)⟩

meta instance : has_reflect ℚ
| x :=
match rat.has_reflect' x with
| ⟨ ._, rfl, h ⟩ := h
end

namespace smt

inductive atom
| num (s : ℤ)
| dec (s : ℚ)
-- | str (s : string)
| sym (s : string)
-- | keyword (s : string)

protected meta def atom.to_string : atom → string
| (atom.num s) := to_string s
| (atom.dec s) := to_string s
-- | (atom.str s) := s
| (atom.sym s) := s
-- | (atom.keyword s) := s

meta instance atom.has_to_string : has_to_string atom :=
⟨ atom.to_string ⟩

inductive sexpr
| const : atom → sexpr
| fapp : list sexpr → sexpr

protected meta def sexpr.to_string : sexpr → string
| (sexpr.const n) := to_string n
| (sexpr.fapp args) := "( " ++ string.intercalate " " (args.map sexpr.to_string) ++ " )"

meta instance sexpr.has_to_string : has_to_string sexpr :=
⟨ sexpr.to_string ⟩

inductive type
| int | real | array (idx rng : type)

open smt.type

def type.to_string : type → string
| int := "Int"
| real := "Real"
| (array t₀ t₁) := "(Array " ++ t₀.to_string ++ " " ++ t₁.to_string ++ ")"

def string.map (f : char → char) : string → string :=
list.as_string ∘ list.map f ∘ string.to_list

protected def name := string
protected def name.to_string : smt.name → string := id

def repl_prime : char → char
| '\'' := '@'
| c := c

def to_smt_name : name → smt.name :=
string.map repl_prime ∘ name.to_string_with_sep "_"

inductive expr'
| all : smt.name → type → expr' → expr'
| exist : smt.name → type → expr' → expr'
| var : ℕ → expr'
| lit : ℕ → expr'
| const : smt.name → expr'
| app : smt.name → list expr' → expr'

open smt.expr'

mutual inductive bounded, all_bounded
with bounded : expr' → ℕ → Prop
| all {n t e b} :
  bounded e (b+1) →
  bounded (all n t e) b
| exist {n t e b} :
  bounded e (b+1) →
  bounded (exist n t e) b
| var {n b} : n < b → bounded (var n) b
| const {n b} : bounded (const n) b
| lit {n b} : bounded (lit n) b
| app {fn args b} :
  all_bounded args b →
  bounded (expr'.app fn args) b
with all_bounded : list expr' → ℕ → Prop
| nil {b} : all_bounded [] b
| cons {x xs b} :
  bounded x b →
  all_bounded xs b →
  all_bounded (x :: xs) b

def expr := { e // bounded e 0 }

meta def type.to_z3 : _root_.expr → string ⊕ type
| `(ℤ) := sum.inr type.int
| `(ℝ) := sum.inr type.real
| `(%%a → %%b) := type.array <$> type.to_z3 a <*> type.to_z3 b
| e := sum.inl $ (format!"type not supported: {e}").to_string

meta def z3_builtin : rbmap name (ℕ × name) :=
rbmap.from_list
[ (`eq, 1, `=),
  (`has_lt.lt, 2, `<),
  (`has_add.add, 2, `+),
  (`has_mul.mul, 2, `*),
  (`has_sub.sub, 2, `-),
  (`has_neg.neg, 2, `-),
  (`has_pow.pow, 3, `^),
  (`not, 0, `not) ]

meta def mk_lit : _root_.expr → string ⊕ ℕ
| `(bit0 %%e) := (*2) <$> mk_lit e
| `(bit1 %%e) := (λ n, 2*n + 1) <$> mk_lit e
| `(@has_zero.zero _ _) := pure 0
| `(@has_one.one _ _) := pure 1
| e := sum.inl (format!"invalid numeral {e}").to_string

meta def to_z3' : _root_.expr → string ⊕ expr'
| (expr.var n) := sum.inr $ expr'.var n
| (expr.const n t) := sum.inr $ expr'.const (to_smt_name n)
| e@`(bit0 _) := expr'.lit <$> mk_lit e
| e@`(bit1 _) := expr'.lit <$> mk_lit e
| e@`(@has_zero.zero _ _) := expr'.lit <$> mk_lit e
| e@`(@has_one.one _ _) := expr'.lit <$> mk_lit e
| e@(expr.app e₀ e₁) :=
let fn := e₀.get_app_fn,
    args := e.get_app_args in
if fn.is_constant then do
  match z3_builtin.find fn.const_name with
  | (some (i,n)) :=
  expr'.app (to_smt_name n) <$> (args.drop i).traverse to_z3'
  | none := sum.inl (format!"invalid function: {fn.const_name}").to_string
  end
else sum.inl "invalid function application"
| (expr.lam _ _ _ _) := sum.inl "lambdas are not supported"
| (expr.pi n _ d b) := all (to_smt_name n) <$> type.to_z3 d <*> to_z3' b
| (expr.elet n d t b) := sum.inl "let are not supported"
| (expr.local_const _ n _ _) := sum.inr $ const (to_smt_name n)
| (expr.mvar _ _ _) := sum.inl "mvars are not supported"
| (expr.sort _) := sum.inl "sort is not supported"
| (expr.macro _ _) := sum.inl "macros are not supported"

lemma bounded.of_all {n t e b} : bounded (all n t e) b → bounded e (b+1)
| (bounded.all h) := h

lemma bounded.of_exist {n t e b} : bounded (exist n t e) b → bounded e (b+1)
| (bounded.exist h) := h

lemma bounded.of_var {n b} : bounded (var n) b → n < b
| (bounded.var h) := h

lemma bounded.of_app {fn args b} : bounded (expr'.app fn args) b → all_bounded args b
| (bounded.app h) := h

lemma all_bounded.head {x xs b} : all_bounded (x :: xs) b → bounded x b
| (all_bounded.cons h _) := h

lemma all_bounded.tail {x xs b} : all_bounded (x :: xs) b → all_bounded xs b
| (all_bounded.cons _ h) := h

def decidable.map {p q : Prop} (f : p → q) (g : q → p) : decidable p → decidable q
| (is_true p) := is_true $ f p
| (is_false p) := is_false $ λ h, p (g h)

-- open tactic
-- meta def prove_dec : tactic unit :=
-- do try well_founded_tactics.default_dec_tac,
--    `[dsimp [has_well_founded.r,sizeof_measure,measure,inv_image,sizeof]],
--    `[dsimp [has_sizeof.sizeof,psum.sizeof,sizeof]],
--    `[dsimp [psigma.sizeof]],
--    -- constructor,
--    trace_state

mutual def bounded.decide, all_bounded.decide
with bounded.decide : Π e b, decidable (bounded e b)
| (var v) := λ b,
if h : v < b then is_true  $ bounded.var h
             else is_false $ by { intro, cases a, apply h a_a }
| (const n) := λ b, is_true $ bounded.const
| (lit n) := λ b, is_true $ bounded.lit
| (all n t e) := λ b,
  -- have sizeof e < sizeof n + (sizeof t + sizeof e), from _,
  decidable.map bounded.all bounded.of_all (bounded.decide e (b+1))
| (exist n t e) := λ b, decidable.map bounded.exist bounded.of_exist (bounded.decide e $ b+1)
| (app fn args) := λ b, decidable.map bounded.app bounded.of_app (all_bounded.decide args b)
with all_bounded.decide : Π es b, decidable (all_bounded es b)
| [] := λ b, is_true all_bounded.nil
| (e :: es) := λ b,
have 2 < 1 + (1 + (1 + list.sizeof es)), by linarith,
match bounded.decide e b with
| (is_true h) :=
  match all_bounded.decide es b with
  | (is_true h') := is_true (all_bounded.cons h h')
  | (is_false h') := is_false (λ h'', h' h''.tail)
  end
| (is_false h) := is_false (λ h', h h'.head)
end

local attribute [instance] bounded.decide all_bounded.decide

mutual def expr'.to_string_aux, expr'.to_string_aux'
with expr'.to_string_aux : Π (e : expr') (vs : list smt.name), bounded e vs.length → string
| (all v t e) vs h :=
  "(forall ((" ++ v ++ " " ++ t.to_string ++ ")) " ++ e.to_string_aux (v :: vs) h.of_all ++ ")"
| (exist v t e) vs h := "(exists ((" ++ v ++ " " ++ t.to_string ++ ")) " ++ e.to_string_aux (v :: vs) h.of_exist ++ ")"
| (var v) vs h := (vs.nth_le v h.of_var).to_string
| (const v) _ _ := v
| (lit v) _ _ := to_string v
| (app fn args) vs h := "(" ++ fn ++ expr'.to_string_aux' args vs h.of_app ++ ")"
with expr'.to_string_aux' : Π (e : list expr') (vs : list smt.name), all_bounded e vs.length → string
| [] vs _ := ""
| (x :: xs) vs h :=
have 2 < 1 + (1 + (1 + list.sizeof xs)), by linarith,
" " ++ x.to_string_aux vs h.head ++ expr'.to_string_aux' xs vs h.tail

def expr.to_string : expr → string
| ⟨e,h⟩ := e.to_string_aux [] h

meta def to_z3 (e : _root_.expr) : string ⊕ expr :=
do e' ← to_z3' e,
   if h : bounded e' 0 then pure ⟨e',h⟩
                       else sum.inl "wrong use of bound variables"

meta def encode_local (v : _root_.expr) : tactic string :=
do t ← tactic.infer_type v,
   p ← tactic.is_prop t,
   if p then do
     e' ← to_z3 t,
     -- pure (format!"(assert (! {e'.to_string} :named {v.local_pp_name}))\n").to_string
     pure (format!"(assert {e'.to_string})\n").to_string
   else do
     t ← type.to_z3 t,
     -- pure (format!"(declare-const {v.local_pp_name} {t.to_string})\n").to_string
     pure (format!"(declare-fun {(to_smt_name v.local_pp_name).to_string} () {t.to_string})\n").to_string

end smt

namespace smt.parser
open smt (atom sexpr)
open smt.atom

def white := () <$ sat char.is_whitespace

def space := () <$ many white
def space1 := () <$ many1 white

def ident := (mk_simple_name ∘ list.as_string) <$> parser.many1 (sat char.is_alphanum <|> '_' <$ ch '_')

def is_printable (c : char) : Prop :=
32 ≤ c.val ∧ c.val ≤ 126

def is_symbol (c : char) : Prop :=
c ∈ ("~!@$%^&*_-+=<>.?/").to_list

instance is_printable.decidable_pred : decidable_pred is_printable :=
λ c, (by apply_instance : decidable (32 ≤ c.val ∧ c.val ≤ 126))

instance is_symbol.decidable_pred : decidable_pred is_symbol :=
λ c, (by apply_instance : decidable (c ∈ ("~!@$%^&*_-+=<>.?/").to_list))

def simple_symbol : parser string := list.as_string <$> parser.many1 (sat is_symbol <|> sat char.is_alphanum)
def symbol : parser atom := sym <$> simple_symbol
-- def keyword : parser atom := ch ':' *> atom.keyword <$> simple_symbol

def nat.of_char : list char → ℕ :=
list.foldl (λ n c, 10 * n + c.val - '0'.val) 0

def nat.bin_of_char : list char → ℕ :=
list.foldl (λ n c, 2 * n + c.val - '0'.val) 0

def nat.hex_of_char : list char → ℕ :=
let digit := "0123456789abcdef".to_list in
list.foldl (λ n c, 16 * n + list.index_of c.to_lower digit) 0

def rat.of_char : list char → ℚ :=
list.foldl (λ n (c : char), (n + ↑(c.val - '0'.val)) / 10) 0 ∘ list.reverse

def non_zero : parser char :=
sat $ λ d, char.is_digit d ∧ d ≠ '0'

def numerals : parser (list char) :=
((::) <$> non_zero <*> many (sat char.is_digit)) <|>
['0'] <$ ch '0'

def parse_nat : parser ℕ :=
nat.of_char <$> numerals

def decimal : parser atom :=
do x ← numerals,
   do { ch '.', many (ch '0'),
        y ← numerals,
        pure $ dec $ nat.of_char x + rat.of_char y } <|>
     pure (num $ nat.of_char x)

def any_of (xs : list char) : parser char :=
sat (∈ xs)

def hexa : parser atom :=
str "#x" *>
(num ∘ coe ∘ nat.hex_of_char) <$> many1 (sat char.is_digit <|> any_of "abcdefABCDEF".to_list)

def bin : parser atom :=
str "#b" *>
(num ∘ coe ∘ nat.bin_of_char) <$> many1 (any_of ['0','1'])

-- def parse_string : parser atom :=
-- ch '\"' *>
-- (atom.str ∘ list.as_string) <$> many
--           ('\"' <$ str "\"\"" <|>
--             sat (λ c, is_printable c ∧ c ≠ '\"') <|>
--             sat char.is_whitespace) <*
-- ch '\"'

def parse_atom : parser atom :=
decimal <|> hexa <|> bin <|>
-- parse_string <|>
symbol -- <|> keyword

def sexpr_parser : parser sexpr :=
parser.fix $ λ parser, (smt.sexpr.const <$> parse_atom) <|> (smt.sexpr.fapp <$> (ch '(' *> sep_by space parser <* ch ')') )

def brackets {α} (l r : string) (p : parser α) : parser α :=
str l *> p <* str r

def base_name : name → string
| (name.mk_string s _) := s
| _ := ""

open smt.sexpr tactic

meta def mk_assoc (n : name) : list expr → tactic expr
| [] := fail "mk_assoc []"
-- | [x] := pure x
| (x :: xs) :=
  do mfoldl (λ a b, mk_app n [a,b]) x xs

meta def expr.of_sexpr : sexpr → tactic expr
| (const (num n)) := pure `(n : _)
| (const (dec n)) := pure `(n)
-- | (const (sym "=")) := to_expr ``(@eq _)
-- | (const (sym "-")) := to_expr ``(@has_sub.sub _ _)
-- | (const (sym "+")) := to_expr ``(@has_add.add _ _)
| (const (sym s)) := resolve_name s >>= to_expr
| (fapp (const (sym "-") :: [x,y]))  := [x,y].mmap expr.of_sexpr >>= mk_app ``has_sub.sub
| (fapp (const (sym "-") :: [x]))    := [x].mmap expr.of_sexpr >>= mk_app ``has_neg.neg
| (fapp (const (sym "not") :: [x]))  := [x].mmap expr.of_sexpr >>= mk_app ``not
| (fapp (const (sym "+") :: xs))     := xs.mmap expr.of_sexpr >>= mk_assoc ``has_add.add
| (fapp (const (sym "and") :: xs))   := xs.mmap expr.of_sexpr >>= mk_assoc ``_root_.and
| (fapp (const (sym "=") :: [x,y]))  := [x,y].mmap expr.of_sexpr >>= mk_app ``eq
| (fapp (const (sym "<=") :: [x,y])) := [x,y].mmap expr.of_sexpr >>= mk_app ``has_le.le
| (fapp (const (sym "<") :: [x,y])) := [x,y].mmap expr.of_sexpr >>= mk_app ``has_lt.lt
| e@(fapp _) := fail format!"fapp {e.to_string}"

meta def mk_conj : list expr → expr
| [] := `(true)
| (x :: xs) := xs.foldl (λ a b, (`(and) : expr) a b) x

meta def and_prj : ℕ → expr → expr → tactic expr
| 0 `(%%p ∧ %%q) h :=
     mk_mapp ``and.elim_left [p,q,h]
| 0 p h := mk_app ``id [h]
| (i+1) `(%%p ∧ %%q) h :=
  mk_mapp ``and.elim_right [p,q,h] >>= and_prj i q
| (i+1) p h := fail format!"invalid conjunction {p}"

meta def clear_except (ls : list expr) : tactic unit :=
do n  ← revert_lst ls,
   hs ← local_context,
   hs.reverse.mmap $ λ h, try $ clear_lst [h.local_pp_name],
   intron n

end smt.parser

namespace smt

meta structure solver :=
( cmd : string )
( args : list string )
( options : list string := [] )
( output_to_file : option string := none )
( proof_type : Type )
( read : parser proof_type )
( execute : proof_type → tactic unit )

meta instance : hashable solver :=
{ hash_with_salt := λ ⟨a,b,c,d,_,_,_⟩, hash_with_salt (a,b,c,d) }

@[derive [has_repr,hashable]]
inductive logic_fragment
| AUFLIA | AUFLIRA | LIA | LRA
| QF_AUFLIA | QF_AX | QF_IDL | QF_LIA
| QF_LRA | QF_RDL | QF_UF
| QF_UFIDL | QF_UFLIA | QF_UFLRA | UFLRA
| QF_NIA | QF_NRA
-- |QF_UF
-- |QF_IDL
-- |QF_RDL
-- |QF_UFIDL

end smt


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Tactic.Clear
import Lean.Meta.Tactic.Util
import Lean.Meta.Tactic.Simp.Main

namespace Lean.Meta

namespace SimpAll

structure Entry where
  fvarId   : FVarId -- original fvarId
  userName : Name
  id       : Name   -- id of the lemma at `SimpLemmas`
  type     : Expr
  proof    : Expr
  deriving Inhabited

structure State where
  modified : Bool := false
  mvarId   : MVarId
  entries  : Array Entry := #[]
  ctx      : Simp.Context

abbrev M := StateRefT State MetaM

private def initEntries : M Unit := do
  let hs ← getNondepPropHyps (← get).mvarId
  let erased := (← get).ctx.simpLemmas.erased
  for h in hs do
    let localDecl ← getLocalDecl h
    unless erased.contains localDecl.userName do
      let fvarId := localDecl.fvarId
      let proof  := localDecl.toExpr
      let id     ← mkFreshUserName `h
      let simpLemmas ← (← get).ctx.simpLemmas.add #[] proof (name? := id)
      let entry : Entry := { fvarId := fvarId, userName := localDecl.userName, id := id, type := (← instantiateMVars localDecl.type), proof := proof }
      modify fun s => { s with entries := s.entries.push entry, ctx.simpLemmas := simpLemmas }

private abbrev getSimpLemmas : M SimpLemmas :=
  return (← get).ctx.simpLemmas

private partial def loop : M Bool := do
  modify fun s => { s with modified := false }
  -- simplify entries
  for i in [:(← get).entries.size] do
    let entry := (← get).entries[i]
    let ctx := (← get).ctx
    -- We disable the current entry to prevent it to be simplified to `True`
    let simpLemmasWithoutEntry ← (← getSimpLemmas).eraseCore entry.id
    let ctx := { ctx with simpLemmas := simpLemmasWithoutEntry }
    match (← simpStep (← get).mvarId entry.proof entry.type ctx) with
    | none => return true -- closed the goal
    | some (proofNew, typeNew) =>
      unless typeNew == entry.type do
        let id ← mkFreshUserName `h
        let simpLemmasNew ← (← getSimpLemmas).add #[] proofNew (name? := id)
        modify fun s => { s with
          modified       := true
          ctx.simpLemmas := simpLemmasNew
          entries[i]     := { entry with type := typeNew, proof := proofNew, id := id }
        }
  -- simplify target
  let mvarId := (← get).mvarId
  match (← simpTarget mvarId (← get).ctx) with
  | none => return true
  | some mvarIdNew =>
    unless mvarId == mvarIdNew do
      modify fun s => { s with
        modified := true
        mvarId   := mvarIdNew
      }
  if (← get).modified then
    loop
  else
    return false

def main : M (Option MVarId) := do
  initEntries
  if (← loop) then
    return none -- close the goal
  else
    let mvarId := (← get).mvarId
    let entries := (← get).entries
    let (_, mvarId) ← assertHypotheses mvarId (entries.map fun e => { userName := e.userName, type := e.type, value := e.proof })
    tryClearMany mvarId (entries.map fun e => e.fvarId)

end SimpAll

def simpAll (mvarId : MVarId) (ctx : Simp.Context) : MetaM (Option MVarId) := do
  withMVarContext mvarId do
    SimpAll.main.run' { mvarId := mvarId, ctx := ctx }

end Lean.Meta


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

section
open Lean Elab Command

syntax (name := timeCmd)  "#time " command : command

/--
Time the elaboration of a command, and print the result (in milliseconds).

Example usage:
```
set_option maxRecDepth 100000 in
#time example : (List.range 500).length = 500 := rfl
```
-/
@[commandElab timeCmd] def timeCmdElab : CommandElab
  | `(#time%$tk $stx:command) => do
    let start ← IO.monoMsNow
    elabCommand stx
    logInfoAt tk m!"time: {(← IO.monoMsNow) - start}ms"
  | _ => throwUnsupportedSyntax

end


namespace Foo

scoped macro "foo!" x:term:max : term => `($x + 1)

#check foo! 10

theorem ex1 : foo! 10 = 11 := rfl

end Foo

#check foo! 10 -- Error

open Foo

#check foo! 10 -- works

theorem ex2 : foo! 10 = 11 := rfl

scoped macro "bla!" x:term:max : term => `($x * 2) -- Error scoped macros must be used inside namespaces

section

local macro "bla!" x:term:max : term => `($x * 2)

theorem ex3 : bla! 10 = 20 := rfl

end

#check bla! 10 -- Error unknown identifier `bla!`

def bla! := 20 -- bla! is still a valid identifier

syntax "bar!" term:max : term

 -- Error scoped attributes must be used inside namespaces
scoped macro_rules | `(bar! $x) => `($x + 10)

section

local macro_rules | `(bar! $x) => `($x + 20)

#check bar! 10

end

-- Error no elaboration function
#check bar! 10

namespace Bar

scoped macro_rules | `(bar! $x) => `($x + 10)

#check bar! 10

end Bar

-- Error no elaboration function
#check bar! 10

open Bar

#check bar! 10


macro x:ident noWs "(" ys:term,* ")" : term => `($x $ys*)

#check id(1)

macro "foo" &"only" : tactic => `(trivial)

example : True := by foo only


import justification
import Architectural.LACU input.lacu_contract
import Architectural.lang Architectural.proofObligations
import rpo_meta
open interactive LANG PORTS

variable {α : Type}

local infix `OR`:50 := LANG.disj
local infix `&`:50 := LANG.conj

set_option pp.structure_instances_qualifier true

def local_input_name : string := "lacu_input"
def local_strat_name : string := "lacu_strat"
def local_prf_name : string := "lacu_strat_valid"

def preamble : string := "import justification Architectural.LACU input.lacu_contract rpo_meta \n open LANG PORTS \n\n
local infix `OR`:50 := LANG.disj
local infix `&`:50 := LANG.conj
\n\n
variables Is : Implementations LACU_ARCH_MODEL
variables Env : Env PORTS"

meta def proof_template (p₁ p₂ : string) : string :=
"\n\n
theorem " ++ local_prf_name ++ " : " ++ p₁ ++ " := \nbegin \n" ++ p₂ ++ "\nend" ++ "\n\n\n"

meta def evidence_file_template (input_string tscript : string) : string :=
preamble
++ "\n\n @[reducible] def " ++ local_input_name
++ " : ArchitectureWithContracts LANG LACU  := "++ input_string
++ "\n\n @[reducible] def "++ local_strat_name
++ " : Strategy (Trace PORTS) := Contract.strategy " ++ local_input_name ++ " Is Env "
++ proof_template ("deductive (Trace PORTS) " ++ " (" ++ local_strat_name ++ " Is Env)" ) (tscript)

meta def output (s : string) : io unit := do
  of ← io.mk_file_handle "src/evidence.lean" io.mode.write,
  io.fs.write of s.to_char_buffer

theorem archMap
{Var Φ : Type} [fintype Var] [decidable_eq Var] [AssertionLang Φ Var]
{S : Component Var}
{A : Architecture S}
(Is :
 Π (S' : Component Var), S' ∈ A.subs → Impl Var)
(inpt : ArchitectureWithContracts Φ S)
(h : A = inpt.to_Architecture)
: Implementations (inpt.to_Architecture) :=
by {rw ← h, exact Is,}

meta def Output (s : string) : io unit := do
  of ← io.mk_file_handle "src/evidence.lean" io.mode.write,
  io.fs.write of s.to_char_buffer

meta def driver (input : pexpr) : tactic unit :=
do
  STRAT ← tactic.to_expr input,
  if STRAT.contains_sorry then tactic.trace "ff" else do
  match STRAT with
  | `(ArchitectureWithContracts.mk %%A %%prnt %%map %%prf) := do
      inpt ← tactic.eval_expr (ArchitectureWithContracts LANG LACU) STRAT,
      input_fmt ← tactic_format_expr STRAT,
      let envc : expr := `(@set.univ (Trace PORTS)),
      let goal := `(deductive (Trace PORTS) (@Contract.mk_strategy LANG _ _ _ _ LACU (%%STRAT))),
      set_goal goal,
      `[apply via_rpo],
      solve_rpo,
      b ← is_solved,
      match b with
      | tt := do tactic.trace "tt",
         input_string ← stringOfFormatExpr STRAT,
          tactic.unsafe_run_io $ Output $ evidence_file_template input_string  "apply via_rpo,\n solve_rpo,"
      | ff := do tactic.trace "ff"
      end
  | _ := return ()
end

@[user_command]
meta def main
(meta_info : decl_meta_info)
(_ : parse (lean.parser.tk "main")) : lean.parser unit :=
do
   F ← read "src/input/inputLACU.txt" types.texpr,
   lean.parser.of_tactic $ driver F
.
 main


#reduce "".data

example : "".data = [] := rfl

theorem ex : "".data = [] := rfl


example (r : α → α → Prop) (q : Quot r) : False := by
  induction q using Quot.ind with
  | mk x => admit


import Mt.Thread.Basic
import Mt.Utils

namespace Mt.Traced

structure TracedThread (spec : Spec) where
  thread : Thread spec
  reservation : spec.Reservation

variable {spec : Spec}
local instance : IsReservation spec.Reservation :=spec.is_reservation

namespace TracedThread

def T (t : TracedThread spec) : Type :=t.thread.T
def block_until (t : TracedThread spec) : spec.State -> Bool :=t.thread.block_until
def task (t : TracedThread spec) : TaskM spec t.T :=t.thread.task
def iterate (t : TracedThread spec) : spec.State -> Thread.IterationResult spec :=t.thread.iterate

def valid (thread : TracedThread spec) : Prop :=
  thread.thread.task.valid thread.reservation
    thread.thread.block_until
    (λ _ r => r = IsReservation.empty)

theorem valid_elim {thread : TracedThread spec}
  (is_valid : thread.valid)
  : ∀ env_r s,
    thread.block_until s →
    spec.validate (env_r + thread.reservation) s → ∃ r' : spec.Reservation,
    match thread.iterate s with
      | Thread.IterationResult.Done s' =>
          spec.validate (env_r + r') s' ∧
          r' = IsReservation.empty
      | Thread.IterationResult.Panic .. => False
      | Thread.IterationResult.Running s' cont =>
        (spec.validate (env_r + r') s') ∧ TracedThread.valid ⟨cont, r'⟩ :=by
  simp only [] -- TODO: Remove
  intro env_r s bu_true initial_valid
  rw [valid, TaskM.valid] at is_valid
  have :=is_valid env_r s bu_true initial_valid
  cases this

  clear is_valid ; rename_i r' is_valid
  exists r'
  simp only [iterate, Thread.iterate]

  cases h : TaskM.iterate thread.thread.task s
  all_goals (
    rw [h] at is_valid
    exact is_valid
  )

end TracedThread

end Mt.Traced


import Lean

import Smt.Reconstruction.Certifying.Boolean
import Smt.Reconstruction.Certifying.LiftOrNToImp

namespace Smt.Reconstruction.Certifying

open Lean Elab Tactic

def applyList (l: List Term) (res: Term) : TacticM Term :=
  match l with
  | [] => return res
  | t::ts =>
    withMainContext do
      let res' := Syntax.mkApp t #[res]
      let fname ← mkIdent <$> mkFreshId
      evalTactic (← `(tactic| have $fname := $res'))
      applyList ts fname

def mkAppList : List Term → Ident → Syntax
| [], id => id
| t::ts, id =>
  let rest := mkAppList ts id
  let rest := ⟨rest⟩
  Syntax.mkApp t #[rest]

def congTactics (tactics : List Term) (i : Nat) (id : Ident) (last : Bool) : TacticM Syntax :=
  match i with
  | 0 => do
    if last then
      let innerProof := mkAppList tactics id
      let innerProof: Term := ⟨innerProof⟩
      `($innerProof)
    else
      let id' := mkIdent (Name.mkSimple "w")
      let innerProof := mkAppList tactics id'
      let innerProof: Term := ⟨innerProof⟩
      `(congOrRight (fun $id' => $innerProof) $id)
  | (i' + 1) => do
    let id' := mkIdent (Name.mkSimple "w")
    let r ← congTactics tactics i' id' last
    let r: Term := ⟨r⟩
    `(congOrLeft (fun $id' => $r) $id)

-- pull j-th term in the orchain to i-th position
-- (we start counting indices at 0)
-- TODO: clear intermediate steps
def pullToMiddleCore (i j : Nat) (hyp : Syntax) (type : Expr) (id : Ident)
  : TacticM Unit :=
  if i == j then do
    let hyp: Term := ⟨hyp⟩
    evalTactic (← `(tactic| have $id := $hyp))
  else withMainContext do
    let last := getLength type == j + 1
    let step₁: Ident ←
      if last then pure ⟨hyp⟩
      else do
        let v := List.take (j - i) $ getCongAssoc j `orAssocDir
        let res: Term := ⟨hyp⟩
        let step₁: Term ← applyList v res
        let step₁: Ident := ⟨step₁⟩
        pure step₁

    let step₂: Ident ←
      if last then do
        let tactics := List.take (j - 1 - i) $ getCongAssoc (j - 1) `orAssocDir
        let step₂: Term ← applyList tactics step₁
        let step₂: Ident := ⟨step₂⟩
        pure step₂
      else do
        let tactics₂ := List.reverse $ getCongAssoc (j - i - 1) `orAssocDir
        let wrappedTactics₂: Syntax ← congTactics tactics₂ i step₁ last
        let wrappedTactics₂: Term := ⟨wrappedTactics₂⟩
        let fname₂ ← mkIdent <$> mkFreshId
        evalTactic (← `(tactic| have $fname₂ := $wrappedTactics₂))
        pure fname₂

    let orComm: Term := ⟨mkIdent `orComm⟩
    let wrappedTactics₃ ← congTactics [orComm] i step₂ last
    let wrappedTactics₃ := ⟨wrappedTactics₃⟩
    let step₃ ← mkIdent <$> mkFreshId
    evalTactic (← `(tactic| have $step₃ := $wrappedTactics₃))

    let step₄: Ident ←
      if last then pure step₃
      else do
        let u := List.reverse $ List.take (j - i) $ getCongAssoc j `orAssocConv
        let step₄: Term ← applyList u step₃
        let step₄: Ident := ⟨step₄⟩
        pure step₄

    evalTactic (← `(tactic| have $id := $step₄))

syntax (name := pullToMiddle) "pullToMiddle" term "," term "," term "," ident : tactic

@[tactic pullToMiddle] def evalPullToMiddle : Tactic := fun stx => withMainContext do
  let i ← stxToNat ⟨stx[1]⟩
  let j ← stxToNat ⟨stx[3]⟩
  let id: Ident := ⟨stx[7]⟩
  let e ← elabTerm stx[5] none
  let t ← instantiateMVars (← Meta.inferType e)
  pullToMiddleCore i j stx[5] t id

def pullIndex (index : Nat) (hypS : Syntax) (type : Expr) (id : Ident) : TacticM Unit :=
  pullToMiddleCore 0 index hypS type id

-- insert pivot in the first position of the or-chain
-- represented by hypS
def pullCore (pivot type : Expr) (hypS : Syntax) (id : Ident)
  (sufIdx : Option Nat := none) : TacticM Unit :=
  let lastSuffix := getLength type - 1
  let sufIdx :=
    match sufIdx with
    | some i => i
    | none   => lastSuffix
  let li := collectPropsInOrChain' sufIdx type
  match getIndexList pivot li with
  | some i =>
      if i == sufIdx && sufIdx != lastSuffix then do
        if i == 0 then
          evalTactic (← `(tactic| have $id := $(⟨hypS⟩)))
        else
          let ctx ← getLCtx
          let hyp := (ctx.findFromUserName? hypS.getId).get!.toExpr
          let fname ← mkFreshId
          groupOrPrefixCore hyp type sufIdx fname
          evalTactic (← `(tactic| have $id := orComm $(mkIdent fname)))
      else
        pullIndex i hypS type id
  | none   => throwError "[Pull]: couldn't find pivot"

syntax (name := pull) "pull" term "," term "," ident : tactic

@[tactic pull] def evalPullCore : Tactic := fun stx => withMainContext do
  let e ← elabTerm stx[1] none
  let t ← instantiateMVars (← Meta.inferType e)
  let e₂ ← elabTerm stx[3] none
  pullCore e₂ t stx[1] ⟨stx[5]⟩

/- example : A ∨ B ∨ C ∨ D ∨ E → E ∨ A ∨ B ∨ C ∨ D := by -/
/-   intro h -/
/-   pull h, E, h₂ -/

end Smt.Reconstruction.Certifying


import Runtime.Time
import Runtime.Interface
import Runtime.Utilities
import Runtime.Reaction.Trigger

namespace ReactionT

/--
An event `{ action, value, time }` indicates that the action identified by name `action` should be
set to the value `value` at time `time`.
-/
structure Event (σA : Interface.Scheme) where
  action : σA.vars
  value  : σA.type action
  time   : Time

/-- Cf. `EventType` -/
instance : EventType (Event σA) where
  Id := σA.vars
  id := Event.action
  time := Event.time

/--
An `Input` in the context of a `ReactionT`-based monad carries all of the information that should be
readable by a reaction. That is:
* `ports`: source ports of the reaction
* `actions`: source action of the reaction
* `state`: state variables of the parent reactor
* `params`: parameters of the parent reactor
* `tag`: the logical tag at the time of the reaction's execution

The `physicalOffset` is not exposed directly by any monadic operation on `ReactionT` (below), but is
required by `ReactionT.getPhysicalTime`. It is used to normalize physical be 0 at the start of
execution of the program.
-/
structure Input (σPS σAS σS σP : Interface.Scheme) where
  ports          : Interface? σPS
  actions        : Interface? σAS
  state          : Interface σS
  params         : Interface σP
  tag            : Tag
  physicalOffset : Duration

/-- The time of an input is the time component of its `tag`. -/
abbrev Input.time (input : Input σPS σAS σS σP) := input.tag.time

/--
An `Output` in the context of a `ReactionT`-based monad carries all of the information that should
be writable by a reaction. That is:
* `ports`: effect ports of the reaction
* `state`: state variables of the parent reactor
* `events`: a list of `Event`s scheduled for effect actions of the reaction
* `stopRequested`: an indicator for whether the reaction requested execution to stop

The `writtenPorts` field is a (temporary) implementation detail used to record when a given port was
written to. This information is used for the implementation of connections with delays. If we didn't
force reaction bodies to be written in `do` notation, this field could be manipulated to break the
semantics of reactor execution, by marking a port as unwritten, even though it was written to. In
this case, the port's value would not be propagated along a delayed connection.
-/
-- TODO: If there's an implementation of a dependent hash map available, combine the fields `ports`
--       and `writtenPorts` by using a dependent hash map.
structure Output (σPE σAE σS : Interface.Scheme) (min : Time) where
  ports         : Interface? σPE        := Interface?.empty
  state         : Interface σS
  events        : Queue (Event σAE) min := °[]
  stopRequested : Bool                  := false
  writtenPorts  : Array σPE.vars        := #[]

-- WIP: Try implementing issue #11 before continuing with this.
-- structure Proofs (input : Input σPS σAS σS σP) (triggers : Array (Trigger σPS.vars σAS.vars Timer)) where
--   a : triggers.all (·.valued) → ¬(input.ports.isEmpty ∧ input.actions.isEmpty)
--   b : triggers = #[.startup] → input.tag = ⟨0, 0⟩
--   c : triggers = #[.timer t] → input.tag.microstep = 0

/--
The `ReactionT` monad transformer adds readable `ReactionT.Input` and writable `ReactionT.Output` to
a given monad.
-/
abbrev _root_.ReactionT (σPS σPE σAS σAE σS σP : Interface.Scheme) (m : Type → Type) (α : Type) :=
  (input : Input σPS σAS σS σP) → m (Output σPE σAE σS input.time × α)

/--
Merges outputs `o₁` and `o₂` assuming `o₂` was produced *after* `o₁`. This order is relevant for
`ports`, `state` and `events`:
* Writes to ports of `o₂` override those of `o₁`.
* The state of `o₂` is considered to be the resulting state.
* For a fixed action and time, events of `o₂` are queued *after* those of `o₁`.
-/
def Output.merge (o₁ o₂ : Output σPE σAE σS time) : Output σPE σAE σS time where
  ports         := o₁.ports.merge o₂.ports
  state         := o₂.state
  events        := o₁.events.merge o₂.events
  stopRequested := o₁.stopRequested ∨ o₂.stopRequested
  writtenPorts  := o₁.writtenPorts ++ o₂.writtenPorts

@[simp]
theorem Output.merge_ports : (Output.merge o₁ o₂).ports = o₁.ports.merge o₂.ports := rfl

@[simp]
theorem Output.merge_state : (Output.merge o₁ o₂).state = o₂.state := rfl

@[simp]
theorem Output.merge_events : (Output.merge o₁ o₂).events = o₁.events.merge o₂.events := rfl

@[simp]
theorem Output.merge_stopRequested :
  (Output.merge o₁ o₂).stopRequested = (o₁.stopRequested ∨ o₂.stopRequested) := by simp [merge]

@[simp]
theorem Output.merge_writtenPorts :
  (Output.merge o₁ o₂).writtenPorts = o₁.writtenPorts ++ o₂.writtenPorts := rfl

/--
Produces the `Output` for a given `Input` that should be the result of performing no (monadic)
operation. This amounts to simply propagating the state from input to output.
-/
def Input.noop (input : Input σPS σAS σS σP) : Output σPE σAE σS input.time where
  state := input.state

@[simp]
theorem Input.noop_ports_isEmpty (input : Input σPS σAS σS σP) {σPE σAE} :
  input.noop (σPE := σPE) (σAE := σAE) |>.ports.isEmpty := rfl

variable [Monad m]

instance : Monad (ReactionT σPS σPE σAS σAE σS σP m) where
  -- A pure value results in a noop `Output`.
  pure a input := do
    let output := input.noop
    return (output, a)
  -- Mapping a value retains the `Output`.
  map f ma input := do
    let (output, a) ← ma input
    return (output, f a)
  -- Sequencing requires the `Input` of the second operation to receive the state from the `Output`
  -- of the first operation.
  seq mf ma input₁ := do
    let (output₁, a) ← ma () input₁
    let input₂ := { input₁ with state := output₁.state }
    let (output₂, f) ← mf input₂
    return (output₂, f a)
  -- Binding requires the `Input` of the second operation to receive the state from the `Output` of
  -- the first operation. Additionally the outputs need to be merged at the end.
  bind ma f input₁ := do
    let (output₁, a) ← ma input₁
    let input₂ := { input₁ with state := output₁.state }
    let (output₂, b) ← f a input₂
    let output := output₁.merge output₂
    return (output, b)

/-- Any `IO` operation can be used in an impure (cf. `Reaction.Kind`) reaction. -/
-- TODO: This doesn't work in reaction bodies.
instance : MonadLift IO (ReactionT σPS σPE σAS σAE σS σP IO) where
  monadLift io input world :=
    match io world with
    | .error e world' => .error e world'
    | .ok    a world' => .ok (input.noop, a) world'

/--
Gets the value of a given input port. The return value is optional, as the port may be absent.
-/
def getInput (port : σPS.vars) : ReactionT σPS σPE σAS σAE σS σP m (Option <| σPS.type port) :=
  fun input => return (input.noop, input.ports port)

/-- Gets the value of a given state variable. -/
def getState (stv : σS.vars) : ReactionT σPS σPE σAS σAE σS σP m (σS.type stv) :=
  fun input => return (input.noop, input.state stv)

/--
Gets the value of a given action as scheduled for the current tag (cf. `ReactionT.Input.tag` &
`getTag`). The return value is optional, as there may be no event scheduled for the action at the
current tag.
-/
def getAction (action : σAS.vars) : ReactionT σPS σPE σAS σAE σS σP m (Option <| σAS.type action) :=
  fun input => return (input.noop, input.actions action)

/-- Gets the value of a given parameter as set for the parent reactor (instance) of the reaction. -/
def getParam (param : σP.vars) : ReactionT σPS σPE σAS σAE σS σP m (σP.type param) :=
  fun input => return (input.noop, input.params param)

/-- Gets the current logical tag. -/
def getTag : ReactionT σPS σPE σAS σAE σS σP m Tag :=
  fun input => return (input.noop, input.tag)

/-- Gets the current logical time. -/
def getLogicalTime : ReactionT σPS σPE σAS σAE σS σP m Time := do
  return (← getTag).time

/--
Gets the current physical time, which is monotonically increasing and normalized to be 0 upon the
start of the program's execution.

Note that this operation is only available in the context impure reactions (cf. `Reaction.Kind`).
-/
def getPhysicalTime : ReactionT σPS σPE σAS σAE σS σP IO Time :=
  fun input => return (input.noop, (← Time.now) - input.physicalOffset)

/-- Sets a given output port to a given value. -/
def setOutput (port : σPE.vars) (v : σPE.type port) : ReactionT σPS σPE σAS σAE σS σP m Unit :=
  fun input =>
    let ports := fun p => if h : p = port then some (h ▸ v) else none
    let output := { ports := ports, writtenPorts := #[port], state := input.state }
    return (output, ())

/-- Sets a given state variable to a given value. -/
def setState (stv : σS.vars) (v : σS.type stv) : ReactionT σPS σPE σAS σAE σS σP m Unit :=
  fun input =>
    let state := fun s => if h : s = stv then h ▸ v else input.state s
    let output := { state := state }
    return (output, ())

/--
Schedules an event for a given action with a given value to occur after a given logical delay.

If `delay = 0`, the action is scheduled for the current time with a microstep delay of 1.
If `delay > 0`, the action is scheduled for the tag `⟨(← getLogicalTime) + delay, 0⟩`.
-/
def schedule (action : σAE.vars) (delay : Duration) (v : σAE.type action) :
  ReactionT σPS σPE σAS σAE σS σP m Unit :=
  fun input =>
    let time := input.time + delay
    let event : Event σAE := { action, time, value := v }
    let output := {
      state := input.state,
      events := °[event]' (Nat.le_trans (Nat.le_refl _) (Nat.le_add_right ..))
    }
    return (output, ())

/--
Causes the program to enter shutdown mode. This results in the following steps: After invoking this
operation, execution for the current logical tag will be completed as usual. Afterwards, execution
continues at the immediate successor of the current tag (if the current tag is `⟨t, m⟩` the
immediate successor is `⟨t, m + 1⟩`). The execution of the immediate successor tag will be
accompanied by the `shutdown` trigger being active. Upon completion of that tag, the program will
terminate.
-/
def requestStop : ReactionT σPS σPE σAS σAE σS σP m Unit :=
  fun input =>
    let output := { stopRequested := true, state := input.state }
    return (output, ())

end ReactionT


import Contractome.Interfaces
import Contractome.Instances.Map256
import Contractome.Instances
import Contractome.EVM
import Contractome.UInt256
import Std.Data.Stack
import Contractome.Utils.RBMap2
import Contractome.Utils

import Contractome.ABIEncoding

open EVM

open MStd (RBMap mkRBMap)

def C : Cfg := {
  S := Std.Stack UInt256
  BA := List UInt8
  BAI := List UInt8

  M := CondensedMap
  AM := RBMap UInt256 UInt256 Ord.compare
  BAM := RBMap UInt256 (List UInt8) Ord.compare
  STM := RBMap UInt256 CondensedMap Ord.compare
  RS := Std.Stack (UInt256 × (List UInt8))
  Tw := UInt256
  Tb := UInt8
}

deriving instance Repr for Std.Stack

-- instance : Repr ByteArray := ⟨ fun a _ => byteArrayToHex a ⟩

-- #eval UInt64

instance : Repr C.Tw := (inferInstance : Repr UInt256)
instance : Repr C.Tb := (inferInstance : Repr UInt8)
instance : Repr C.M := (inferInstance : Repr CondensedMap)
instance : Repr C.S := (inferInstance : Repr (Std.Stack UInt256))
instance : Repr C.BA := (inferInstance : Repr (List UInt8))
instance : Repr C.AM := (inferInstance : Repr (RBMap UInt256 UInt256 Ord.compare))
instance : Repr C.BAM := (inferInstance : Repr (RBMap UInt256 (List UInt8) Ord.compare))
instance : Repr C.STM := (inferInstance : Repr (RBMap UInt256 CondensedMap Ord.compare))
instance : Repr C.RS := (inferInstance : Repr (Std.Stack (UInt256 × (List UInt8))))
-- deriving instance Repr for TransactionContext

instance : DecidableEq C.Tw := (inferInstance : DecidableEq UInt256)
instance : ∀ n, OfNat C.Tw n := (inferInstance : ∀ n, OfNat UInt256 n)
instance : Element C.Tw := (inferInstance : Element UInt256)

instance : DecidableEq C.Tb := (inferInstance : DecidableEq UInt8)
instance : ∀ n, OfNat C.Tb n := (inferInstance : ∀ n, OfNat UInt8 n)
instance : Element C.Tb := (inferInstance : Element UInt8)
instance : TakeBytes C.BAI := (inferInstance : TakeBytes (List UInt8))
instance : SByteArray C.Tw C.Tb C.BA C.BAI := (inferInstance : SByteArray UInt256 UInt8 (List UInt8) (List UInt8))

instance : Zero C.M := (inferInstance : Zero CondensedMap)
instance : EVMStack C.Tw C.S := (inferInstance : EVMStack UInt256 (Std.Stack UInt256))
instance : EVMStack (C.Tw × C.BA) C.RS := (inferInstance : EVMStack (UInt256 × (List UInt8)) (Std.Stack (UInt256 × (List UInt8))))
instance : EVMMapDefault C.Tw C.Tw C.AM := (inferInstance : EVMMapDefault UInt256 UInt256 (RBMap UInt256 UInt256 Ord.compare))
instance : EVMMapDefault C.Tw C.M C.STM := (inferInstance : EVMMapDefault UInt256 CondensedMap (RBMap UInt256 CondensedMap Ord.compare))
instance : EVMMapBasic C.Tw C.BA C.BAM := (inferInstance : EVMMapBasic UInt256 (List UInt8) (RBMap UInt256 (List UInt8) Ord.compare))

instance : EVMMapSeq C.Tw C.Tb C.M (BA := C.BA) (BAI := C.BAI) :=
  (inferInstance : EVMMapSeq UInt256 UInt8 (List UInt8) (List UInt8) CondensedMap)

-- variable [EVMStack C.Tw C.S] [EVMMap C.Tw C.Tw C.AM] [EVMMapSeq C.Tw C.Tb C.M (instBA := instBA)]
-- variable [EVMMapBasic C.Tw C.BA C.BAM]

#assert (hexToByteArray! "604260005260206000F3") == (hexToByteArray!' "604260005260206000F3")

def basicInput := hexToByteList!' "604260005260206000F3"

def emptySolcInput := hexToByteArray! "6080604052348015600f57600080fd5b50603f80601d6000396000f3fe6080604052600080fdfea2646970667358221220c852edbace7e3c9da7b9e566199d4b7f89d6c7c9e5d1029f0337839e993fa6fa64736f6c63430008070033"

def basicSolcInput := hexToByteList!' "6080604052348015600f57600080fd5b5060405160e338038060e38339818101604052810190602d9190604c565b80600081905550506097565b6000815190506046816083565b92915050565b600060208284031215605f57605e607e565b5b6000606b848285016039565b91505092915050565b6000819050919050565b600080fd5b608a816074565b8114609457600080fd5b50565b603f8060a46000396000f3fe6080604052600080fdfea26469706673582212209c130309b4505633bae9459145bea0f6138a99c38947f11384f39beca020bc9a64736f6c63430008070033"
def basicSolcInputWithArg := [basicSolcInput, (ABIEncodable.abiEncode 123).data.toList].join

-- #eval basicSolcInputWithArg

-- #eval basicSolcInput.size

def initTC (bytecode : List UInt8) : TransactionContext (C:=C) := {
  address := 0
  origin := 0
  caller := 0
  callvalue := 0
  balances := MStd.rbmapOf [ (0, 5) ] Ord.compare
  calldata := []
  returnData := Std.Stack.empty
  codes := MStd.rbmapOf [ (0, bytecode) ] Ord.compare
}

def initCC : ChainContext (C:=C) := {
  gasprice := 0
  blockhash := 0
  coinbase := 0
  timestamp := 0
  number := 0
  difficulty := 0
  gaslimit := 0
  chainid := 0
  basefee := 0
}

abbrev runEvm (v: EVMM (C:=C) α) (txCtx : TransactionContext (C:=C)) (chCtx : ChainContext (C:=C)) := EVMM.run (C:=C) v txCtx chCtx
abbrev runEvm' (v: EVMM (C:=C) α) (txCtx : TransactionContext (C:=C)) (chCtx : ChainContext (C:=C)) := EVMM.run' (C:=C) v txCtx chCtx

-- #eval EVM.decode basicInput
-- #eval basicInput
-- #eval EVM.decode ⟨ hexToByteArray! "604260005260206000F3", 123 ⟩

-- #eval 0x103

def stepN (n : Nat) : EVMM (C:=C) Unit := match n with
| 0 => pure ()
| n+1 => do
  if (← EVMM.isDone) then pure () else
  EVMM.step; stepN n

-- #eval UInt256.ofBytes! $ hexToByteArray! "42"
-- #eval runEvm (EVMM.getNextInstr) initTC initCC

-- #eval 0x2d

#eval runEvm (stepN 116) (initTC basicSolcInputWithArg) initCC

#reduce basicInput

set_option maxRecDepth 5000
def m := mkRBMap UInt256 UInt256 Ord.compare

-- set_option pp.all true
-- #reduce' (5 : UInt256) + 2 + 1

#reduce' EVMMapBasic.set (K:=UInt256) (V:=UInt8) m 1 0xff

-- set_option maxRecDepth 5000
-- #reduce runEvm (do
--   EVMM.pushStack 0x40
--   EVMM.pushStack 0x80
--   EVMM.i52_mstore) (initTC basicInput) initCC

-- set_option maxHeartbeats 200000
-- #reduce runEvm' (do
--   stepN 3
--   let st ← get
--   return st.memory
--   ) (initTC basicSolcInputWithArg) initCC
-- TODO note: not work

-- def hexToByteArray'(s: String): Option ByteArray := Id.run do
--   if s.length % 2 != 0 then return none
--   let mut res := ByteArray.mkEmpty $ s.length / 2
--   for i in [:((s.length)/2)] do
--     let v1 := hexChar (s[2*i])
--     let v2 := hexChar (s[2*i+1])
--     match (v1, v2) with
--     | (some v1, some v2) => res := res.push $ ⟨ (16 * v1) + v2, sorry ⟩
--     | _ => return none
--   return res
-- set_option pp.all true

-- def codeInlined : ByteArray := {}

-- local instance : OfNat UInt8 n where
--   -- ofNat := fofNat n
--   ofNat := ⟨ n % 256, sorry ⟩

-- -- #reduce basicInput
-- set_option maxRecDepth 2000
-- -- #reduce initTC basicInput

-- -- set_option maxRecDepth 10000
-- -- #redComp (1 : UInt256)

-- -- set_option maxRecDepth 10000
-- -- #reduce codeInlined

-- -- local instance : OfNat UInt8 n where
-- --   ofNat := ⟨n % 256, sorry⟩

-- set_option maxHeartbeats 500000
-- -- #redComp emptySolcInput

-- -- #reduce initTC emptySolcInput

-- constant a : UInt8

-- -- #eval b[1, 2]

-- -- #reduce initTC b[a]

-- -- theorem test1 (tC : TransactionContext) (cC : ChainContext) :=

-- #reduce runEvm (EVMM.getNextInstr) (initTC basicInput) initCC
-- #eval runEvm (stepN 116) (initTC basicSolcInputWithArg) initCC


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Tactic.Clear
import Lean.Meta.Tactic.Util
import Lean.Meta.Tactic.Simp.Main

namespace Lean.Meta

open Simp (UsedSimps)

namespace SimpAll

structure Entry where
  fvarId   : FVarId -- original fvarId
  userName : Name
  id       : Origin -- id of the theorem at `SimpTheorems`
  type     : Expr
  proof    : Expr
  deriving Inhabited

structure State where
  modified  : Bool := false
  mvarId    : MVarId
  entries   : Array Entry := #[]
  ctx       : Simp.Context
  usedSimps : UsedSimps := {}

abbrev M := StateRefT State MetaM

private def initEntries : M Unit := do
  let hs ←  (← get).mvarId.withContext do getPropHyps
  let hsNonDeps ← (← get).mvarId.getNondepPropHyps
  let mut simpThms := (← get).ctx.simpTheorems
  for h in hs do
    unless simpThms.isErased (.fvar h) do
      let localDecl ← h.getDecl
      let proof  := localDecl.toExpr
      simpThms ← simpThms.addTheorem (.fvar h) proof
      modify fun s => { s with ctx.simpTheorems := simpThms }
      if hsNonDeps.contains h then
        -- We only simplify nondependent hypotheses
        let entry : Entry := { fvarId := h, userName := localDecl.userName, id := .fvar h, type := (← instantiateMVars localDecl.type), proof := proof }
        modify fun s => { s with entries := s.entries.push entry }

private abbrev getSimpTheorems : M SimpTheoremsArray :=
  return (← get).ctx.simpTheorems

private partial def loop : M Bool := do
  modify fun s => { s with modified := false }
  -- simplify entries
  for i in [:(← get).entries.size] do
    let entry := (← get).entries[i]!
    let ctx := (← get).ctx
    -- We disable the current entry to prevent it to be simplified to `True`
    let simpThmsWithoutEntry := (← getSimpTheorems).eraseTheorem entry.id
    let ctx := { ctx with simpTheorems := simpThmsWithoutEntry }
    let (r, usedSimps) ← simpStep (← get).mvarId entry.proof entry.type ctx (usedSimps := (← get).usedSimps)
    modify fun s => { s with usedSimps }
    match r with
    | none => return true -- closed the goal
    | some (proofNew, typeNew) =>
      unless typeNew == entry.type do
        /- We must erase the `id` for the simplified theorem. Otherwise,
           the previous versions can be used to self-simplify the new version. For example, suppose we have
           ```
            x : Nat
            h : x ≠ 0
            ⊢ Unit
           ```
           In the first round, `h : x ≠ 0` is simplified to `h : ¬ x = 0`.

           It is also important for avoiding identical hypotheses to simplify each other to `True`.
           Example
           ```
           ...
           h₁ : p a
           h₂ : p a
           ⊢ q a
           ```
           `h₁` is first simplified to `True`. If we don't remove `h₁` from the set of simp theorems, it will
           be used to simplify `h₂` to `True` and information is lost.

           We must use `mkExpectedTypeHint` because `inferType proofNew` may not be equal to `typeNew` when
           we have theorems marked with `rfl`.
        -/
        trace[Meta.Tactic.simp.all] "entry.id: {← ppOrigin entry.id}, {entry.type} => {typeNew}"
        let mut simpThmsNew := (← getSimpTheorems).eraseTheorem (.fvar entry.fvarId)
        let idNew ← mkFreshId
        simpThmsNew ← simpThmsNew.addTheorem (.other idNew) (← mkExpectedTypeHint proofNew typeNew)
        modify fun s => { s with
          modified         := true
          ctx.simpTheorems := simpThmsNew
          entries[i]       := { entry with type := typeNew, proof := proofNew, id := .other idNew }
        }
  -- simplify target
  let mvarId := (← get).mvarId
  let (r, usedSimps) ← simpTarget mvarId (← get).ctx (usedSimps := (← get).usedSimps)
  modify fun s => { s with usedSimps }
  match r with
  | none => return true
  | some mvarIdNew =>
    unless mvarId == mvarIdNew do
      modify fun s => { s with
        modified := true
        mvarId   := mvarIdNew
      }
  if (← get).modified then
    loop
  else
    return false

def main : M (Option MVarId) := do
  initEntries
  if (← loop) then
    return none -- close the goal
  else
    let mvarId := (← get).mvarId
    let entries := (← get).entries
    let (_, mvarId) ← mvarId.assertHypotheses <| entries.filterMap fun e =>
      -- Do not assert `True` hypotheses
      if e.type.isConstOf ``True then none else some { userName := e.userName, type := e.type, value := e.proof }
    mvarId.tryClearMany (entries.map fun e => e.fvarId)

end SimpAll

def simpAll (mvarId : MVarId) (ctx : Simp.Context) (usedSimps : UsedSimps := {}) : MetaM (Option MVarId × UsedSimps) := do
  mvarId.withContext do
    let (r, s) ← SimpAll.main.run { mvarId, ctx, usedSimps }
    return (r, s.usedSimps)

end Lean.Meta