import Lean

-- This is a copy of Lean's DiscrTree, but with all definitional equality checks removed.

namespace CvxLean

open Lean
open Meta

inductive Key where
  | const : Name → Nat → Key
  | fvar  : FVarId → Nat → Key
  | lit   : Literal → Key
  | star  : Key
  | other : Key
  | arrow : Key
  | proj  : Name → Nat → Key
  deriving Inhabited, BEq, Repr

protected def Key.hash : Key → UInt64
  | Key.const n a => mixHash 5237 $ mixHash (hash n) (hash a)
  | Key.fvar n a  => mixHash 3541 $ mixHash (hash n) (hash a)
  | Key.lit v     => mixHash 1879 $ hash v
  | Key.star      => 7883
  | Key.other     => 2411
  | Key.arrow     => 17
  | Key.proj s i  => mixHash 11 $ mixHash (hash s) (hash i)

instance : Hashable Key := ⟨Key.hash⟩

inductive Trie (α : Type) where
  | node (vs : Array α) (children : Array (Key × Trie α)) : Trie α

structure DiscrTree (α : Type) where
  root : Std.PersistentHashMap Key (Trie α) := {}

def Key.ctorIdx : Key → Nat
  | Key.star     => 0
  | Key.other    => 1
  | Key.lit ..   => 2
  | Key.fvar ..  => 3
  | Key.const .. => 4
  | Key.arrow    => 5
  | Key.proj ..  => 6

def Key.lt : Key → Key → Bool
  | Key.lit v₁,      Key.lit v₂      => v₁ < v₂
  | Key.fvar n₁ a₁,  Key.fvar n₂ a₂  => Name.quickLt n₁.name n₂.name || (n₁ == n₂ && a₁ < a₂)
  | Key.const n₁ a₁, Key.const n₂ a₂ => Name.quickLt n₁ n₂ || (n₁ == n₂ && a₁ < a₂)
  | Key.proj s₁ i₁,  Key.proj s₂ i₂  => Name.quickLt s₁ s₂ || (s₁ == s₂ && i₁ < i₂)
  | k₁,              k₂              => k₁.ctorIdx < k₂.ctorIdx

instance : LT Key := ⟨fun a b => Key.lt a b⟩
instance (a b : Key) : Decidable (a < b) := inferInstanceAs (Decidable (Key.lt a b))

def Key.format : Key → Format
  | Key.star                   => "*"
  | Key.other                  => "◾"
  | Key.lit (Literal.natVal v) => Std.format v
  | Key.lit (Literal.strVal v) => repr v
  | Key.const k _              => Std.format k
  | Key.proj s i               => Std.format s ++ "." ++ Std.format i
  | Key.fvar k _               => Std.format k.name
  | Key.arrow                  => "→"

instance : ToFormat Key := ⟨Key.format⟩

def Key.arity : Key → Nat
  | Key.const _ a => a
  | Key.fvar _ a  => a
  | Key.arrow     => 2
  | Key.proj ..   => 1
  | _             => 0

instance : Inhabited (Trie α) := ⟨Trie.node #[] #[]⟩

namespace DiscrTree

def empty : DiscrTree α := { root := {} }

partial def Trie.format [ToMessageData α] : Trie α → MessageData
  | Trie.node vs cs => MessageData.group $ MessageData.paren $
    "node" ++ (if vs.isEmpty then MessageData.nil else " " ++ toMessageData vs)
    ++ MessageData.joinSep (cs.toList.map $ fun ⟨k, c⟩ => MessageData.paren (toMessageData k ++ " => " ++ format c)) ","

instance [ToMessageData α] : ToMessageData (Trie α) := ⟨Trie.format⟩

partial def format [ToMessageData α] (d : DiscrTree α) : MessageData :=
  let (_, r) := d.root.foldl
    (fun (p : Bool × MessageData) k c =>
      (false, p.2 ++ MessageData.paren (toMessageData k ++ " => " ++ toMessageData c)))
    (true, Format.nil)
  MessageData.group r

instance [ToMessageData α] : ToMessageData (DiscrTree α) := ⟨fun dt => format dt⟩

/- The discrimination tree ignores some implicit arguments and proofs.
   We use the following auxiliary id as a "mark". -/
private def tmpMVarId : MVarId := { name := `_discr_tree_tmp }
private def tmpStar := mkMVar tmpMVarId

instance : Inhabited (DiscrTree α) where
  default := {}

/--
  Return true iff the argument should be treated as a "wildcard" by the discrimination tree.
  - We ignore proofs because of proof irrelevance. It doesn't make sense to try to
    index their structure.
  - We ignore instance implicit arguments (e.g., `[Add α]`) because they are "morally" canonical.
    Moreover, we may have many definitionally equal terms floating around.
    Example: `Ring.hasAdd Int Int.isRing` and `Int.hasAdd`.
  - We considered ignoring implicit arguments (e.g., `{α : Type}`) since users don't "see" them,
    and may not even understand why some simplification rule is not firing.
    However, in type class resolution, we have instance such as `Decidable (@Eq Nat x y)`,
    where `Nat` is an implicit argument. Thus, we would add the path
    ```
    Decidable -> Eq -> * -> * -> * -> [Nat.decEq]
    ```
    to the discrimination tree IF we ignored the implict `Nat` argument.
    This would be BAD since **ALL** decidable equality instances would be in the same path.
    So, we index implicit arguments if they are types.
    This setting seems sensible for simplification lemmas such as:
    ```
    forall (x y : Unit), (@Eq Unit x y) = true
    ```
    If we ignore the implicit argument `Unit`, the `DiscrTree` will say it is a candidate
    simplification lemma for any equality in our goal.
  Remark: if users have problems with the solution above, we may provide a `noIndexing` annotation,
  and `ignoreArg` would return true for any term of the form `noIndexing t`.
-/
private def ignoreArg (a : Expr) (i : Nat) (infos : Array Meta.ParamInfo) : MetaM Bool := do
  if h : i < infos.size then
    let info := infos.get ⟨i, h⟩
    if info.isInstImplicit then
      return true
    else if info.isImplicit || info.isStrictImplicit then
      return not (← isType a)
    else
      isProof a
  else
    isProof a

private partial def pushArgsAux (infos : Array Meta.ParamInfo) : Nat → Expr → Array Expr → MetaM (Array Expr)
  | i, Expr.app f a, todo => do
    if (← ignoreArg a i infos) then
      pushArgsAux infos (i-1) f (todo.push tmpStar)
    else
      pushArgsAux infos (i-1) f (todo.push a)
  | _, _, todo => return todo

def mkNoindexAnnotation (e : Expr) : Expr :=
  mkAnnotation `noindex e

def hasNoindexAnnotation (e : Expr) : Bool :=
  annotation? `noindex e |>.isSome

private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) : MetaM (Key × Array Expr) := do
  if hasNoindexAnnotation e then
    return (Key.star, todo)
  else
    let fn := e.getAppFn
    let push (k : Key) (nargs : Nat) : MetaM (Key × Array Expr) := do
      let info ← getFunInfoNArgs fn nargs
      let todo ← pushArgsAux info.paramInfo (nargs-1) e todo
      return (k, todo)
    match fn with
    | Expr.lit v         => return (Key.lit v, todo)
    | Expr.const c _     =>
      let nargs := e.getAppNumArgs
      push (Key.const c nargs) nargs
    | Expr.proj s i a .. =>
      return (Key.proj s i, todo.push a)
    | Expr.fvar fvarId   =>
      let nargs := e.getAppNumArgs
      push (Key.fvar fvarId nargs) nargs
    | Expr.mvar mvarId   =>
      if mvarId == tmpMVarId then
        -- We use `tmp to mark some implicit arguments and proofs
        return (Key.star, todo)
      else
        return (Key.star, todo)
    | Expr.forallE _ d b _ =>
      if b.hasLooseBVars then
        return (Key.other, todo)
      else
        return (Key.arrow, todo.push d |>.push b)
    | _ =>
      return (Key.other, todo)

partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) : MetaM (Array Key) := do
  if todo.isEmpty then
    return keys
  else
    let e    := todo.back
    let todo := todo.pop
    let (k, todo) ← pushArgs root todo e
    mkPathAux false todo (keys.push k)

private def initCapacity := 8

def mkPath (e : Expr) : MetaM (Array Key) := do
  let todo : Array Expr := Array.mkEmpty initCapacity
  let keys : Array Key  := Array.mkEmpty initCapacity
  mkPathAux (root := true) (todo.push e) keys

private partial def createNodes (keys : Array Key) (v : α) (i : Nat) : Trie α :=
  if h : i < keys.size then
    let k := keys.get ⟨i, h⟩
    let c := createNodes keys v (i+1)
    Trie.node #[] #[(k, c)]
  else
    Trie.node #[v] #[]

private def insertVal [BEq α] (vs : Array α) (v : α) : Array α :=
  if vs.contains v then vs else vs.push v

private partial def insertAux [BEq α] (keys : Array Key) (v : α) : Nat → Trie α → Trie α
  | i, Trie.node vs cs =>
    if h : i < keys.size then
      let k := keys.get ⟨i, h⟩
      let c := Id.run $ cs.binInsertM
          (fun a b => a.1 < b.1)
          (fun ⟨_, s⟩ => let c := insertAux keys v (i+1) s; (k, c)) -- merge with existing
          (fun _ => let c := createNodes keys v (i+1); (k, c))
          (k, default)
      Trie.node vs c
    else
      Trie.node (insertVal vs v) cs

def insertCore [BEq α] (d : DiscrTree α) (keys : Array Key) (v : α) : DiscrTree α :=
  if keys.isEmpty then panic! "invalid key sequence"
  else
    let k := keys[0]!
    match d.root.find? k with
    | none =>
      let c := createNodes keys v 1
      { root := d.root.insert k c }
    | some c =>
      let c := insertAux keys v 1 c
      { root := d.root.insert k c }

def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) : MetaM (DiscrTree α) := do
  let keys ← mkPath e
  return d.insertCore keys v

private def getKeyArgs (e : Expr) (isMatch root : Bool) : MetaM (Key × Array Expr) := do
  match e.getAppFn with
  | Expr.lit v         => return (Key.lit v, #[])
  | Expr.const c _     =>
    let nargs := e.getAppNumArgs
    return (Key.const c nargs, e.getAppRevArgs)
  | Expr.fvar fvarId   =>
    let nargs := e.getAppNumArgs
    return (Key.fvar fvarId nargs, e.getAppRevArgs)
  | Expr.mvar mvarId   =>
    if isMatch then
      return (Key.other, #[])
    else do
      return (Key.star, #[])
  | Expr.proj s i a .. =>
    return (Key.proj s i, #[a])
  | Expr.forallE _ d b _ =>
    if b.hasLooseBVars then
      return (Key.other, #[])
    else
      return (Key.arrow, #[d, b])
  | _ =>
    return (Key.other, #[])

private abbrev getMatchKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
  getKeyArgs e (isMatch := true) (root := root)

private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
  getKeyArgs e (isMatch := false) (root := root)

private def getStarResult (d : DiscrTree α) : Array α :=
  let result : Array α := Array.mkEmpty initCapacity
  match d.root.find? Key.star with
  | none                  => result
  | some (Trie.node vs _) => result ++ vs

private abbrev findKey (cs : Array (Key × Trie α)) (k : Key) : Option (Key × Trie α) :=
  cs.binSearch (k, default) (fun a b => a.1 < b.1)

private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
  match c with
  | Trie.node vs cs =>
    if todo.isEmpty then
      return result ++ vs
    else if cs.isEmpty then
      return result
    else
      let e     := todo.back
      let todo  := todo.pop
      let first := cs[0]! /- Recall that `Key.star` is the minimal key -/
      let (k, args) ← getMatchKeyArgs e (root := false)
      /- We must always visit `Key.star` edges since they are wildcards.
         Thus, `todo` is not used linearly when there is `Key.star` edge
         and there is an edge for `k` and `k != Key.star`. -/
      let visitStar (result : Array α) : MetaM (Array α) :=
        if first.1 == Key.star then
          getMatchLoop todo first.2 result
        else
          return result
      let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
        match findKey cs k with
        | none   => pure result
        | some c => getMatchLoop (todo ++ args) c.2 result
      let result ← visitStar result
      match k with
      | Key.star  => pure result
      /-
        Recall that dependent arrows are `(Key.other, #[])`, and non-dependent arrows are `(Key.arrow, #[a, b])`.
        A non-dependent arrow may be an instance of a dependent arrow (stored at `DiscrTree`). Thus, we also visit the `Key.other` child.
      -/
      | Key.arrow => visitNonStar Key.other #[] (← visitNonStar k args result)
      | _         => visitNonStar k args result

private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
  match d.root.find? k with
  | none   => return result
  | some c => getMatchLoop args c result

/--
  Find values that match `e` in `d`.
-/
partial def getMatch (d : DiscrTree α) (e : Expr) : MetaM (Array α) := do
  Core.checkMaxHeartbeats "getMatch"
  let result := getStarResult d
  let (k, args) ← getMatchKeyArgs e (root := true)
  match k with
  | Key.star => return result
  | _        => getMatchRoot d k args result

partial def getUnify (d : DiscrTree α) (e : Expr) : MetaM (Array α) := do
  Core.checkMaxHeartbeats "getUnify"
  let (k, args) ← getUnifyKeyArgs e (root := true)
  match k with
  | Key.star => d.root.foldlM (init := #[]) fun result k c => process k.arity #[] c result
  | _ =>
    let result := getStarResult d
    match d.root.find? k with
    | none   => return result
    | some c => process 0 args c result
where
  process (skip : Nat) (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
    match skip, c with
    | skip+1, Trie.node vs cs =>
      if cs.isEmpty then
        return result
      else
        cs.foldlM (init := result) fun result ⟨k, c⟩ => process (skip + k.arity) todo c result
    | 0, Trie.node vs cs => do
      if todo.isEmpty then
        return result ++ vs
      else if cs.isEmpty then
        return result
      else
        let e     := todo.back
        let todo  := todo.pop
        let (k, args) ← getUnifyKeyArgs e (root := false)
        let visitStar (result : Array α) : MetaM (Array α) :=
          let first := cs[0]!
          if first.1 == Key.star then
            process 0 todo first.2 result
          else
            return result
        let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
          match findKey cs k with
          | none   => pure result
          | some c => process 0 (todo ++ args) c.2 result
        match k with
        | Key.star  => cs.foldlM (init := result) fun result ⟨k, c⟩ => process k.arity todo c result
        -- See comment a `getMatch` regarding non-dependent arrows vs dependent arrows
        | Key.arrow => visitNonStar Key.other #[] (← visitNonStar k args (← visitStar result))
        | _         => visitNonStar k args (← visitStar result)

end DiscrTree

-- From AESOP:
namespace Trie

unsafe def foldMUnsafe [Monad m] (initialKeys : Array Key)
    (f : σ → Array Key → α → m σ) (init : σ) : Trie α → m σ
  | Trie.node vs children => do
    let s ← vs.foldlM (init := init) λ s v => f s initialKeys v
    children.foldlM (init := s) λ s (k, t) =>
      t.foldMUnsafe (initialKeys.push k) f s

@[implementedBy foldMUnsafe]
opaque foldM [Monad m] (initalKeys : Array Key)
    (f : σ → Array Key → α → m σ) (init : σ) (t : Trie α) : m σ :=
  pure init

@[inline]
def fold (initialKeys : Array Key) (f : σ → Array Key → α → σ) (init : σ)
    (t : Trie α) : σ :=
  Id.run $ t.foldM initialKeys (init := init) λ s k a => return f s k a

end Trie

namespace DiscrTree

@[inline]
def foldM [Monad m] (f : σ → Array Key → α → m σ) (init : σ) (t : DiscrTree α) :
    m σ :=
  t.root.foldlM (init := init) λ s k t => t.foldM #[k] (init := s) f

@[inline]
def fold (f : σ → Array Key → α → σ) (init : σ) (t : DiscrTree α) : σ :=
  Id.run $ t.foldM (init := init) λ s keys a => return f s keys a

-- TODO inefficient since it doesn't take advantage of the Trie structure at all
@[inline]
def merge [BEq α] (t u : DiscrTree α) : DiscrTree α :=
  if t.root.size < u.root.size then loop t u else loop u t
  where
    @[inline]
    loop t u := t.fold (init := u) DiscrTree.insertCore

def values (t : DiscrTree α) : Array α :=
  t.fold (init := #[]) λ as _ a => as.push a

def toArray (t : DiscrTree α) : Array (Array Key × α) :=
  t.fold (init := #[]) λ as keys a => as.push (keys, a)

end DiscrTree

end CvxLean


import Std.Tactic.Basic
import Std.Tactic.GuardExpr
import Std.Tactic.RCases

set_option linter.missingDocs false

example (x : α × β × γ) : True := by
  rcases x with ⟨a, b, c⟩
  guard_hyp a : α
  guard_hyp b : β
  guard_hyp c : γ
  trivial

example (x : α × β × γ) : True := by
  rcases x with ⟨(a : α) : id α, -, c : id γ⟩
  guard_hyp a : α
  fail_if_success have : β := by assumption
  guard_hyp c : id γ
  trivial

example (x : (α × β) × γ) : True := by
  fail_if_success rcases x with ⟨_a, b, c⟩
  fail_if_success rcases x with ⟨⟨a:β, b⟩, c⟩
  rcases x with ⟨⟨a:α, b⟩, c⟩
  guard_hyp a : α
  guard_hyp b : β
  guard_hyp c : γ
  trivial

example : @Inhabited.{1} α × Option β ⊕ γ → True := by
  rintro (⟨⟨a⟩, _ | b⟩ | c)
  · guard_hyp a : α; trivial
  · guard_hyp a : α; guard_hyp b : β; trivial
  · guard_hyp c : γ; trivial

example : cond false Nat Int → cond true Int Nat → Nat ⊕ Unit → True := by
  rintro (x y : Int) (z | u)
  · guard_hyp x : Int; guard_hyp y : Int; guard_hyp z : Nat; trivial
  · guard_hyp x : Int; guard_hyp y : Int; guard_hyp u : Unit; trivial

example (x y : Nat) (h : x = y) : True := by
  rcases x with _|⟨⟩|z
  · guard_hyp h : Nat.zero = y; trivial
  · guard_hyp h : Nat.succ Nat.zero = y; trivial
  · guard_hyp z : Nat
    guard_hyp h : Nat.succ (Nat.succ z) = y; trivial

example (h : x = 3) (h₂ : x < 4) : x < 4 := by
  rcases h with ⟨⟩
  guard_hyp h₂ : 3 < 4; guard_target = 3 < 4; exact h₂

example (h : x = 3) (h₂ : x < 4) : x < 4 := by
  rcases h with rfl
  guard_hyp h₂ : 3 < 4; guard_target = 3 < 4; exact h₂

example (h : 3 = x) (h₂ : x < 4) : x < 4 := by
  rcases h with ⟨⟩
  guard_hyp h₂ : 3 < 4; guard_target = 3 < 4; exact h₂

example (h : 3 = x) (h₂ : x < 4) : x < 4 := by
  rcases h with rfl
  guard_hyp h₂ : 3 < 4; guard_target = 3 < 4; exact h₂

example (s : α ⊕ Empty) : True := by
  rcases s with s|⟨⟨⟩⟩
  guard_hyp s : α; trivial

example : True := by
  obtain ⟨n : Nat, _h : n = n, -⟩ : ∃ n : Nat, n = n ∧ True
  · exact ⟨0, rfl, trivial⟩
  trivial

example : True := by
  obtain (h : True) | ⟨⟨⟩⟩ : True ∨ False
  · exact Or.inl trivial
  guard_hyp h : True; trivial

example : True := by
  obtain h | ⟨⟨⟩⟩ : True ∨ False := Or.inl trivial
  guard_hyp h : True; trivial

example : True := by
  obtain ⟨h, h2⟩ := And.intro trivial trivial
  guard_hyp h : True; guard_hyp h2 : True; trivial

example : True := by
  fail_if_success obtain ⟨h, h2⟩
  trivial

example (x y : α × β) : True := by
  rcases x, y with ⟨⟨a, b⟩, c, d⟩
  guard_hyp a : α; guard_hyp b : β
  guard_hyp c : α; guard_hyp d : β
  trivial

example (x y : α ⊕ β) : True := by
  rcases x, y with ⟨a|b, c|d⟩
  · guard_hyp a : α; guard_hyp c : α; trivial
  · guard_hyp a : α; guard_hyp d : β; trivial
  · guard_hyp b : β; guard_hyp c : α; trivial
  · guard_hyp b : β; guard_hyp d : β; trivial

example (i j : Nat) : (Σ' x, i ≤ x ∧ x ≤ j) → i ≤ j := by
  intro h
  rcases h' : h with ⟨x, h₀, h₁⟩
  guard_hyp h' : h = ⟨x, h₀, h₁⟩
  apply Nat.le_trans h₀ h₁

example (x : Quot fun _ _ : α => True) (h : x = x): x = x := by
  rcases x with ⟨z⟩
  guard_hyp z : α
  guard_hyp h : Quot.mk (fun _ _ => True) z = Quot.mk (fun _ _ => True) z
  guard_target = Quot.mk (fun _ _ => True) z = Quot.mk (fun _ _ => True) z
  exact h

example (n : Nat) : True := by
  obtain _one_lt_n | _n_le_one : 1 < n + 1 ∨ n + 1 ≤ 1 := Nat.lt_or_ge 1 (n + 1)
  {trivial}; trivial

example (n : Nat) : True := by
  obtain _one_lt_n | (_n_le_one : n + 1 ≤ 1) := Nat.lt_or_ge 1 (n + 1)
  {trivial}; trivial

open Lean Elab Tactic in
/-- Asserts that the goal has `n` hypotheses. Used for testing. -/
elab "check_num_hyps " n:num : tactic => liftMetaMAtMain fun _ => do
  -- +1 because the _example recursion decl is in the list
  guard $ (← getLCtx).foldl (fun i _ => i+1) 0 = n.1.toNat + 1

example (h : ∃ x : Nat, x = x ∧ 1 = 1) : True := by
  rcases h with ⟨-, _⟩
  check_num_hyps 0
  trivial

example (h : ∃ x : Nat, x = x ∧ 1 = 1) : True := by
  rcases h with ⟨-, _, h⟩
  check_num_hyps 1
  guard_hyp h : 1 = 1
  trivial

example (h : True ∨ True ∨ True) : True := by
  rcases h with - | - | -
  iterate 3 · check_num_hyps 0; trivial

example : Bool → False → True
| false => by rintro ⟨⟩
| true => by rintro ⟨⟩

example : (b : Bool) → cond b False False → True := by
  rintro ⟨⟩ ⟨⟩

structure Baz {α : Type _} (f : α → α) : Prop where
  [inst : Nonempty α]
  h : f ∘ f = id

example {α} (f : α → α) (h : Baz f) : True := by rcases h with ⟨_⟩; trivial

example {α} (f : α → α) (h : Baz f) : True := by rcases h with @⟨_, _⟩; trivial

inductive Test : Nat → Prop
  | a (n) : Test (2 + n)
  | b {n} : n > 5 → Test (n * n)

example {n} (h : Test n) : n = n := by
  have : True := by
    rcases h with (a | b)
    · guard_hyp a : Nat
      trivial
    · guard_hyp b : ‹Nat› > 5
      trivial
  · rcases h with (a | @⟨n, b⟩)
    · guard_hyp a : Nat
      trivial
    · guard_hyp b : n > 5
      trivial

example (h : a ≤ 2 ∨ 2 < a) : True := by
  obtain ha1 | ha2 : a ≤ 2 ∨ 3 ≤ a := h
  · guard_hyp ha1 : a ≤ 2; trivial
  · guard_hyp ha2 : 3 ≤ a; trivial

example (h : a ≤ 2 ∨ 2 < a) : True := by
  obtain ha1 | ha2 : a ≤ 2 ∨ 3 ≤ a := id h
  · guard_hyp ha1 : a ≤ 2; trivial
  · guard_hyp ha2 : 3 ≤ a; trivial

inductive BaseType : Type where
  | one

inductive BaseTypeHom : BaseType → BaseType → Type where
  | loop : BaseTypeHom one one
  | id (X : BaseType) : BaseTypeHom X X

example : BaseTypeHom one one → Unit := by rintro ⟨_⟩ <;> constructor


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Sébastien Gouëzel, Scott Morrison
-/
import logic.nonempty
import tactic.lint
import tactic.dependencies

setup_tactic_parser

namespace tactic
namespace interactive
open interactive interactive.types expr

/-- Similar to `constructor`, but does not reorder goals. -/
meta def fconstructor : tactic unit := concat_tags tactic.fconstructor

add_tactic_doc
{ name       := "fconstructor",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.fconstructor],
  tags       := ["logic", "goal management"] }

/-- `try_for n { tac }` executes `tac` for `n` ticks, otherwise uses `sorry` to close the goal.
Never fails. Useful for debugging. -/
meta def try_for (max : parse parser.pexpr) (tac : itactic) : tactic unit :=
do max ← i_to_expr_strict max >>= tactic.eval_expr nat,
  λ s, match _root_.try_for max (tac s) with
  | some r := r
  | none   := (tactic.trace "try_for timeout, using sorry" >> admit) s
  end

/-- Multiple `subst`. `substs x y z` is the same as `subst x, subst y, subst z`. -/
meta def substs (l : parse ident*) : tactic unit :=
propagate_tags $ l.mmap' (λ h, get_local h >>= tactic.subst) >> try (tactic.reflexivity reducible)

add_tactic_doc
{ name       := "substs",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.substs],
  tags       := ["rewriting"] }

/-- Unfold coercion-related definitions -/
meta def unfold_coes (loc : parse location) : tactic unit :=
unfold [
  ``coe, ``coe_t, ``has_coe_t.coe, ``coe_b,``has_coe.coe,
  ``lift, ``has_lift.lift, ``lift_t, ``has_lift_t.lift,
  ``coe_fn, ``has_coe_to_fun.coe, ``coe_sort, ``has_coe_to_sort.coe] loc

add_tactic_doc
{ name       := "unfold_coes",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.unfold_coes],
  tags       := ["simplification"] }

/-- Unfold `has_well_founded.r`, `sizeof` and other such definitions. -/
meta def unfold_wf :=
propagate_tags (well_founded_tactics.unfold_wf_rel; well_founded_tactics.unfold_sizeof)

/-- Unfold auxiliary definitions associated with the current declaration. -/
meta def unfold_aux : tactic unit :=
do tgt ← target,
   name ← decl_name,
   let to_unfold := (tgt.list_names_with_prefix name),
   guard (¬ to_unfold.empty),
   -- should we be using simp_lemmas.mk_default?
   simp_lemmas.mk.dsimplify to_unfold.to_list tgt >>= tactic.change

/-- For debugging only. This tactic checks the current state for any
missing dropped goals and restores them. Useful when there are no
goals to solve but "result contains meta-variables". -/
meta def recover : tactic unit :=
metavariables >>= tactic.set_goals

/-- Like `try { tac }`, but in the case of failure it continues
from the failure state instead of reverting to the original state. -/
meta def continue (tac : itactic) : tactic unit :=
λ s, result.cases_on (tac s)
 (λ a, result.success ())
 (λ e ref, result.success ())

/-- `id { tac }` is the same as `tac`, but it is useful for creating a block scope without
requiring the goal to be solved at the end like `{ tac }`. It can also be used to enclose a
non-interactive tactic for patterns like `tac1; id {tac2}` where `tac2` is non-interactive. -/
@[inline] protected meta def id (tac : itactic) : tactic unit := tac

/--
`work_on_goal n { tac }` creates a block scope for the `n`-goal (indexed from zero),
and does not require that the goal be solved at the end
(any remaining subgoals are inserted back into the list of goals).

Typically usage might look like:
````
intros,
simp,
apply lemma_1,
work_on_goal 2
{ dsimp,
  simp },
refl
````

See also `id { tac }`, which is equivalent to `work_on_goal 0 { tac }`.
-/
meta def work_on_goal : parse small_nat → itactic → tactic unit
| n t := do
  goals ← get_goals,
  let earlier_goals := goals.take n,
  let later_goals := goals.drop (n+1),
  set_goals (goals.nth n).to_list,
  t,
  new_goals ← get_goals,
  set_goals (earlier_goals ++ new_goals ++ later_goals)

/--
`swap n` will move the `n`th goal to the front.
`swap` defaults to `swap 2`, and so interchanges the first and second goals.

See also `tactic.interactive.rotate`, which moves the first `n` goals to the back.
-/
meta def swap (n := 2) : tactic unit :=
do gs ← get_goals,
   match gs.nth (n-1) with
   | (some g) := set_goals (g :: gs.remove_nth (n-1))
   | _        := skip
   end

add_tactic_doc
{ name       := "swap",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.swap],
  tags       := ["goal management"] }

/--
`rotate` moves the first goal to the back. `rotate n` will do this `n` times.

See also `tactic.interactive.swap`, which moves the `n`th goal to the front.
-/
meta def rotate (n := 1) : tactic unit := tactic.rotate n

add_tactic_doc
{ name       := "rotate",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rotate],
  tags       := ["goal management"] }

/-- Clear all hypotheses starting with `_`, like `_match` and `_let_match`. -/
meta def clear_ : tactic unit := tactic.repeat $ do
  l ← local_context,
  l.reverse.mfirst $ λ h, do
    name.mk_string s p ← return $ local_pp_name h,
    guard (s.front = '_'),
    cl ← infer_type h >>= is_class, guard (¬ cl),
    tactic.clear h

add_tactic_doc
{ name       := "clear_",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_],
  tags       := ["context management"] }

/--
Acts like `have`, but removes a hypothesis with the same name as
this one. For example if the state is `h : p ⊢ goal` and `f : p → q`,
then after `replace h := f h` the goal will be `h : q ⊢ goal`,
where `have h := f h` would result in the state `h : p, h : q ⊢ goal`.
This can be used to simulate the `specialize` and `apply at` tactics
of Coq. -/
meta def replace (h : parse ident?) (q₁ : parse (tk ":" *> texpr)?)
  (q₂ : parse $ (tk ":=" *> texpr)?) : tactic unit :=
do let h := h.get_or_else `this,
  old ← try_core (get_local h),
  «have» h q₁ q₂,
  match old, q₂ with
  | none,   _      := skip
  | some o, some _ := tactic.clear o
  | some o, none   := swap >> tactic.clear o >> swap
  end

add_tactic_doc
{ name       := "replace",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.replace],
  tags       := ["context management"] }

/-- Make every proposition in the context decidable. -/
meta def classical := tactic.classical

add_tactic_doc
{ name       := "classical",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.classical],
  tags       := ["classical logic", "type class"] }

private meta def generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `eq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def generalize_arg_p : parser (pexpr × name) :=
with_desc "expr = id" $ parser.pexpr 0 >>= generalize_arg_p_aux

@[nolint def_lemma]
lemma {u} generalize_a_aux {α : Sort u}
  (h : ∀ x : Sort u, (α → x) → x) : α := h α id

/--
Like `generalize` but also considers assumptions
specified by the user. The user can also specify to
omit the goal.
-/
meta def generalize_hyp  (h : parse ident?) (_ : parse $ tk ":")
  (p : parse generalize_arg_p)
  (l : parse location) :
  tactic unit :=
do h' ← get_unused_name `h,
   x' ← get_unused_name `x,
   g ← if ¬ l.include_goal then
       do refine ``(generalize_a_aux _),
          some <$> (prod.mk <$> tactic.intro x' <*> tactic.intro h')
   else pure none,
   n ← l.get_locals >>= tactic.revert_lst,
   generalize h () p,
   intron n,
   match g with
     | some (x',h') :=
        do tactic.apply h',
           tactic.clear h',
           tactic.clear x'
     | none := return ()
   end

add_tactic_doc
{ name       := "generalize_hyp",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize_hyp],
  tags       := ["context management"] }

meta def compact_decl_aux : list name → binder_info → expr → list expr →
  tactic (list (list name × binder_info × expr))
| ns bi t [] := pure [(ns.reverse, bi, t)]
| ns bi t (v'@(local_const n pp bi' t') :: xs) :=
  do t' ← infer_type v',
     if bi = bi' ∧ t = t'
       then compact_decl_aux (pp :: ns) bi t xs
       else do vs ← compact_decl_aux [pp] bi' t' xs,
               pure $ (ns.reverse, bi, t) :: vs
| ns bi t (_ :: xs) := compact_decl_aux ns bi t xs

/-- go from (x₀ : t₀) (x₁ : t₀) (x₂ : t₀) to (x₀ x₁ x₂ : t₀) -/
meta def compact_decl : list expr → tactic (list (list name × binder_info × expr))
| [] := pure []
| (v@(local_const n pp bi t) :: xs)  :=
  do t ← infer_type v,
     compact_decl_aux [pp] bi t xs
| (_ :: xs) := compact_decl xs

/--
Remove identity functions from a term. These are normally
automatically generated with terms like `show t, from p` or
`(p : t)` which translate to some variant on `@id t p` in
order to retain the type.
-/
meta def clean (q : parse texpr) : tactic unit :=
do tgt : expr ← target,
   e ← i_to_expr_strict ``(%%q : %%tgt),
   tactic.exact $ e.clean

meta def source_fields (missing : list name) (e : pexpr) : tactic (list (name × pexpr)) :=
do e ← to_expr e,
   t ← infer_type e,
   let struct_n : name := t.get_app_fn.const_name,
   fields ← expanded_field_list struct_n,
   let exp_fields := fields.filter (λ x, x.2 ∈ missing),
   exp_fields.mmap $ λ ⟨p,n⟩,
     (prod.mk n ∘ to_pexpr) <$> mk_mapp (n.update_prefix p) [none,some e]

meta def collect_struct' : pexpr → state_t (list $ expr×structure_instance_info) tactic pexpr | e :=
do some str ← pure (e.get_structure_instance_info)
       | e.traverse collect_struct',
   v ← monad_lift mk_mvar,
   modify (list.cons (v,str)),
   pure $ to_pexpr v

meta def collect_struct (e : pexpr) : tactic $ pexpr × list (expr×structure_instance_info) :=
prod.map id list.reverse <$> (collect_struct' e).run []

meta def refine_one (str : structure_instance_info) :
  tactic $ list (expr×structure_instance_info) :=
do    tgt ← target >>= whnf,
      let struct_n : name := tgt.get_app_fn.const_name,
      exp_fields ← expanded_field_list struct_n,
      let missing_f := exp_fields.filter (λ f, (f.2 : name) ∉ str.field_names),
      (src_field_names,src_field_vals) ← (@list.unzip name _ ∘ list.join) <$>
        str.sources.mmap (source_fields $ missing_f.map prod.snd),
      let provided  := exp_fields.filter (λ f, (f.2 : name) ∈ str.field_names),
      let missing_f' := missing_f.filter (λ x, x.2 ∉ src_field_names),
      vs ← mk_mvar_list missing_f'.length,
      (field_values,new_goals) ← list.unzip <$> (str.field_values.mmap collect_struct : tactic _),
      e' ← to_expr $ pexpr.mk_structure_instance
          { struct := some struct_n
          , field_names  := str.field_names  ++ missing_f'.map prod.snd ++ src_field_names
          , field_values := field_values ++ vs.map to_pexpr         ++ src_field_vals },
      tactic.exact e',
      gs ← with_enable_tags (
        mzip_with (λ (n : name × name) v, do
           set_goals [v],
           try (dsimp_target simp_lemmas.mk),
           apply_auto_param
             <|> apply_opt_param
             <|> (set_main_tag [`_field,n.2,n.1]),
           get_goals)
        missing_f' vs),
      set_goals gs.join,
      return new_goals.join

meta def refine_recursively : expr × structure_instance_info → tactic (list expr) | (e,str) :=
do set_goals [e],
   rs ← refine_one str,
   gs ← get_goals,
   gs' ← rs.mmap refine_recursively,
   return $ gs'.join ++ gs

/--
`refine_struct { .. }` acts like `refine` but works only with structure instance
literals. It creates a goal for each missing field and tags it with the name of the
field so that `have_field` can be used to generically refer to the field currently
being refined.

As an example, we can use `refine_struct` to automate the construction of semigroup
instances:

```lean
refine_struct ( { .. } : semigroup α ),
-- case semigroup, mul
-- α : Type u,
-- ⊢ α → α → α

-- case semigroup, mul_assoc
-- α : Type u,
-- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)
```

`have_field`, used after `refine_struct _`, poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def refine_struct : parse texpr → tactic unit | e :=
do (x,xs) ← collect_struct e,
   refine x,
   gs ← get_goals,
   xs' ← xs.mmap refine_recursively,
   set_goals (xs'.join ++ gs)

/--
`guard_hyp' h : t` fails if the hypothesis `h` does not have type `t`.
We use this tactic for writing tests.
Fixes `guard_hyp` by instantiating meta variables
-/
meta def guard_hyp' (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_eq h p

/--
`match_hyp h : t` fails if the hypothesis `h` does not match the type `t` (which may be a pattern).
We use this tactic for writing tests.
-/
meta def match_hyp (n : parse ident) (p : parse $ tk ":" *> texpr) (m := reducible) :
  tactic (list expr) :=
do
  h ← get_local n >>= infer_type >>= instantiate_mvars,
  match_expr p h m

/--
`guard_expr_strict t := e` fails if the expr `t` is not equal to `e`. By contrast
to `guard_expr`, this tests strict (syntactic) equality.
We use this tactic for writing tests.
-/
meta def guard_expr_strict (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, guard (t = e)

/--
`guard_target_strict t` fails if the target of the main goal is not syntactically `t`.
We use this tactic for writing tests.
-/
meta def guard_target_strict (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_strict t p

/--
`guard_hyp_strict h : t` fails if the hypothesis `h` does not have type syntactically equal
to `t`.
We use this tactic for writing tests.
-/
meta def guard_hyp_strict (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_strict h p

/-- Tests that there are `n` hypotheses in the current context. -/
meta def guard_hyp_nums (n : ℕ) : tactic unit :=
do k ← local_context,
   guard (n = k.length) <|> fail format!"{k.length} hypotheses found"

/-- Test that `t` is the tag of the main goal. -/
meta def guard_tags (tags : parse ident*) : tactic unit :=
do (t : list name) ← get_main_tag,
   guard (t = tags)

/-- `guard_proof_term { t } e` applies tactic `t` and tests whether the resulting proof term
  unifies with `p`. -/
meta def guard_proof_term (t : itactic) (p : parse texpr) : itactic :=
do
  g :: _ ← get_goals,
  e ← to_expr p,
  t,
  g ← instantiate_mvars g,
  unify e g

/-- `success_if_fail_with_msg { tac } msg` succeeds if the interactive tactic `tac` fails with
error message `msg` (for test writing purposes). -/
meta def success_if_fail_with_msg (tac : tactic.interactive.itactic) :=
tactic.success_if_fail_with_msg tac

/-- Get the field of the current goal. -/
meta def get_current_field : tactic name :=
do [_,field,str] ← get_main_tag,
   expr.const_name <$> resolve_name (field.update_prefix str)

meta def field (n : parse ident) (tac : itactic) : tactic unit :=
do gs ← get_goals,
   ts ← gs.mmap get_tag,
   ([g],gs') ← pure $ (list.zip gs ts).partition (λ x, x.snd.nth 1 = some n),
   set_goals [g.1],
   tac, done,
   set_goals $ gs'.map prod.fst

/--
`have_field`, used after `refine_struct _` poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def have_field : tactic unit :=
propagate_tags $
get_current_field
>>= mk_const
>>= note `field none
>>  return ()

/-- `apply_field` functions as `have_field, apply field, clear field` -/
meta def apply_field : tactic unit :=
propagate_tags $
get_current_field >>= applyc

add_tactic_doc
{ name       := "refine_struct",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.refine_struct, `tactic.interactive.apply_field,
                 `tactic.interactive.have_field],
  tags       := ["structures"],
  inherit_description_from := `tactic.interactive.refine_struct }

/--
`apply_rules hs n` applies the list of lemmas `hs` and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times.
`n` is optional, equal to 50 by default.
You can pass an `apply_cfg` option argument as `apply_rules hs n opt`.
(A typical usage would be with `apply_rules hs n { md := reducible })`,
which asks `apply_rules` to not unfold `semireducible` definitions (i.e. most)
when checking if a lemma matches the goal.)

`hs` can contain user attributes: in this case all theorems with this
attribute are added to the list of rules.

For instance:

```lean
@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }

attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

lemma my_test {a b c d e : real} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
-- any of the following lines solve the goal:
add_le_add (add_le_add (add_le_add (add_le_add h1 (mul_le_mul_of_nonneg_right h2 h3)) h1 ) h2) h3
by apply_rules [add_le_add, mul_le_mul_of_nonneg_right]
by apply_rules [mono_rules]
by apply_rules mono_rules
```
-/
meta def apply_rules (hs : parse pexpr_list_or_texpr) (n : nat := 50) (opt : apply_cfg := {}) :
  tactic unit :=
tactic.apply_rules hs n opt

add_tactic_doc
{ name       := "apply_rules",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_rules],
  tags       := ["lemma application"] }

meta def return_cast (f : option expr) (t : option (expr × expr))
  (es : list (expr × expr × expr))
  (e x x' eq_h : expr) :
  tactic (option (expr × expr) × list (expr × expr × expr)) :=
(do guard (¬ e.has_var),
    unify x x',
    u ← mk_meta_univ,
    f ← f <|> mk_mapp ``_root_.id [(expr.sort u : expr)],
    t' ← infer_type e,
    some (f',t) ← pure t | return (some (f,t'), (e,x',eq_h) :: es),
    infer_type e >>= is_def_eq t,
    unify f f',
    return (some (f,t), (e,x',eq_h) :: es)) <|>
return (t, es)

meta def list_cast_of_aux (x : expr) (t : option (expr × expr))
  (es : list (expr × expr × expr)) :
  expr → tactic (option (expr × expr) × list (expr × expr × expr))
| e@`(cast %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mp %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mpr %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast none t es e x x'
| e@`(@eq.subst %%α %%p %%a %%b  %%eq_h %%x') := return_cast p t es e x x' eq_h
| e@`(@eq.substr %%α %%p %%a %%b %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast p t es e x x'
| e@`(@eq.rec %%α %%a %%f %%x' _  %%eq_h) := return_cast f t es e x x' eq_h
| e@`(@eq.rec_on %%α %%a %%f %%b  %%eq_h %%x') := return_cast f t es e x x' eq_h
| e := return (t,es)

meta def list_cast_of (x tgt : expr) : tactic (list (expr × expr × expr)) :=
(list.reverse ∘ prod.snd) <$> tgt.mfold (none, []) (λ e i es, list_cast_of_aux x es.1 es.2 e)

private meta def h_generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `heq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def h_generalize_arg_p : parser (pexpr × name) :=
with_desc "expr == id" $ parser.pexpr 0 >>= h_generalize_arg_p_aux

/--
`h_generalize Hx : e == x` matches on `cast _ e` in the goal and replaces it with
`x`. It also adds `Hx : e == x` as an assumption. If `cast _ e` appears multiple
times (not necessarily with the same proof), they are all replaced by `x`. `cast`
`eq.mp`, `eq.mpr`, `eq.subst`, `eq.substr`, `eq.rec` and `eq.rec_on` are all treated
as casts.

- `h_generalize Hx : e == x with h` adds hypothesis `α = β` with `e : α, x : β`;
- `h_generalize Hx : e == x with _` chooses automatically chooses the name of
  assumption `α = β`;
- `h_generalize! Hx : e == x` reverts `Hx`;
- when `Hx` is omitted, assumption `Hx : e == x` is not added.
-/
meta def h_generalize (rev : parse (tk "!")?)
     (h : parse ident_?)
     (_ : parse (tk ":"))
     (arg : parse h_generalize_arg_p)
     (eqs_h : parse ( (tk "with" >> pure <$> ident_) <|> pure [])) :
  tactic unit :=
do let (e,n) := arg,
   let h' := if h = `_ then none else h,
   h' ← (h' : tactic name) <|> get_unused_name ("h" ++ n.to_string : string),
   e ← to_expr e,
   tgt ← target,
   ((e,x,eq_h)::es) ← list_cast_of e tgt | fail "no cast found",
   interactive.generalize h' () (to_pexpr e, n),
   asm ← get_local h',
   v ← get_local n,
   hs ← es.mmap (λ ⟨e,_⟩, mk_app `eq [e,v]),
   (eqs_h.zip [e]).mmap' (λ ⟨h,e⟩, do
        h ← if h ≠ `_ then pure h else get_unused_name `h,
        () <$ note h none eq_h ),
   hs.mmap' (λ h,
     do h' ← assert `h h,
        tactic.exact asm,
        try (rewrite_target h'),
        tactic.clear h' ),
   when h.is_some (do
     (to_expr ``(heq_of_eq_rec_left %%eq_h %%asm)
       <|> to_expr ``(heq_of_cast_eq %%eq_h %%asm))
     >>= note h' none >> pure ()),
   tactic.clear asm,
   when rev.is_some (interactive.revert [n])

add_tactic_doc
{ name       := "h_generalize",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.h_generalize],
  tags       := ["context management"] }

/-- Tests whether `t` is definitionally equal to `p`. The difference with `guard_expr_eq` is that
  this uses definitional equality instead of alpha-equivalence. -/
meta def guard_expr_eq' (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, is_def_eq t e

/--
`guard_target' t` fails if the target of the main goal is not definitionally equal to `t`.
We use this tactic for writing tests.
The difference with `guard_target` is that this uses definitional equality instead of
alpha-equivalence.
-/
meta def guard_target' (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_eq' t p

add_tactic_doc
{ name       := "guard_target'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.guard_target'],
  tags       := ["testing"] }

/--
Tries to solve the goal using a canonical proof of `true` or the `reflexivity` tactic.
Unlike `trivial` or `trivial'`, does not the `contradiction` tactic.
-/
meta def triv : tactic unit :=
tactic.triv <|> tactic.reflexivity <|> fail "triv tactic failed"

add_tactic_doc
{ name       := "triv",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.triv],
  tags       := ["finishing"] }

/--
A weaker version of `trivial` that tries to solve the goal using a canonical proof of `true` or the
`reflexivity` tactic (unfolding only `reducible` constants, so can fail faster than `trivial`),
and otherwise tries the `contradiction` tactic. -/
meta def trivial' : tactic unit :=
tactic.triv'
  <|> tactic.reflexivity reducible
  <|> tactic.contradiction
  <|> fail "trivial' tactic failed"

add_tactic_doc
{ name       := "trivial'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.trivial'],
  tags       := ["finishing"] }

/--
Similar to `existsi`. `use x` will instantiate the first term of an `∃` or `Σ` goal with `x`. It
will then try to close the new goal using `trivial'`, or try to simplify it by applying
`exists_prop`. Unlike `existsi`, `x` is elaborated with respect to the expected type.
`use` will alternatively take a list of terms `[x0, ..., xn]`.

`use` will work with constructors of arbitrary inductive types.

Examples:
```lean
example (α : Type) : ∃ S : set α, S = S :=
by use ∅

example : ∃ x : ℤ, x = x :=
by use 42

example : ∃ n > 0, n = n :=
begin
  use 1,
  -- goal is now 1 > 0 ∧ 1 = 1, whereas it would be ∃ (H : 1 > 0), 1 = 1 after existsi 1.
  exact ⟨zero_lt_one, rfl⟩,
end

example : ∃ a b c : ℤ, a + b + c = 6 :=
by use [1, 2, 3]

example : ∃ p : ℤ × ℤ, p.1 = 1 :=
by use ⟨1, 42⟩

example : Σ x y : ℤ, (ℤ × ℤ) × ℤ :=
by use [1, 2, 3, 4, 5]

inductive foo
| mk : ℕ → bool × ℕ → ℕ → foo

example : foo :=
by use [100, tt, 4, 3]
```
-/
meta def use (l : parse pexpr_list_or_texpr) : tactic unit :=
focus1 $
  tactic.use l;
  try (trivial' <|> (do
        `(Exists %%p) ← target,
        to_expr ``(exists_prop.mpr) >>= tactic.apply >> skip))

add_tactic_doc
{ name       := "use",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.use, `tactic.interactive.existsi],
  tags       := ["logic"],
  inherit_description_from := `tactic.interactive.use }

/--
`clear_aux_decl` clears every `aux_decl` in the local context for the current goal.
This includes the induction hypothesis when using the equation compiler and
`_let_match` and `_fun_match`.

It is useful when using a tactic such as `finish`, `simp *` or `subst` that may use these
auxiliary declarations, and produce an error saying the recursion is not well founded.

```lean
example (n m : ℕ) (h₁ : n = m) (h₂ : ∃ a : ℕ, a = n ∧ a = m) : 2 * m = 2 * n :=
let ⟨a, ha⟩ := h₂ in
begin
  clear_aux_decl, -- subst will fail without this line
  subst h₁
end

example (x y : ℕ) (h₁ : ∃ n : ℕ, n * 1 = 2) (h₂ : 1 + 1 = 2 → x * 1 = y) : x = y :=
let ⟨n, hn⟩ := h₁ in
begin
  clear_aux_decl, -- finish produces an error without this line
  finish
end
```
-/
meta def clear_aux_decl : tactic unit := tactic.clear_aux_decl

add_tactic_doc
{ name       := "clear_aux_decl",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_aux_decl, `tactic.clear_aux_decl],
  tags       := ["context management"],
  inherit_description_from := `tactic.interactive.clear_aux_decl }

meta def loc.get_local_pp_names : loc → tactic (list name)
| loc.wildcard := list.map expr.local_pp_name <$> local_context
| (loc.ns l) := return l.reduce_option

meta def loc.get_local_uniq_names (l : loc) : tactic (list name) :=
list.map expr.local_uniq_name <$> l.get_locals

/--
The logic of `change x with y at l` fails when there are dependencies.
`change'` mimics the behavior of `change`, except in the case of `change x with y at l`.
In this case, it will correctly replace occurences of `x` with `y` at all possible hypotheses
in `l`. As long as `x` and `y` are defeq, it should never fail.
-/
meta def change' (q : parse texpr) : parse (tk "with" *> texpr)? → parse location → tactic unit
| none (loc.ns [none]) := do e ← i_to_expr q, change_core e none
| none (loc.ns [some h]) := do eq ← i_to_expr q, eh ← get_local h, change_core eq (some eh)
| none _ := fail "change-at does not support multiple locations"
| (some w) l :=
  do l' ← loc.get_local_pp_names l,
     l'.mmap' (λ e, try (change_with_at q w e)),
     when l.include_goal $ change q w (loc.ns [none])

add_tactic_doc
{ name       := "change'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.change', `tactic.interactive.change],
  tags       := ["renaming"],
  inherit_description_from := `tactic.interactive.change' }

private meta def opt_dir_with : parser (option (bool × name)) :=
(do tk "with",
   arrow ← (tk "<-")?,
   h ← ident,
   return (arrow.is_some, h)) <|> return none

/--
`set a := t with h` is a variant of `let a := t`. It adds the hypothesis `h : a = t` to
the local context and replaces `t` with `a` everywhere it can.

`set a := t with ←h` will add `h : t = a` instead.

`set! a := t with h` does not do any replacing.

```lean
example (x : ℕ) (h : x = 3)  : x + x + x = 9 :=
begin
  set y := x with ←h_xy,
/-
x : ℕ,
y : ℕ := x,
h_xy : x = y,
h : y = 3
⊢ y + y + y = 9
-/
end
```
-/
meta def set (h_simp : parse (tk "!")?) (a : parse ident) (tp : parse ((tk ":") >> texpr)?)
  (_ : parse (tk ":=")) (pv : parse texpr)
  (rev_name : parse opt_dir_with) :=
do tp ← i_to_expr $ tp.get_or_else pexpr.mk_placeholder,
   pv ← to_expr ``(%%pv : %%tp),
   tp ← instantiate_mvars tp,
   definev a tp pv,
   when h_simp.is_none $ change' ``(%%pv) (some (expr.const a [])) $ interactive.loc.wildcard,
   match rev_name with
   | some (flip, id) :=
     do nv ← get_local a,
        mk_app `eq (cond flip [pv, nv] [nv, pv]) >>= assert id,
        reflexivity
   | none := skip
   end

add_tactic_doc
{ name       := "set",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.set],
  tags       := ["context management"] }

/--
`clear_except h₀ h₁` deletes all the assumptions it can except for `h₀` and `h₁`.
-/
meta def clear_except (xs : parse ident *) : tactic unit :=
do n ← xs.mmap (try_core ∘ get_local) >>= revert_lst ∘ list.filter_map id,
   ls ← local_context,
   ls.reverse.mmap' $ try ∘ tactic.clear,
   intron_no_renames n

add_tactic_doc
{ name       := "clear_except",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_except],
  tags       := ["context management"] }

meta def format_names (ns : list name) : format :=
format.join $ list.intersperse " " (ns.map to_fmt)

private meta def indent_bindents (l r : string) : option (list name) → expr → tactic format
| none e :=
  do e ← pp e,
     pformat!"{l}{format.nest l.length e}{r}"
| (some ns) e :=
  do e ← pp e,
     let ns := format_names ns,
     let margin := l.length + ns.to_string.length + " : ".length,
     pformat!"{l}{ns} : {format.nest margin e}{r}"

private meta def format_binders : list name × binder_info × expr → tactic format
| (ns, binder_info.default, t) := indent_bindents "(" ")" ns t
| (ns, binder_info.implicit, t) := indent_bindents "{" "}" ns t
| (ns, binder_info.strict_implicit, t) := indent_bindents "⦃" "⦄" ns t
| ([n], binder_info.inst_implicit, t) :=
  if "_".is_prefix_of n.to_string
    then indent_bindents "[" "]" none t
    else indent_bindents "[" "]" [n] t
| (ns, binder_info.inst_implicit, t) := indent_bindents "[" "]" ns t
| (ns, binder_info.aux_decl, t) := indent_bindents "(" ")" ns t

private meta def partition_vars' (s : name_set) :
  list expr → list expr → list expr → tactic (list expr × list expr)
| [] as bs := pure (as.reverse, bs.reverse)
| (x :: xs) as bs :=
do t ← infer_type x,
   if t.has_local_in s then partition_vars' xs as (x :: bs)
     else partition_vars' xs (x :: as) bs

private meta def partition_vars : tactic (list expr × list expr) :=
do ls ← local_context,
   partition_vars' (name_set.of_list $ ls.map expr.local_uniq_name) ls [] []

/--
Format the current goal as a stand-alone example. Useful for testing tactics
or creating [minimal working examples](https://leanprover-community.github.io/mwe.html).

* `extract_goal`: formats the statement as an `example` declaration
* `extract_goal my_decl`: formats the statement as a `lemma` or `def` declaration
  called `my_decl`
* `extract_goal with i j k:` only use local constants `i`, `j`, `k` in the declaration

Examples:

```lean
example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
begin
  extract_goal,
     -- prints:
     -- example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
  extract_goal my_lemma
     -- prints:
     -- lemma my_lemma (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
end

example {i j k x y z w p q r m n : ℕ} (h₀ : i ≤ j) (h₁ : j ≤ k) (h₁ : k ≤ p) (h₁ : p ≤ q) : i ≤ k :=
begin
  extract_goal my_lemma,
    -- prints:
    -- lemma my_lemma {i j k x y z w p q r m n : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p)
    --   (h₁ : p ≤ q) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end

  extract_goal my_lemma with i j k
    -- prints:
    -- lemma my_lemma {p i j k : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end
end

example : true :=
begin
  let n := 0,
  have m : ℕ, admit,
  have k : fin n, admit,
  have : n + m + k.1 = 0, extract_goal,
    -- prints:
    -- example (m : ℕ)  : let n : ℕ := 0 in ∀ (k : fin n), n + m + k.val = 0 :=
    -- begin
    --   intros n k,
    --   admit,
    -- end
end
```

-/
meta def extract_goal (print_use : parse $ tt <$ tk "!" <|> pure ff)
  (n : parse ident?) (vs : parse (tk "with" *> ident*)?)
  : tactic unit :=
do tgt ← target,
   solve_aux tgt $ do
   { ((cxt₀,cxt₁,ls,tgt),_) ← solve_aux tgt $ do
       { vs.mmap clear_except,
         ls ← local_context,
         ls ← ls.mfilter $ succeeds ∘ is_local_def,
         n ← revert_lst ls,
         (c₀,c₁) ← partition_vars,
         tgt ← target,
         ls ← intron' n,
         pure (c₀,c₁,ls,tgt) },
     is_prop ← is_prop tgt,
     let title := match n, is_prop with
                  | none, _ := to_fmt "example"
                  | (some n), tt := format!"lemma {n}"
                  | (some n), ff := format!"def {n}"
                  end,
     cxt₀ ← compact_decl cxt₀ >>= list.mmap format_binders,
     cxt₁ ← compact_decl cxt₁ >>= list.mmap format_binders,
     stmt ← pformat!"{tgt} :=",
     let fmt :=
       format.group $ format.nest 2 $
         title ++ cxt₀.foldl (λ acc x, acc ++ format.group (format.line ++ x)) "" ++
         format.join (list.map (λ x, format.line ++ x) cxt₁) ++ " :" ++
         format.line ++ stmt,
     trace $ fmt.to_string $ options.mk.set_nat `pp.width 80,
     let var_names := format.intercalate " " $ ls.map (to_fmt ∘ local_pp_name),
     let call_intron := if ls.empty
                     then to_fmt ""
                     else format!"\n  intros {var_names},",
     trace!"begin{call_intron}\n  admit,\nend\n" },
   skip

add_tactic_doc
{ name       := "extract_goal",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.extract_goal],
  tags       := ["goal management", "proof extraction", "debugging"] }

/--
`inhabit α` tries to derive a `nonempty α` instance and then upgrades this
to an `inhabited α` instance.
If the target is a `Prop`, this is done constructively;
otherwise, it uses `classical.choice`.

```lean
example (α) [nonempty α] : ∃ a : α, true :=
begin
  inhabit α,
  existsi default,
  trivial
end
```
-/
meta def inhabit (t : parse parser.pexpr) (inst_name : parse ident?) : tactic unit :=
do ty ← i_to_expr t,
   nm ← returnopt inst_name <|> get_unused_name `inst,
   tgt ← target,
   tgt_is_prop ← is_prop tgt,
   if tgt_is_prop then do
     decorate_error "could not infer nonempty instance:" $
       mk_mapp ``nonempty.elim_to_inhabited [ty, none, tgt] >>= tactic.apply,
     introI nm
   else do
     decorate_error "could not infer nonempty instance:" $
      mk_mapp ``classical.inhabited_of_nonempty' [ty, none] >>= note nm none,
     resetI

add_tactic_doc
{ name       := "inhabit",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.inhabit],
  tags       := ["context management", "type class"] }

/-- `revert_deps n₁ n₂ ...` reverts all the hypotheses that depend on one of `n₁, n₂, ...`
It does not revert `n₁, n₂, ...` themselves (unless they depend on another `nᵢ`). -/
meta def revert_deps (ns : parse ident*) : tactic unit :=
propagate_tags $
  ns.mmap get_local >>= revert_reverse_dependencies_of_hyps >> skip

add_tactic_doc
{ name       := "revert_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_deps],
  tags       := ["context management", "goal management"] }

/-- `revert_after n` reverts all the hypotheses after `n`. -/
meta def revert_after (n : parse ident) : tactic unit :=
propagate_tags $ get_local n >>= tactic.revert_after >> skip

add_tactic_doc
{ name       := "revert_after",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_after],
  tags       := ["context management", "goal management"] }

/-- Reverts all local constants on which the target depends (recursively). -/
meta def revert_target_deps : tactic unit :=
propagate_tags $ tactic.revert_target_deps >> skip

add_tactic_doc
{ name       := "revert_target_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_target_deps],
  tags       := ["context management", "goal management"] }

/-- `clear_value n₁ n₂ ...` clears the bodies of the local definitions `n₁, n₂ ...`, changing them
into regular hypotheses. A hypothesis `n : α := t` is changed to `n : α`. -/
meta def clear_value (ns : parse ident*) : tactic unit :=
propagate_tags $ ns.reverse.mmap get_local >>= tactic.clear_value

add_tactic_doc
{ name       := "clear_value",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_value],
  tags       := ["context management"] }

/--
`generalize' : e = x` replaces all occurrences of `e` in the target with a new hypothesis `x` of
the same type.

`generalize' h : e = x` in addition registers the hypothesis `h : e = x`.

`generalize'` is similar to `generalize`. The difference is that `generalize' : e = x` also
succeeds when `e` does not occur in the goal. It is similar to `set`, but the resulting hypothesis
`x` is not a local definition.
-/
meta def generalize' (h : parse ident?) (_ : parse $ tk ":") (p : parse generalize_arg_p) :
  tactic unit :=
propagate_tags $
do let (p, x) := p,
   e ← i_to_expr p,
   some h ← pure h | tactic.generalize' e x >> skip,
   -- `h` is given, the regular implementation of `generalize` works.
   tgt ← target,
   tgt' ← do
   { ⟨tgt', _⟩ ← solve_aux tgt (tactic.generalize e x >> target),
     to_expr ``(Π x, %%e = x → %%(tgt'.binding_body.lift_vars 0 1)) }
   <|> to_expr ``(Π x, %%e = x → %%tgt),
   t ← assert h tgt',
   swap,
   exact ``(%%t %%e rfl),
   intro x,
   intro h

add_tactic_doc
{ name       := "generalize'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize'],
  tags       := ["context management"] }

/--
If the expression `q` is a local variable with type `x = t` or `t = x`, where `x` is a local
constant, `tactic.interactive.subst' q` substitutes `x` by `t` everywhere in the main goal and
then clears `q`.
If `q` is another local variable, then we find a local constant with type `q = t` or `t = q` and
substitute `t` for `q`.

Like `tactic.interactive.subst`, but fails with a nicer error message if the substituted variable is
a local definition. It is trickier to fix this in core, since `tactic.is_local_def` is in mathlib.
-/
meta def subst' (q : parse texpr) : tactic unit := do
i_to_expr q >>= tactic.subst' >> try (tactic.reflexivity reducible)

add_tactic_doc
{ name       := "subst'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.subst'],
  tags       := ["context management"] }

end interactive
end tactic


import data.list
import data.list.perm
import data.multiset.basic

mk_iff_of_inductive_prop list.chain test.chain_iff

mk_iff_of_inductive_prop false    test.false_iff

mk_iff_of_inductive_prop true     test.true_iff

mk_iff_of_inductive_prop nonempty test.non_empty_iff

mk_iff_of_inductive_prop and      test.and_iff

mk_iff_of_inductive_prop or       test.or_iff

mk_iff_of_inductive_prop eq       test.eq_iff

mk_iff_of_inductive_prop heq      test.heq_iff

mk_iff_of_inductive_prop list.perm  test.perm_iff

mk_iff_of_inductive_prop list.pairwise  test.pairwise_iff

inductive test.is_true (p : Prop) : Prop
| triviality : p → test.is_true

mk_iff_of_inductive_prop test.is_true test.is_true_iff

@[mk_iff] structure foo (m n : ℕ) : Prop :=
(equal : m = n)
(sum_eq_two : m + n = 2)

example (m n : ℕ) : foo m n ↔ m = n ∧ m + n = 2 := foo_iff m n

@[mk_iff bar] structure foo2 (m n : ℕ) : Prop :=
(equal : m = n)
(sum_eq_two : m + n = 2)

example (m n : ℕ) : foo2 m n ↔ m = n ∧ m + n = 2 := bar m n


/-
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.Data.Options

/- Basic support for auto bound implicit local names -/

namespace Lean.Elab

register_builtin_option autoBoundImplicitLocal : Bool := {
    defValue := true
    descr    := "Unbound local variables in declaration headers become implicit arguments if they are a lower case or greek letter followed by numeric digits. For example, `def f (x : Vector α n) : Vector α n :=` automatically introduces the implicit variables {α n}."
  }

private def isValidAutoBoundSuffix (s : String) : Bool :=
  s.toSubstring.drop 1 |>.all fun c => c.isDigit || isSubScriptAlnum c || c == '_' || c == '\''

/-
Remark: Issue #255 exposed a nasty interaction between macro scopes and auto-bound-implicit names.
```
local notation "A" => id x
theorem test : A = A := sorry
```
We used to use `n.eraseMacroScopes` at `isValidAutoBoundImplicitName` and `isValidAutoBoundLevelName`.
Thus, in the example above, when `A` is expanded, a `x` with a fresh macro scope is created.
`x`+macros-scope is not in scope and is a valid auto-bound implicit name after macro scopes are erased.
So, an auto-bound exception would be thrown, and `x`+macro-scope would be added as a new implicit.
When, we try again, a `x` with a new macro scope is created and this process keeps repeating.
Therefore, we do consider identifier with macro scopes anymore.
-/

def isValidAutoBoundImplicitName (n : Name) : Bool :=
  match n with
  | Name.str Name.anonymous s _ => s.length > 0 && (isGreek s[0] || s[0].isLower) && isValidAutoBoundSuffix s
  | _ => false

def isValidAutoBoundLevelName (n : Name) : Bool :=
  match n with
  | Name.str Name.anonymous s _ => s.length > 0 && s[0].isLower && isValidAutoBoundSuffix s
  | _ => false

end Lean.Elab


/-
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.Elab.App
import Lean.Elab.BuiltinNotation

/-! # Auxiliary elaboration functions: AKA custom elaborators -/

namespace Lean.Elab.Term
open Meta

private def getMonadForIn (expectedType? : Option Expr) : TermElabM Expr := do
    match expectedType? with
    | none => throwError "invalid 'for_in%' notation, expected type is not available"
    | some expectedType =>
      match (← isTypeApp? expectedType) with
      | some (m, _) => return m
      | none => throwError "invalid 'for_in%' notation, expected type is not of of the form `M α`{indentExpr expectedType}"

private def throwForInFailure (forInInstance : Expr) : TermElabM Expr :=
  throwError "failed to synthesize instance for 'for_in%' notation{indentExpr forInInstance}"

@[builtin_term_elab forInMacro] def elabForIn : TermElab :=  fun stx expectedType? => do
  match stx with
  | `(for_in% $col $init $body) =>
      match (← isLocalIdent? col) with
      | none   => elabTerm (← `(let col := $col; for_in% col $init $body)) expectedType?
      | some colFVar =>
        tryPostponeIfNoneOrMVar expectedType?
        let m ← getMonadForIn expectedType?
        let colType ← inferType colFVar
        let elemType ← mkFreshExprMVar (mkSort (mkLevelSucc (← mkFreshLevelMVar)))
        let forInInstance ← try
          mkAppM ``ForIn #[m, colType, elemType]
        catch _ =>
          tryPostpone; throwError "failed to construct 'ForIn' instance for collection{indentExpr colType}\nand monad{indentExpr m}"
        match (← trySynthInstance forInInstance) with
        | .some inst =>
          let forInFn ← mkConst ``forIn
          elabAppArgs forInFn
            (namedArgs := #[{ name := `m, val := Arg.expr m}, { name := `α, val := Arg.expr elemType }, { name := `self, val := Arg.expr inst }])
            (args := #[Arg.stx col, Arg.stx init, Arg.stx body])
            (expectedType? := expectedType?)
            (explicit := false) (ellipsis := false) (resultIsOutParamSupport := false)
        | .undef    => tryPostpone; throwForInFailure forInInstance
        | .none     => throwForInFailure forInInstance
  | _ => throwUnsupportedSyntax

@[builtin_term_elab forInMacro'] def elabForIn' : TermElab :=  fun stx expectedType? => do
  match stx with
  | `(for_in'% $col $init $body) =>
      match (← isLocalIdent? col) with
      | none   => elabTerm (← `(let col := $col; for_in'% col $init $body)) expectedType?
      | some colFVar =>
        tryPostponeIfNoneOrMVar expectedType?
        let m ← getMonadForIn expectedType?
        let colType ← inferType colFVar
        let elemType ← mkFreshExprMVar (mkSort (mkLevelSucc (← mkFreshLevelMVar)))
        let forInInstance ←
          try
            let memType ← mkFreshExprMVar (← mkAppM ``Membership #[elemType, colType])
            mkAppM ``ForIn' #[m, colType, elemType, memType]
          catch _ =>
            tryPostpone; throwError "failed to construct `ForIn'` instance for collection{indentExpr colType}\nand monad{indentExpr m}"
        match (← trySynthInstance forInInstance) with
        | .some inst  =>
          let forInFn ← mkConst ``forIn'
          elabAppArgs forInFn
            (namedArgs := #[{ name := `m, val := Arg.expr m}, { name := `α, val := Arg.expr elemType}, { name := `self, val := Arg.expr inst }])
            (args := #[Arg.expr colFVar, Arg.stx init, Arg.stx body])
            (expectedType? := expectedType?)
            (explicit := false) (ellipsis := false) (resultIsOutParamSupport := false)
        | .undef    => tryPostpone; throwForInFailure forInInstance
        | .none     => throwForInFailure forInInstance
  | _ => throwUnsupportedSyntax

namespace Op
/-!

The elaborator for `binop%`, `binop_lazy%`, and `unop%` terms.

It works as follows:

1- Expand macros.
2- Convert `Syntax` object corresponding to the `binop%` (`binop_lazy%` and `unop%`) term into a `Tree`.
   The `toTree` method visits nested `binop%` (`binop_lazy%` and `unop%`) terms and parentheses.
3- Synthesize pending metavariables without applying default instances and using the
   `(mayPostpone := true)`.
4- Tries to compute a maximal type for the tree computed at step 2.
   We say a type α is smaller than type β if there is a (nondependent) coercion from α to β.
   We are currently ignoring the case we may have cycles in the coercion graph.
   If there are "uncomparable" types α and β in the tree, we skip the next step.
   We say two types are "uncomparable" if there isn't a coercion between them.
   Note that two types may be "uncomparable" because some typing information may still be missing.
5- We traverse the tree and inject coercions to the "maximal" type when needed.

Recall that the coercions are expanded eagerly by the elaborator.

Properties:

a) Given `n : Nat` and `i : Nat`, it can successfully elaborate `n + i` and `i + n`. Recall that Lean 3
   fails on the former.

b) The coercions are inserted in the "leaves" like in Lean 3.

c) There are no coercions "hidden" inside instances, and we can elaborate
```
axiom Int.add_comm (i j : Int) : i + j = j + i

example (n : Nat) (i : Int) : n + i = i + n := by
  rw [Int.add_comm]
```
Recall that the `rw` tactic used to fail because our old `binop%` elaborator would hide
coercions inside of a `HAdd` instance.

Remarks:

In the new `binop%` and related elaborators the decision whether a coercion will be inserted or not
is made at `binop%` elaboration time. This was not the case in the old elaborator.
For example, an instance, such as `HAdd Int ?m ?n`, could be created when executing
the `binop%` elaborator, and only resolved much later. We try to minimize this problem
by synthesizing pending metavariables at step 3.

For types containing heterogeneous operators (e.g., matrix multiplication), step 4 will fail
and we will skip coercion insertion. For example, `x : Matrix Real 5 4` and `y : Matrix Real 4 8`,
there is no coercion `Matrix Real 5 4` from `Matrix Real 4 8` and vice-versa, but
`x * y` is elaborated successfully and has type `Matrix Real 5 8`.
-/

private inductive Tree where
  /--
  Leaf of the tree.
  We store the `infoTrees` generated when elaborating `val`. These trees become
  subtrees of the infotree nodes generated for `op` nodes.
  -/
  | term (ref : Syntax) (infoTrees : PersistentArray InfoTree) (val : Expr)
  /--
  `ref` is the original syntax that expanded into `binop%`.
  -/
  | binop (ref : Syntax) (lazy : Bool) (f : Expr) (lhs rhs : Tree)
  /--
  `ref` is the original syntax that expanded into `unop%`.
  -/
  | unop (ref : Syntax) (f : Expr) (arg : Tree)
  /--
  Used for assembling the info tree. We store this information
  to make sure "go to definition" behaves similarly to notation defined without using `binop%` helper elaborator.
  -/
  | macroExpansion (macroName : Name) (stx stx' : Syntax) (nested : Tree)

private partial def toTree (s : Syntax) : TermElabM Tree := do
  /-
  Remark: ew used to use `expandMacros` here, but this is a bad idiom
  because we do not record the macro expansion information in the info tree.
  We now manually expand the notation in the `go` function, and save
  the macro declaration names in the `op` nodes.
  -/
  let result ← go s
  synthesizeSyntheticMVars (mayPostpone := true)
  return result
where
  go (s : Syntax) := do
    match s with
    | `(binop% $f $lhs $rhs) => processBinOp (lazy := false) s f lhs rhs
    | `(binop_lazy% $f $lhs $rhs) => processBinOp (lazy := true) s f lhs rhs
    | `(unop% $f $arg) => processUnOp s f arg
    | `(($e)) =>
      if hasCDot e then
        processLeaf s
      else
        go e
    | _ =>
      withRef s do
        match (← liftMacroM <| expandMacroImpl? (← getEnv) s) with
        | some (macroName, s?) =>
          let s' ← liftMacroM <| liftExcept s?
          withPushMacroExpansionStack s s' do
            return .macroExpansion macroName s s' (← go s')
        | none => processLeaf s

  processBinOp (ref : Syntax) (f lhs rhs : Syntax) (lazy : Bool) := do
    let some f ← resolveId? f | throwUnknownConstant f.getId
    return .binop (lazy := lazy) ref f (← go lhs) (← go rhs)

  processUnOp (ref : Syntax) (f arg : Syntax) := do
    let some f ← resolveId? f | throwUnknownConstant f.getId
    return .unop ref f (← go arg)

  processLeaf (s : Syntax) := do
    let e ← elabTerm s none
    let info ← getResetInfoTrees
    return .term s info e

-- Auxiliary function used at `analyze`
private def hasCoe (fromType toType : Expr) : TermElabM Bool := do
  if (← getEnv).contains ``CoeT then
    withLocalDeclD `x fromType fun x => do
    match ← coerceSimple? x toType with
    | .some _ => return true
    | .none   => return false
    | .undef  => return false -- TODO: should we do something smarter here?
  else
    return false

private structure AnalyzeResult where
  max?            : Option Expr := none
  hasUncomparable : Bool := false -- `true` if there are two types `α` and `β` where we don't have coercions in any direction.

private def isUnknow : Expr → Bool
  | .mvar ..        => true
  | .app f _        => isUnknow f
  | .letE _ _ _ b _ => isUnknow b
  | .mdata _ b      => isUnknow b
  | _               => false

private def analyze (t : Tree) (expectedType? : Option Expr) : TermElabM AnalyzeResult := do
  let max? ←
    match expectedType? with
    | none => pure none
    | some expectedType =>
      let expectedType ← instantiateMVars expectedType
      if isUnknow expectedType then pure none else pure (some expectedType)
  (go t *> get).run' { max? }
where
   go (t : Tree) : StateRefT AnalyzeResult TermElabM Unit := do
     unless (← get).hasUncomparable do
       match t with
       | .macroExpansion _ _ _ nested => go nested
       | .binop _ _ _ lhs rhs => go lhs; go rhs
       | .unop _ _ arg => go arg
       | .term _ _ val =>
         let type ← instantiateMVars (← inferType val)
         unless isUnknow type do
           match (← get).max? with
           | none     => modify fun s => { s with max? := type }
           | some max =>
             unless (← withNewMCtxDepth <| isDefEqGuarded max type) do
               if (← hasCoe type max) then
                 return ()
               else if (← hasCoe max type) then
                 modify fun s => { s with max? := type }
               else
                 trace[Elab.binop] "uncomparable types: {max}, {type}"
                 modify fun s => { s with hasUncomparable := true }

private def mkBinOp (f : Expr) (lhs rhs : Expr) : TermElabM Expr := do
  elabAppArgs f #[] #[Arg.expr lhs, Arg.expr rhs] (expectedType? := none) (explicit := false) (ellipsis := false) (resultIsOutParamSupport := false)

private def mkUnOp (f : Expr) (arg : Expr) : TermElabM Expr := do
  elabAppArgs f #[] #[Arg.expr arg] (expectedType? := none) (explicit := false) (ellipsis := false) (resultIsOutParamSupport := false)

private def toExprCore (t : Tree) : TermElabM Expr := do
  match t with
  | .term _ trees e =>
    modifyInfoState (fun s => { s with trees := s.trees ++ trees }); return e
  | .binop ref lazy f lhs rhs =>
    withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
      let lhs ← toExprCore lhs
      let mut rhs ← toExprCore rhs
      if lazy then
        rhs ← mkFunUnit rhs
      mkBinOp f lhs rhs
  | .unop ref f arg =>
    withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
      mkUnOp f (← toExprCore arg)
  | .macroExpansion macroName stx stx' nested =>
    withRef stx <| withInfoContext' stx (mkInfo := mkTermInfo macroName stx) do
      withMacroExpansion stx stx' do
        toExprCore nested

/--
  Auxiliary function to decide whether we should coerce `f`'s argument to `maxType` or not.
  - `f` is a binary operator.
  - `lhs == true` (`lhs == false`) if are trying to coerce the left-argument (right-argument).
  This function assumes `f` is a heterogeneous operator (e.g., `HAdd.hAdd`, `HMul.hMul`, etc).
  It returns true IF
  - `f` is a constant of the form `Cls.op` where `Cls` is a class name, and
  - `maxType` is of the form `C ...` where `C` is a constant, and
  - There are more than one default instance. That is, it assumes the class `Cls` for the heterogeneous operator `f`, and
    always has the monomorphic instance. (e.g., for `HAdd`, we have `instance [Add α] : HAdd α α α`), and
  - If `lhs == true`, then there is a default instance of the form `Cls _ (C ..) _`, and
  - If `lhs == false`, then there is a default instance of the form `Cls (C ..) _ _`.

  The motivation is to support default instances such as
  ```
  @[default_instance high]
  instance [Mul α] : HMul α (Array α) (Array α) where
    hMul a as := as.map (a * ·)

  #eval 2 * #[3, 4, 5]
  ```
  If the type of an argument is unknown we should not coerce it to `maxType` because it would prevent
  the default instance above from being even tried.
-/
private def hasHeterogeneousDefaultInstances (f : Expr) (maxType : Expr) (lhs : Bool) : MetaM Bool := do
  let .const fName .. := f | return false
  let .const typeName .. := maxType.getAppFn | return false
  let className := fName.getPrefix
  let defInstances ← getDefaultInstances className
  if defInstances.length ≤ 1 then return false
  for (instName, _) in defInstances do
    if let .app (.app (.app _heteroClass lhsType) rhsType) _resultType :=
        (← getConstInfo instName).type.getForallBody then
      if  lhs && rhsType.isAppOf typeName then return true
      if !lhs && lhsType.isAppOf typeName then return true
  return false

/--
  Return `true` if polymorphic function `f` has a homogenous instance of `maxType`.
  The coercions to `maxType` only makes sense if such instance exists.

  For example, suppose `maxType` is `Int`, and `f` is `HPow.hPow`. Then,
  adding coercions to `maxType` only make sense if we have an instance `HPow Int Int Int`.
-/
private def hasHomogeneousInstance (f : Expr) (maxType : Expr) : MetaM Bool := do
  let .const fName .. := f | return false
  let className := fName.getPrefix
  try
    let inst ← mkAppM className #[maxType, maxType, maxType]
    return (← trySynthInstance inst) matches .some _
  catch _ =>
    return false

mutual
  /--
    Try to coerce elements in the `t` to `maxType` when needed.
    If the type of an element in `t` is unknown we only coerce it to `maxType` if `maxType` does not have heterogeneous
    default instances. This extra check is approximated by `hasHeterogeneousDefaultInstances`.

    Remark: If `maxType` does not implement heterogeneous default instances, we do want to assign unknown types `?m` to
    `maxType` because it produces better type information propagation. Our test suite has many tests that would break if
    we don't do this. For example, consider the term
    ```
    eq_of_isEqvAux a b hsz (i+1) (Nat.succ_le_of_lt h) heqv.2
    ```
    `Nat.succ_le_of_lt h` type depends on `i+1`, but `i+1` only reduces to `Nat.succ i` if we know that `1` is a `Nat`.
    There are several other examples like that in our test suite, and one can find them by just replacing the
    `← hasHeterogeneousDefaultInstances f maxType lhs` test with `true`

    Remark: if `hasHeterogeneousDefaultInstances` implementation is not good enough we should refine it in the future.
  -/
  private partial def applyCoe (t : Tree) (maxType : Expr) (isPred : Bool) : TermElabM Tree := do
    go t none false isPred
  where
    go (t : Tree) (f? : Option Expr) (lhs : Bool) (isPred : Bool) : TermElabM Tree := do
      match t with
      | .binop ref lazy f lhs rhs =>
        /-
          We only keep applying coercions to `maxType` if `f` is predicate or
          `f` has a homogenous instance with `maxType`. See `hasHomogeneousInstance` for additional details.

          Remark: We assume `binrel%` elaborator is only used with homogenous predicates.
        -/
        if (← pure isPred <||> hasHomogeneousInstance f maxType) then
          return .binop ref lazy f (← go lhs f true false) (← go rhs f false false)
        else
          let r ← withRef ref do
            mkBinOp f (← toExpr lhs none) (← toExpr rhs none)
          let infoTrees ← getResetInfoTrees
          return .term ref infoTrees r
      | .unop ref f arg =>
        return .unop ref f (← go arg none false false)
      | .term ref trees e =>
        let type ← instantiateMVars (← inferType e)
        trace[Elab.binop] "visiting {e} : {type} =?= {maxType}"
        if isUnknow type then
          if let some f := f? then
            if (← hasHeterogeneousDefaultInstances f maxType lhs) then
              -- See comment at `hasHeterogeneousDefaultInstances`
              return t
        if (← isDefEqGuarded maxType type) then
          return t
        else
          trace[Elab.binop] "added coercion: {e} : {type} => {maxType}"
          withRef ref <| return .term ref trees (← mkCoe maxType e)
      | .macroExpansion macroName stx stx' nested =>
        withRef stx <| withPushMacroExpansionStack stx stx' do
          return .macroExpansion macroName stx stx' (← go nested f? lhs isPred)

  private partial def toExpr (tree : Tree) (expectedType? : Option Expr) : TermElabM Expr := do
    let r ← analyze tree expectedType?
    trace[Elab.binop] "hasUncomparable: {r.hasUncomparable}, maxType: {r.max?}"
    if r.hasUncomparable || r.max?.isNone then
      let result ← toExprCore tree
      ensureHasType expectedType? result
    else
      let result ← toExprCore (← applyCoe tree r.max?.get! (isPred := false))
      trace[Elab.binop] "result: {result}"
      ensureHasType expectedType? result

end

def elabOp : TermElab := fun stx expectedType? => do
  toExpr (← toTree stx) expectedType?

@[builtin_term_elab binop]
def elabBinOp : TermElab := elabOp

@[builtin_term_elab binop_lazy]
def elabBinOpLazy : TermElab := elabOp

@[builtin_term_elab unop]
def elabUnOp : TermElab := elabOp

/--
  Elaboration functionf for `binrel%` and `binrel_no_prop%` notations.
  We use the infrastructure for `binop%` to make sure we propagate information between the left and right hand sides
  of a binary relation.

  Recall that the `binrel_no_prop%` notation is used for relations such as `==` which do not support `Prop`, but
  we still want to be able to write `(5 > 2) == (2 > 1)`.
-/
def elabBinRelCore (noProp : Bool) (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr :=  do
  match (← resolveId? stx[1]) with
  | some f => withSynthesizeLight do
    /-
    We used to use `withSynthesize (mayPostpone := true)` here instead of `withSynthesizeLight` here.
    Recall that `withSynthesizeLight` is equivalent to `withSynthesize (mayPostpone := true) (synthesizeDefault := false)`.
    It seems too much to apply default instances at binary relations. For example, we cannot elaborate
    ```
    def as : List Int := [-1, 2, 0, -3, 4]
    #eval as.map fun a => ite (a ≥ 0) [a] []
    ```
    The problem is that when elaborating `a ≥ 0` we don't know yet that `a` is an `Int`.
    Then, by applying default instances, we apply the default instance to `0` that forces it to become an `Int`,
    and Lean infers that `a` has type `Nat`.
    Then, later we get a type error because `as` is `List Int` instead of `List Nat`.
    This behavior is quite counterintuitive since if we avoid this elaborator by writing
    ```
    def as : List Int := [-1, 2, 0, -3, 4]
    #eval as.map fun a => ite (GE.ge a 0) [a] []
    ```
    everything works.
    However, there is a drawback of using `withSynthesizeLight` instead of `withSynthesize (mayPostpone := true)`.
    The following cannot be elaborated
    ```
    have : (0 == 1) = false := rfl
    ```
    We get a type error at `rfl`. `0 == 1` only reduces to `false` after we have applied the default instances that force
    the numeral to be `Nat`. We claim this is defensible behavior because the same happens if we do not use this elaborator.
    ```
    have : (BEq.beq 0 1) = false := rfl
    ```
    We can improve this failure in the future by applying default instances before reporting a type mismatch.
    -/
    let lhs ← withRef stx[2] <| toTree stx[2]
    let rhs ← withRef stx[3] <| toTree stx[3]
    let tree := .binop (lazy := false) stx f lhs rhs
    let r ← analyze tree none
    trace[Elab.binrel] "hasUncomparable: {r.hasUncomparable}, maxType: {r.max?}"
    if r.hasUncomparable || r.max?.isNone then
      -- Use default elaboration strategy + `toBoolIfNecessary`
      let lhs ← toExprCore lhs
      let rhs ← toExprCore rhs
      let lhs ← toBoolIfNecessary lhs
      let rhs ← toBoolIfNecessary rhs
      let lhsType ← inferType lhs
      let rhs ← ensureHasType lhsType rhs
      elabAppArgs f #[] #[Arg.expr lhs, Arg.expr rhs] expectedType? (explicit := false) (ellipsis := false) (resultIsOutParamSupport := false)
    else
      let mut maxType := r.max?.get!
      /- If `noProp == true` and `maxType` is `Prop`, then set `maxType := Bool`. `See toBoolIfNecessary` -/
      if noProp then
        if (← withNewMCtxDepth <| isDefEq maxType (mkSort levelZero)) then
          maxType := Lean.mkConst ``Bool
      let result ← toExprCore (← applyCoe tree maxType (isPred := true))
      trace[Elab.binrel] "result: {result}"
      return result
  | none   => throwUnknownConstant stx[1].getId
where
  /-- If `noProp == true` and `e` has type `Prop`, then coerce it to `Bool`. -/
  toBoolIfNecessary (e : Expr) : TermElabM Expr := do
    if noProp then
      -- We use `withNewMCtxDepth` to make sure metavariables are not assigned
      if (← withNewMCtxDepth <| isDefEq (← inferType e) (mkSort levelZero)) then
        return (← ensureHasType (Lean.mkConst ``Bool) e)
    return e

@[builtin_term_elab binrel] def elabBinRel : TermElab := elabBinRelCore false

@[builtin_term_elab binrel_no_prop] def elabBinRelNoProp : TermElab := elabBinRelCore true

@[builtin_term_elab defaultOrOfNonempty]
def elabDefaultOrNonempty : TermElab :=  fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  match expectedType? with
  | none => throwError "invalid 'default_or_ofNonempty%', expected type is not known"
  | some expectedType =>
    try
      mkDefault expectedType
    catch ex => try
      mkOfNonempty expectedType
    catch _ =>
      if stx[1].isNone then
        throw ex
      else
        -- It is in the context of an `unsafe` constant. We can use sorry instead.
        -- Another option is to make a recursive application since it is unsafe.
        mkSorry expectedType false

builtin_initialize
  registerTraceClass `Elab.binop
  registerTraceClass `Elab.binrel

end Op

end Lean.Elab.Term


import tactic.default

universes u v
-- #check @option.elim
-- def option.elim {α β} (x : β) (f : α → β) : option α → β
-- | none := x
-- | (some y) := f y
-- #exit
namespace list

def mfilter_map {m} [applicative m] {α β} (f : α → m (option β)) : list α → m (list.{v} β)
| [] := pure []
| (x :: xs) :=
  (λ a, option.elim a id (::)) <$> f x <*> mfilter_map xs

def mfilter_map' {m} [applicative m] [alternative m] {α β} (f : α → m β) : list α → m (list.{v} β)
| [] := pure []
| (x :: xs) :=
  ((::) <$> f x <|> pure id) <*> mfilter_map' xs

end list

namespace tactic

open native

meta def rename_many' (renames : name_map name) (strict := tt) (use_unique_names := ff)
: tactic (list (name × expr)) :=
do let hyp_name : expr → name :=
     if use_unique_names then expr.local_uniq_name else expr.local_pp_name,
   ctx ← revertible_local_context,
   -- The part of the context after (but including) the first hypthesis that
   -- must be renamed.
   let ctx_suffix := ctx.drop_while (λ h, (renames.find $ hyp_name h).is_none),
   when strict $ do {
     let ctx_names := rb_map.set_of_list (ctx_suffix.map hyp_name),
     let invalid_renames :=
       (renames.to_list.map prod.fst).filter (λ h, ¬ ctx_names.contains h),
     when ¬ invalid_renames.empty $ fail $ format.join
       [ "Cannot rename these hypotheses:\n"
       , format.join $ (invalid_renames.map to_fmt).intersperse ", "
       , format.line
       , "This is because these hypotheses either do not occur in the\n"
       , "context or they occur before a frozen local instance.\n"
       , "In the latter case, try `tactic.unfreeze_local_instances`."
       ]
   },
   -- The new names for all hypotheses in ctx_suffix.
   let new_names :=
     ctx_suffix.map $ λ h,
       (renames.find $ hyp_name h).get_or_else h.local_pp_name,
   revert_lst ctx_suffix,
   -- trace_state,
   xs ← intro_lst new_names,
   xs' ← xs.mmap infer_type,
   -- trace $ ctx_suffix.zip $ xs.zip xs',
   pure $ (ctx_suffix.map expr.local_uniq_name).zip xs

meta def find_hyp (pat : pexpr) (f : expr → tactic unit) : tactic unit := do
ls ← local_context,
pat ← pexpr_to_pattern pat,
ls.mfirst $ λ h, do
  t ← infer_type h,
  match_pattern pat t,
  f h

meta def find_all_hyps (pat : pexpr) (f : expr → tactic unit) : tactic unit := do
ls ← local_context,
pat ← pexpr_to_pattern pat,
ls.mmap' $ λ h, try $ do
  t ← infer_type h,
  match_pattern pat t,
  f h

namespace interactive
setup_tactic_parser

meta def find_hyp (id : parse ident) (_ : parse (tk ":=")) (pat : parse texpr)
  (_ : parse (tk "then")) (tac : itactic) : tactic unit := do
ls ← local_context,
pat ← pexpr_to_pattern pat,
ls.mfirst $ λ h, do
  t ← infer_type h,
  match_pattern pat t,
  rename_many (native.rb_map.of_list [(h.local_uniq_name, id)]) tt tt,
  tac,
  rename_many $ native.rb_map.of_list [(id, h.local_pp_name)]
-- #exit

meta def find_all_hyps (id : parse ident) (_ : parse (tk ":=")) (pat : parse texpr)
  (_ : parse (tk "then")) (tac : itactic) : tactic unit := do
ls ← local_context,
pat ← pexpr_to_pattern pat,
ls.reverse.mmap' (λ h,
  -- trace σ,
  -- let h := h.instantiate_locals $ list.reverse σ,
  try_or_report_error $ do {
    t ← infer_type h,
    match_pattern pat t,
    -- trace!"{h} : {t}",
    n ← tactic.revert h,
    intro id,
    intron $ n-1,
    -- xs ← rename_many' (native.rb_map.of_list [(h.local_uniq_name, id)]) tt tt,
    tac,
    h' ← get_local id,
    n ← tactic.revert h',
    intro h.local_pp_name,
    intron $ n-1,
    skip }),
skip

meta def match_le_or_lt : expr → option (expr × expr)
| `(%%x < %%y) := pure (x, y)
| `(%%x ≤ %%y) := pure (x, y)
| `(%%x > %%y) := pure (y, x)
| `(%%x ≥ %%y) := pure (y, x)
| _ := none

meta def match_le : expr → option (expr × expr)
| `(%%x ≤ %%y) := pure (x, y)
| `(%%x ≥ %%y) := pure (y, x)
| _ := none

meta def match_lt : expr → option (expr × expr)
| `(%%x < %%y) := pure (x, y)
| `(%%x > %%y) := pure (y, x)
| _ := none

#print list.filter_map

inductive edge
| lt | le

instance : has_to_string edge :=
⟨ λ e, match e with
      | edge.lt := "lt"
      | edge.le := "le"
      end ⟩

meta instance edge.has_to_format : has_to_format edge :=
⟨ λ e, to_fmt $ to_string e ⟩

meta instance rb_lmap.has_to_format {α β} [has_to_tactic_format α] [has_to_tactic_format β] : has_to_tactic_format (native.rb_lmap α β) :=
by delta native.rb_lmap; apply_instance

open native

meta def graph := (native.rb_lmap expr (expr × edge × expr))

meta instance graph.has_to_format : has_to_tactic_format graph :=
by delta graph; apply_instance

meta def dfs_trans' (g : graph) (r : ref expr_set) (v : expr) : edge → expr → expr → tactic expr
| e x h := do
  x ← instantiate_mvars x,
  -- trace!"visit {x}, going to {v}",
  vs ← read_ref r,
  -- trace!"seen: {vs}",
  if vs.contains x then failed
  else if v = x then pure h
  else do
    write_ref r $ vs.insert x,
    -- trace (g.find x),
    (g.find x).mfirst $ λ ⟨h',e',y⟩, do
      -- trace!"try: {x}, {y}",
      (e,h) ← match e, e' with
              | edge.lt, edge.lt := prod.mk edge.lt <$> mk_app ``lt_trans [h, h']
              | edge.lt, edge.le := prod.mk edge.lt <$> mk_app ``lt_of_lt_of_le [h, h']
              | edge.le, edge.lt := prod.mk edge.lt <$> mk_app ``lt_of_le_of_lt [h, h']
              | edge.le, edge.le := prod.mk edge.le <$> mk_app ``le_trans [h, h']
              end,
      -- trace"ok",
      dfs_trans' e y h

meta def dfs_trans (g : graph) (v v' : expr) : tactic expr :=
using_new_ref mk_expr_set $ λ r, do
  h ← mk_mapp ``le_refl [none, none, v],
  dfs_trans' g r v' edge.le v h

#check cc_state

lemma lt_of_eq_of_lt_of_eq {α} {R : α → α → Prop} {x x' y' y : α} (h₀ : x = x') (h₁ : R x' y') (h₂ : y' = y) :
  R x y := by subst_vars; exact h₁

-- lemma t_of_eq_of_lt_of_eq {α} [has_lt α] {x x' y' y : α} (h₀ : x = x') (h₁ : x' < y') (h₂ : y' = y) :
--   x < y := by subst_vars; exact h₁

meta def chain_trans : tactic unit := do
tgt ← target,
(x, y) ← match_le_or_lt tgt,
α ← infer_type x,
s ← cc_state.mk_using_hs,
ls ← local_context >>= list.mfilter_map'
  (λ h, do t ← infer_type h,
           do { (e, x, y) ← prod.mk edge.le <$> match_le t <|>
                    prod.mk edge.lt <$> match_lt t,
                let x' := s.root x,
                let y' := s.root y,
                x_pr ← s.eqv_proof x' x,
                y_pr ← s.eqv_proof y y',
                h' ← mk_app ``lt_of_eq_of_lt_of_eq [x_pr, h, y_pr],
                -- trace!"h  : {infer_type h}",
                -- trace!"h' : {infer_type h'}",
                infer_type x >>= is_def_eq α,
                pure [(h', e, x', y')] }),
 -- <|>
 --           do { (x, y) ← match_eq t,
 --                infer_type x >>= is_def_eq α,
 --                h₀ ← mk_eq_symm h >>= mk_app ``le_of_eq ∘ list.ret,
 --                h₁ ← mk_app ``le_of_eq [h],
 --                pure [(h₀, edge.le, y, x), (h₁, edge.le, x, y)] }),
let m := list.foldl  (λ (m : graph) (e : _ × _ × _ × _),
  let ⟨pr,e,x,y⟩ := e in
  m.insert x (pr,e,y)) (native.rb_lmap.mk expr (expr × edge × expr)) ls.join,
x ← whnf x,
y ← whnf y,
pr ← dfs_trans m x y,
tactic.apply pr <|>
  mk_app ``le_of_lt [pr] >>= tactic.apply,
skip

end interactive

setup_tactic_parser
precedence `=?`:0

import_private set_cases_tags
import_private cases_postprocess

meta def interactive.trichotomy (x : parse texpr) (_ : parse $ tk "=?") (y : parse texpr) (hyp : parse $ tk "with" *> ident <|> pure `h) : tactic unit := do
x ← to_expr x,
y ← to_expr y,
α ← infer_type x,
inst ← mk_app ``linear_order [α] >>= mk_instance,
h' ← mk_mapp ``cmp_compares [α, inst, x, y] >>= note hyp none,

e ← mk_app ``cmp [x, y],
n ← revert_kdependencies e,
x ← get_unused_name,
tactic.generalize e x,

h ← tactic.intro1,
s ← simp_lemmas.mk.add_simp ``ordering.compares,
in_tag ← get_main_tag,
focus1 $ do
  hs ← cases_core h,
  set_cases_tags in_tag $ cases_postprocess hs,
  gs ← get_goals,
  gs ← (gs.zip hs).mmap $ λ ⟨g,h,_,σ⟩, do
  { set_goals [g],
    interactive.propagate_tags $ do
    { dsimp_target (some s) [] { fail_if_unchanged := ff },
      intron_no_renames (n) },
    get_goals },
  set_goals gs.join

end tactic

example {x y : ℤ} (h : x ≤ y) (h : x < y) : true :=
begin
  find_hyp hh := x ≤ _ then { replace hh : x = y, admit },
  trivial
end

example {x y z w u v : ℕ} {a b : ℤ} (h₀ : x ≤ y) (h₁ : y < z) (h : y < u) (h₂ : z < w) (h₃ : w = u) (h₄ : u < v) : x ≤ u :=
begin
  chain_trans,
end