import Lean.Data.HashMap

inductive NEList (α : Type)
  | uno  : α → NEList α
  | cons : α → NEList α → NEList α

def NEList.contains [BEq α] : NEList α → α → Bool
  | uno  a,    x => a == x
  | cons a as, x => a == x || as.contains x

def NEList.noDup [BEq α] : NEList α → Bool
  | uno  a    => true
  | cons a as => ¬as.contains a && as.noDup

@[specialize]
def NEList.foldl (f : α → β → α) : (init : α) → NEList β → α
  | a, uno  b   => f a b
  | a, cons b l => foldl f (f a b) l

@[specialize]
def NEList.map (f : α → β) : NEList α → NEList β
  | uno  a     => uno  (f a)
  | cons a  as => cons (f a) (map f as)

inductive Literal
  | bool  : Bool   → Literal
  | int   : Int    → Literal
  | float : Float  → Literal
  | str   : String → Literal

inductive BinOp
  | add | mul | eq | ne | lt | le | gt | ge

inductive UnOp
  | not

mutual

  inductive Lambda
    | mk : (l : NEList String) → l.noDup → Program → Lambda

  inductive Expression
    | lit   : Literal → Expression
    | var   : String → Expression
    | lam   : Lambda → Expression
    | list  : List Literal → Expression
    | app   : Expression → NEList Expression → Expression
    | unOp  : UnOp  → Expression → Expression
    | binOp : BinOp → Expression → Expression → Expression

  inductive Program
    | skip  : Program
    | eval  : Expression → Program
    | decl  : String  → Program → Program
    | seq   : Program → Program → Program
    | fork  : Expression → Program → Program → Program
    | loop  : Expression → Program → Program
    | print : Expression → Program
    deriving Inhabited

end

inductive Value
  | nil  : Value
  | lit  : Literal → Value
  | list : List Literal → Value
  | lam  : Lambda → Value
  deriving Inhabited

abbrev Context := Lean.HashMap String Value

inductive ErrorType
  | name | type | runTime

def Literal.typeStr : Literal → String
  | bool  _ => "bool"
  | int   _ => "int"
  | float _ => "float"
  | str   _ => "str"

def removeRightmostZeros (s : String) : String :=
  let rec aux (buff res : List Char) : List Char → List Char
    | []      => res.reverse
    | a :: as =>
      if a != '0'
        then aux [] (a :: (buff ++ res)) as
        else aux (a :: buff) res as
  ⟨aux [] [] s.data⟩

protected def Literal.toString : Literal → String
  | bool  b => toString b
  | int   i => toString i
  | float f => removeRightmostZeros $ toString f
  | str   s => s

def Lambda.typeStr : Lambda → String
  | mk l .. => (l.foldl (init := "") fun acc _ => acc ++ "_ → ") ++ "_"

def Value.typeStr : Value → String
  | nil    => "nil"
  | lit  l => l.typeStr
  | list _ => "list"
  | lam  l => l.typeStr

def Literal.eq : Literal → Literal → Bool
  | bool  bₗ, bool  bᵣ => bₗ == bᵣ
  | int   iₗ, int   iᵣ => iₗ == iᵣ
  | float fₗ, float fᵣ => fₗ == fᵣ
  | int   iₗ, float fᵣ => (.ofInt iₗ) == fᵣ
  | float fₗ, int   iᵣ => fₗ == (.ofInt iᵣ)
  | str   sₗ, str   sᵣ => sₗ == sᵣ
  | _       , _        => false

def listLiteralEq : List Literal → List Literal → Bool
  | [], [] => true
  | a :: a' :: as, b :: b' :: bs =>
    a.eq b && listLiteralEq (a' :: as) (b' :: bs)
  | _, _   => false

def opError (app l r : String) : String :=
  s!"I can't perform a '{app}' operation between '{l}' and '{r}'"

def opError1 (app v : String) : String :=
  s!"I can't perform a '{app}' operation on '{v}'"

def Value.not : Value → Except String Value
  | lit $ .bool b => return lit $ .bool !b
  | v             => throw $ opError1 "!" v.typeStr

def Value.add : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ || bᵣ
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .int  $ iₗ +  iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .float $ fₗ +  fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .float $ (.ofInt iₗ) +  fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .float $ fₗ +  (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .str   $ sₗ ++ sᵣ
  | list         lₗ, list         lᵣ => return list  $ lₗ ++ lᵣ
  | list         l,  lit          r  => return list  $ l.concat r
  | l,               r               => throw $ opError "+" l.typeStr r.typeStr

def Value.mul : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return .lit $ .bool  $ bₗ && bᵣ
  | lit $ .int   iₗ, lit $ .int   iᵣ => return .lit $ .int   $ iₗ *  iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return .lit $ .float $ fₗ *  fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return .lit $ .float $ (.ofInt iₗ) *  fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return .lit $ .float $ fₗ *  (.ofInt iᵣ)
  | l,               r               => throw $ opError "*" l.typeStr r.typeStr

def Bool.toNat : Bool → Nat
  | false => 0
  | true  => 1

def Value.lt : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat < bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ < iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ < fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) < fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ < (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ < sᵣ
  | list lₗ, list lᵣ => return lit $ .bool $ lₗ.length < lᵣ.length
  | l,               r               => throw $ opError "<" l.typeStr r.typeStr

def Value.le : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat ≤ bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ ≤ iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ ≤ fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) ≤ fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ ≤ (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ < sᵣ || sₗ == sᵣ
  | list lₗ, list  lᵣ => return lit $ .bool $ lₗ.length ≤ lᵣ.length
  | l,         r      => throw $ opError "<=" l.typeStr r.typeStr

def Value.gt : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat > bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ > iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ > fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) > fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ > (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ > sᵣ
  | list lₗ, list lᵣ => return lit $ .bool $ lₗ.length > lᵣ.length
  | l,       r       => throw $ opError ">" l.typeStr r.typeStr

def Value.ge : Value → Value → Except String Value
  | lit $ .bool  bₗ, lit $ .bool  bᵣ => return lit $ .bool $ bₗ.toNat ≥ bᵣ.toNat
  | lit $ .int   iₗ, lit $ .int   iᵣ => return lit $ .bool $ iₗ ≥ iᵣ
  | lit $ .float fₗ, lit $ .float fᵣ => return lit $ .bool $ fₗ ≥ fᵣ
  | lit $ .int   iₗ, lit $ .float fᵣ => return lit $ .bool $ (.ofInt iₗ) ≥ fᵣ
  | lit $ .float fₗ, lit $ .int   iᵣ => return lit $ .bool $ fₗ ≥ (.ofInt iᵣ)
  | lit $ .str   sₗ, lit $ .str   sᵣ => return lit $ .bool $ sₗ > sᵣ || sₗ == sᵣ
  | list lₗ, list  lᵣ => return lit $ .bool $ lₗ.length ≥ lᵣ.length
  | l,       r        => throw $ opError ">=" l.typeStr r.typeStr

def Value.eq : Value → Value → Except String Value
  | nil,     nil      => return lit $ .bool true
  | lit  lₗ, lit lᵣ   => return lit $ .bool $ lₗ.eq lᵣ
  | list lₗ, list  lᵣ => return lit $ .bool (listLiteralEq lₗ lᵣ)
  | lam .. , lam ..   => throw "I can't compare functions"
  | _,       _        => return lit $ .bool false

def Value.ne : Value → Value → Except String Value
  | nil,     nil      => return lit $ .bool false
  | lit  lₗ, lit lᵣ   => return lit $ .bool $ !(lₗ.eq lᵣ)
  | list lₗ, list  lᵣ => return lit $ .bool !(listLiteralEq lₗ lᵣ)
  | lam ..,  lam ..   => throw "I can't compare functions"
  | _,       _        => return lit $ .bool true

def Value.unOp : Value → UnOp → Except String Value
  | v, .not => v.not

def Value.binOp : Value → Value → BinOp → Except String Value
  | l, r, .add => l.add r
  | l, r, .mul => l.mul r
  | l, r, .lt  => l.lt r
  | l, r, .le  => l.le r
  | l, r, .gt  => l.gt r
  | l, r, .ge  => l.ge r
  | l, r, .eq  => l.eq r
  | l, r, .ne  => l.ne r

def NEList.unfoldStrings (l : NEList String) : String :=
  l.foldl (init := "") $ fun acc a => acc ++ s!" {a}" |>.trimLeft

mutual

  partial def unfoldExpressions (es : NEList Expression) : String :=
    (es.map exprToString).unfoldStrings

  partial def exprToString : Expression → String
    | .var  n    => n
    | .lit  l    => l.toString
    | .list l    => toString $ l.map Literal.toString
    | .lam  _    => "«function»"
    | .app  e es => s!"({exprToString e} {unfoldExpressions es})"
    | .unOp  .not e   => s!"!{exprToString e}"
    | .binOp .add l r => s!"({exprToString l} + {exprToString r})"
    | .binOp .mul l r => s!"({exprToString l} * {exprToString r})"
    | .binOp .eq  l r => s!"({exprToString l} = {exprToString r})"
    | .binOp .ne  l r => s!"({exprToString l} != {exprToString r})"
    | .binOp .lt  l r => s!"({exprToString l} < {exprToString r})"
    | .binOp .le  l r => s!"({exprToString l} <= {exprToString r})"
    | .binOp .gt  l r => s!"({exprToString l} > {exprToString r})"
    | .binOp .ge  l r => s!"({exprToString l} >= {exprToString r})"

end

instance : ToString Expression := ⟨exprToString⟩

def valToString : Value → String
    | .nil    => "«nil»"
    | .lit  l => l.toString
    | .list l => toString $ l.map Literal.toString
    | .lam  _ => "«function»"

instance : ToString Value := ⟨valToString⟩

def consume (p : Program) :
    NEList String → NEList Expression →
      Option ((Option (NEList String)) × Program)
  | .cons n ns, .cons e es => consume (.seq (.decl n (.eval e)) p) ns es
  | .cons n ns, .uno  e    => some (some ns, .seq (.decl n (.eval e)) p)
  | .uno  n,    .uno  e    => some (none, .seq (.decl n (.eval e)) p)
  | .uno  _,    .cons ..   => none

theorem noDupOfConsumeNoDup
  (h : ns.noDup) (h' : consume p' ns es = some (some l, p)) :
    l.noDup = true := by
  induction ns generalizing p' es with
  | uno  _      => cases es <;> cases h'
  | cons _ _ hi =>
    simp [NEList.noDup] at h
    cases es with
    | uno  _   => simp [consume] at h'; simp only [h.2, ← h'.1]
    | cons _ _ => exact hi h.2 h'

inductive Continuation
  | exit   : Continuation
  | seq    : Program → Continuation → Continuation
  | decl   : String → Continuation → Continuation
  | fork   : Expression → Program → Program → Continuation → Continuation
  | loop   : Expression → Program → Continuation → Continuation
  | unOp   : UnOp → Expression → Continuation → Continuation
  | binOp₁ : BinOp → Expression → Continuation → Continuation
  | binOp₂ : BinOp → Value → Continuation → Continuation
  | app    : Expression → NEList Expression → Continuation → Continuation
  | block  : Context → Continuation → Continuation
  | print  : Continuation → Continuation

inductive State
  | ret   : Value      → Context → Continuation → State
  | prog  : Program    → Context → Continuation → State
  | expr  : Expression → Context → Continuation → State
  | error : ErrorType  → Context → String → State
  | done  : Value      → Context → State

def cantEvalAsBool (e : Expression) (v : Value) : String :=
  s!"I can't evaluate '{e}' as a 'bool' because it reduces to '{v}', of " ++
    s!"type '{v.typeStr}'"

def notFound (n : String) : String :=
  s!"I can't find the definition of '{n}'"

def notAFunction (e : Expression) (v : Value) : String :=
  s!"I can't apply arguments to '{e}' because it evaluates to '{v}', of " ++
    s!"type '{v.typeStr}'"

def wrongNParameters (e : Expression) (allowed provided : Nat) : String :=
  s!"I can't apply {provided} arguments to '{e}' because the maximum " ++
    s!"allowed is {allowed}"

def NEList.length : NEList α → Nat
  | uno  _   => 1
  | cons _ l => 1 + l.length

def State.step : State → State
  | prog .skip c k => ret .nil c k
  | prog (.eval e) c k => expr e c k
  | prog (.seq p₁ p₂) c k => prog p₁ c (.seq p₂ k)
  | prog (.decl n p) c k => prog p c $ .block c (.decl n k)
  | prog (.fork e pT pF) c k => expr e c (.fork e pT pF k)
  | prog (.loop e p) c k => expr e c (.loop e p k)
  | prog (.print e) c k => expr e c (.print k)

  | expr (.lit l) c k => ret (.lit l) c k
  | expr (.list l) c k => ret (.list l) c k
  | expr (.var n) c k => match c[n] with
    | none   => error .name c $ notFound n
    | some v => ret v c k
  | expr (.lam l) c k => ret (.lam l) c k
  | expr (.app e es) c k => expr e c (.app e es k)
  | expr (.unOp o e) c k => expr e c (.unOp o e k)
  | expr (.binOp o e₁ e₂) c k => expr e₁ c (.binOp₁ o e₂ k)

  | ret v c .exit => done v c
  | ret v c (.print k) => dbg_trace v; ret .nil c k
  | ret _ c (.seq p k) => prog p c k

  | ret v _ (.block c k) => ret v c k

  | ret v c (.app e es k) => match v with
    | .lam $ .mk ns h p => match h' : consume p ns es with
      | some (some l, p) =>
        ret (.lam $ .mk l (noDupOfConsumeNoDup h h') p) c k
      | some (none, p) => prog p c (.block c k)
      | none => error .runTime c $ wrongNParameters e ns.length es.length
    | v                 => error .type c $ notAFunction e v

  | ret (.lit $ .bool true)  c (.fork _ pT _ k) => prog pT c k
  | ret (.lit $ .bool false) c (.fork _ _ pF k) => prog pF c k
  | ret v c (.fork e ..) => error .type c $ cantEvalAsBool e v

  | ret (.lit $ .bool true) c (.loop e p k) => prog (.seq p (.loop e p)) c k
  | ret (.lit $ .bool false) c (.loop _ _ k) => ret .nil c k
  | ret v c (.loop e ..) => error .type c $ cantEvalAsBool e v

  | ret v c (.decl n k) => ret .nil (c.insert n v) k

  | ret v c (.unOp o e k) => match v.unOp o with
    | .error m => error .type c m
    | .ok    v => ret v c k
  | ret v₁ c (.binOp₁ o e₂ k) => expr e₂ c (.binOp₂ o v₁ k)
  | ret v₂ c (.binOp₂ o v₁ k) => match v₁.binOp v₂ o with
    | .error m => error .type c m
    | .ok    v => ret v c k

  | s@(error ..) => s
  | s@(done ..)  => s

def State.isProg : State → Bool
  | prog .. => true
  | _       => false

def State.isEnd : State → Bool
  | done  .. => true
  | error .. => true
  | _        => false

def State.stepN : State → Nat → State
  | s, 0     => s
  | s, n + 1 => s.step.stepN n

notation s "^" "[" n "]" => State.stepN s n

theorem State.retProgression :
    ∃ n, (ret v c k^[n]).isEnd ∨ (ret v c k^[n]).isProg := by
  induction k generalizing v c with
  | app e es k hi =>
    cases v with
    | lam lm =>
      cases lm with
      | mk ns h p =>
        exists 1
        simp [stepN, step] -- doesn't seem to use `
        split
        next l p' h' => simp!; sorry
        next => simp!
        next => simp!
    | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
  | _ => sorry

#check @State.step.match_2.eq_1
#check @State.step.match_2.eq_2
#check @State.step.match_2.eq_3
#check @State.step.match_2.splitter


#exit

import Structure.Generic.Axioms

open GeneralizedRelation

set_option autoBoundImplicitLocal false

universes u v w

@[reducible] def mapOperation {α : Sort u} {β : Sort v} (op : α → α → β) {ω : Sort w} (m : ω → α) :
  ω → ω → β :=
λ a b => op (m a) (m b)

namespace GeneralizedProperty

  variable {α : Sort u} {V : Universe} (P : GeneralizedProperty α V)
           {ω : Sort w} (m : ω → α)

  instance mapInst [h : HasInst P] : HasInst (P ∘ m) := ⟨λ a => h.inst (m a)⟩

end GeneralizedProperty

namespace GeneralizedRelation

  variable {α : Sort u} {V : Universe} (R : GeneralizedRelation α V)

  section Mapping

    variable {ω : Sort w} (m : ω → α)

    instance mapRefl  [h : HasRefl  R] : HasRefl  (mapOperation R m) := ⟨λ a => h.refl (m a)⟩

    variable [HasInternalFunctors V]

    instance mapSymm  [h : HasSymm  R] : HasSymm  (mapOperation R m) := ⟨h.symm⟩
    instance mapTrans [h : HasTrans R] : HasTrans (mapOperation R m) := ⟨h.trans⟩

    instance mapPreorder    [IsPreorder    R] : IsPreorder    (mapOperation R m) := ⟨⟩
    instance mapEquivalence [IsEquivalence R] : IsEquivalence (mapOperation R m) := ⟨⟩

  end Mapping

  section Identity

    @[simp] theorem mapRefl.id  [h : HasRefl  R] : mapRefl  R id = h := match h with | ⟨_⟩ => rfl

    variable [HasInternalFunctors V]

    @[simp] theorem mapSymm.id  [h : HasSymm  R] : mapSymm  R id = h := match h with | ⟨_⟩ => rfl
    @[simp] theorem mapTrans.id [h : HasTrans R] : mapTrans R id = h := match h with | ⟨_⟩ => rfl

    @[simp] theorem mapPreorder.id    [h : IsPreorder    R] : mapPreorder    R id = h := match h with | { refl := _, trans := _ } => rfl
    @[simp] theorem mapEquivalence.id [h : IsEquivalence R] : mapEquivalence R id = h := match h with | { refl := _, symm := _, trans := _ } => rfl

  end Identity

end GeneralizedRelation

section Morphisms

  variable {α : Sort u} {V : Universe} [HasInternalFunctors V] [HasInstanceArrows V]
           (R : GeneralizedRelation α V)
           {ω : Sort w} (m : ω → α)

  instance mapComposition  [HasTrans      R] [h : IsCompositionRelation R] :
    IsCompositionRelation (mapOperation R m) :=
  { assocLR  := h.assocLR,
    assocRL  := h.assocRL }

  instance mapMorphisms    [IsPreorder    R] [h : IsMorphismRelation    R] :
    IsMorphismRelation    (mapOperation R m) :=
  { leftId   := h.leftId,
    rightId  := h.rightId }

  instance mapIsomorphisms [IsEquivalence R] [h : IsIsomorphismRelation R] :
    IsIsomorphismRelation (mapOperation R m) :=
  { leftInv  := h.leftInv,
    rightInv := h.rightInv,
    invInv   := h.invInv,
    compInv  := h.compInv,
    idInv    := λ a => h.idInv (m a) }

end Morphisms

section Functors

  variable {α : Sort u} {V W : Universe} [HasInstanceArrows W] [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation α W)
           (F : BaseFunctor R S)
           {ω : Sort w} (m : ω → α)

  instance mapReflFunctor  [HasRefl  R] [HasRefl  S] [h : IsReflFunctor  R S F] :
    IsReflFunctor  (mapOperation R m) (mapOperation S m) F :=
  ⟨λ a => h.respectsRefl (m a)⟩

  variable [HasInternalFunctors V] [HasInternalFunctors W]

  instance mapSymmFunctor  [HasSymm  R] [HasSymm  S] [h : IsSymmFunctor  R S F] :
    IsSymmFunctor  (mapOperation R m) (mapOperation S m) F :=
  ⟨h.respectsSymm⟩

  instance mapTransFunctor [HasTrans R] [HasTrans S] [h : IsTransFunctor R S F] :
    IsTransFunctor (mapOperation R m) (mapOperation S m) F :=
  ⟨h.respectsTrans⟩

  instance mapPreorderFunctor    [IsPreorder    R] [IsPreorder    S] [IsPreorderFunctor    R S F] :
    IsPreorderFunctor    (mapOperation R m) (mapOperation S m) F := ⟨⟩
  instance mapEquivalenceFunctor [IsEquivalence R] [IsEquivalence S] [IsEquivalenceFunctor R S F] :
    IsEquivalenceFunctor (mapOperation R m) (mapOperation S m) F := ⟨⟩

end Functors

section NaturalTransformations

  variable {α : Sort u} {β : Sort v} {V W : Universe} [HasInternalFunctors W] [HasInstanceEquivalences W] [HasExternalFunctors V W]
           (R : GeneralizedRelation α V) (S : GeneralizedRelation β W) [h : HasTrans S]
           {mF mG : α → β} (F : ∀ {a b}, R a b ⟶' S (mF a) (mF b)) (G : ∀ {a b}, R a b ⟶' S (mG a) (mG b))
           (n : ∀ a, S (mF a) (mG a))
           {ω : Sort w} (m : ω → α)

  instance mapNaturality [h : IsNatural R S F G n] :
    IsNatural (mapOperation R m) S F G (λ a => n (m a)) :=
  ⟨h.nat⟩

end NaturalTransformations


/-
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" >> tactic.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,
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 3
{ dsimp,
  simp },
refl
````

See also `id { tac }`, which is equivalent to `work_on_goal 1 { tac }`.
-/
meta def work_on_goal : parse small_nat → itactic → tactic unit
| 0 t := fail "work_on_goal failed: goals are 1-indexed"
| (n+1) 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.

`classical!` does this more aggressively, such that even if a decidable instance is already
available for a specific proposition, the noncomputable one will be used instead. -/
meta def classical (bang : parse $ (tk "!")?) :=
tactic.classical bang.is_some

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]
noncomputable
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"

/--
`guard_hyp_mod_implicit h : t` fails if the type of the hypothesis `h`
is not definitionally equal to `t` modulo none transparency
(i.e., unifying the implicit arguments modulo semireducible transparency).
We use this tactic for writing tests.
-/
meta def guard_hyp_mod_implicit (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit := do
h ← get_local n >>= infer_type >>= instantiate_mvars,
e ← to_expr p,
is_def_eq h e transparency.none

/--
`guard_target_mod_implicit t` fails if the target of the main goal
is not definitionally equal to `t` modulo none transparency
(i.e., unifying the implicit arguments modulo semireducible transparency).
We use this tactic for writing tests.
-/
meta def guard_target_mod_implicit (p : parse texpr) : tactic unit := do
tgt ← target,
e ← to_expr p,
is_def_eq tgt e transparency.none

/-- 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 with attrs n` applies the list of lemmas `hs` and all lemmas tagged with an
attribute from the list `attrs`, as well as the `assumption` tactic 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.)

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 with mono_rules
by apply_rules [add_le_add] with mono_rules
```
-/
meta def apply_rules (args : parse opt_pexpr_list) (attrs : parse with_ident_list)
  (n : nat := 50) (opt : apply_cfg := {}) :
  tactic unit :=
tactic.apply_rules args attrs 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)) :=
(tk "with" *> ((λ arrow h, (option.is_some arrow, h)) <$> (tk "<-")? <*> ident))?

/--
`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 $ let t := tp.get_or_else pexpr.mk_placeholder in ``(%%t : Sort*),
   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 $ (tk "!" *> pure tt) <|> 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 morphisms.isomorphism
import algebraic_geometry.pullback_carrier

open opposite category_theory category_theory.limits topological_space

noncomputable theory

namespace algebraic_geometry

lemma injective_of_surjective_diagonal {X Y : Scheme} (f : X ⟶ Y)
  (h : function.surjective (pullback.diagonal f).1.base) : function.injective f.1.base :=
begin
  intros x y e,
  let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
  obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
  obtain ⟨z', rfl⟩ := h z,
  simp only [← Scheme.comp_val_base_apply, pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
  exact hz.symm.trans hz'
end

lemma surjective_diagonal_of_universally_injective {X Y : Scheme} (f : X ⟶ Y)
  (h : function.surjective (pullback.diagonal f).1.base) : function.injective f.1.base :=
begin
  intros x y e,
  let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
  obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
  obtain ⟨z', rfl⟩ := h z,
  simp only [← Scheme.comp_val_base_apply, pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
  exact hz.symm.trans hz'
end

lemma injective_of_mono {X Y : Scheme} (f : X ⟶ Y) [mono f] :
  function.injective f.1.base :=
begin
  apply injective_of_surjective_diagonal,
  exact (as_iso $ (Scheme.forget_to_Top ⋙ forget Top).map
    (pullback.diagonal f)).to_equiv.surjective,
end

-- move me
lemma mono_eq_diagonal :
  @mono Scheme _ = morphism_property.diagonal (@is_iso Scheme _) :=
begin
  ext X Y f,
  split,
  { introI _, show is_iso _, apply_instance },
  { rintro (H : is_iso _),
    resetI,
  haveI : is_iso (pullback.fst : pullback f f ⟶ X),
  { rw (is_iso.inv_eq_of_hom_inv_id (pullback.diagonal_fst f)).symm, apply_instance },
  exact is_kernel_pair.mono_of_is_iso_fst (is_pullback.of_has_pullback f f) }
end

lemma mono_is_local_at_target :
  property_is_local_at_target (@mono _ _) :=
begin
  rw mono_eq_diagonal,
  exact is_iso_is_local_at_target.diagonal
end

end algebraic_geometry


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

theorem ex1 : foo! 10 = 9 := rfl

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

theorem ex2 : foo! 10 = 11 := rfl

macro (priority := low) "foo! " x:term:max : term => `($x * 2)

theorem ex3 : foo! 10 = 11 := rfl

macro (priority := high+1) "foo! " x:term:max : term => `($x * 2)

theorem ex4 : foo! 10 = 20 := rfl

macro (priority := high+4-2) "foo! " x:term:max : term => `($x * 3)

theorem ex5 : foo! 10 = 30 := rfl


import Lean
import Lean.Elab.Command
import Lean.Elab.Tactic.Basic
import Mathlib.Lean.Expr
import Lean.Meta
import AssertCmd

open Lean Elab Elab.Tactic

-- #print mkIdent

-- #reduce Parser.Term.quot

def doWork : Command.CommandElabM Unit := do
  for i in [0:256] do    -- stxs := stxs.push $
    -- let name := Syntax.mkNameLit s!"name{i}"
    Command.elabCommand (← `(theorem $(mkIdent s!"number{i}_lt") : $(quote i) < 256 := by simp ))
    Command.elabCommand (← `(def $(mkIdent s!"number{i}") : UInt8 := ⟨ $(quote i), $(mkIdent s!"number{i}_lt") ⟩ ))
    -- Command.elabCommand (← `(theorem $(quote name) : $i < 256 := by simp))
    pure ()

  let mut matchArms : Array Syntax := #[]
  for i in [0:256] do    -- stxs := stxs.push $
      -- let name := Syntax.mkNameLit s!"name{i}"
      matchArms := matchArms.push (← `(Parser.Term.matchAltExpr| | $(quote i) => $(mkIdent s!"number{i}")))
      -- Command.elabCommand (← `(theorem $(quote name) : $i < 256 := by simp))
      pure ()

  matchArms := matchArms.push (← `(Parser.Term.matchAltExpr| | n => ⟨ 0, by simp⟩ ))

  let dfn ← `(def $(mkIdent "fofNat") (n : Nat) : UInt8 := match n % 256 with $matchArms:matchAlt*)
  Command.elabCommand dfn

-- constant a : 4 < 5 := by simp

--   pure ()

syntax (name := genTest) "gen_uint_helper_theorems" : command
@[commandElab genTest]
unsafe def elabAssert : Command.CommandElab
  | _ => do doWork

-- set_option maxHeartbeats 500000
-- gen_uint_helper_theorems

-- def fofNat : Nat -> UInt8
-- | n => UInt8.ofNat n

-- -- opaque mod_lt_o (x : Nat) {y : Nat} : y > 0 → x % y < y := Nat.mod_lt
-- @[irreducible]
-- def tofNat (a : Nat) : UInt8 :=
--   ⟨a % 256, let x := Nat.mod_lt a (Nat.zero_lt_succ 255); x⟩

-- local instance : OfNat UInt8 n where
--   ofNat := match n with
--   | 0 => ⟨ 0, name0⟩
--   | 1 => ⟨ 1, name1⟩
--   | _ => UInt8.ofNat n

-- set_option maxRecDepth 10000
-- set_option pp.all true

@[inline]
def hexChar (c: Char): Option Nat :=
  if '0' ≤ c ∧ c ≤ '9' then
    some $ c.val.toNat - '0'.val.toNat
  else if 'a' ≤ c ∧ c ≤ 'f' then
    some $ c.val.toNat - 'a'.val.toNat + 10
  else if 'A' ≤ c ∧ c ≤ 'F' then
    some $ c.val.toNat - 'A'.val.toNat + 10
  else
    none

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

def hexToByteArray!(s: String): ByteArray := Id.run do
  if s.length % 2 != 0 then return ByteArray.empty
  let mut res := ByteArray.mkEmpty $ s.length / 2
  for i in [:((s.length)/2)] do
    let v1 := match hexChar (s[2*i]) with | Option.none => panic! "Bad hex" | Option.some x => x
    let v2 := match hexChar (s[2*i+1]) with | Option.none => panic! "Bad hex" | Option.some x => x
    let val := (16 * v1) + v2
    -- res := res.push $ UInt8.ofNat val
    res := res.push $ ⟨ val, sorry ⟩
  return res

def hexToByteList!(s: String): List UInt8 := Id.run do
  if s.length % 2 != 0 then return []
  let mut res : List UInt8 := []
  for i in [:((s.length)/2)] do
    let v1 := match hexChar (s[2*i]) with | Option.none => panic! "Bad hex" | Option.some x => x
    let v2 := match hexChar (s[2*i+1]) with | Option.none => panic! "Bad hex" | Option.some x => x
    let val := (16 * v1) + v2
    -- res := res.push $ UInt8.ofNat val
    res := List.cons ⟨ val, sorry ⟩ res
  return res.reverse

def ByteArray.mkZeros (n:Nat) := Id.run do
  let mut b := ByteArray.mkEmpty n
  for i in [0:n] do
    b := b.push 0
  b

def byteArrayToHex(b: ByteArray) : String :=
  let parts := b.data.map (fun x => String.singleton (Nat.digitChar (x.toNat / 16)) ++ String.singleton (Nat.digitChar (x.toNat % 16)))
  String.join parts.toList

syntax "b[" sepBy(term, ", ") "]" : term
macro_rules
  | `(b[ $elems,* ]) => `(ByteArray.mk #[ $elems,* ])

-- syntax (name := redComp) "#redComp" : command
@[commandParser] def redComp := leading_parser "#redComp " >> Lean.Parser.termParser

@[commandElab redComp]
def elabRedComp : Command.CommandElab
  | `(#redComp%$tk $term) => withoutModifyingEnv <| Command.runTermElabM (some `_check) fun _ => do
    let e ← Term.elabTerm term none
    Term.synthesizeSyntheticMVarsNoPostponing
    let (e, _) ← Term.levelMVarToParam (← Meta.instantiateMVars e)
    -- TODO: add options or notation for setting the following parameters
    withTheReader Core.Context (fun ctx => { ctx with options := ctx.options.setBool `smartUnfolding true }) do
      let e ← Meta.withTransparency (mode := Meta.TransparencyMode.default) <| Meta.reduce e (skipProofs := true) (skipTypes := false)
      logInfoAt tk e
  | _ => throwUnsupportedSyntax

@[commandParser] def red' := leading_parser "#reduce' " >> Lean.Parser.termParser
@[commandElab red']
def elabRed' : Command.CommandElab
  | `(#reduce'%$tk $term) => withoutModifyingEnv <| Command.runTermElabM (some `_check) fun _ => do
    let e ← Term.elabTerm term none
    Term.synthesizeSyntheticMVarsNoPostponing
    let (e, _) ← Term.levelMVarToParam (← Meta.instantiateMVars e)
    -- TODO: add options or notation for setting the following parameters
    withTheReader Core.Context (fun ctx => { ctx with options := ctx.options.setBool `smartUnfolding true }) do
      let e ← Meta.withTransparency (mode := Meta.TransparencyMode.default) <| Meta.reduce e (skipProofs := false) (skipTypes := false)
      logInfoAt tk e
  | _ => throwUnsupportedSyntax

@[commandParser] def redDontPrint := leading_parser "#redDontPrint " >> Lean.Parser.termParser
@[commandElab redDontPrint]
def elabRedDontPrint : Command.CommandElab
  | `(#redDontPrint%$tk $term) => withoutModifyingEnv <| Command.runTermElabM (some `_check) fun _ => do
    let e ← Term.elabTerm term none
    Term.synthesizeSyntheticMVarsNoPostponing
    let (e, _) ← Term.levelMVarToParam (← Meta.instantiateMVars e)
    -- TODO: add options or notation for setting the following parameters
    withTheReader Core.Context (fun ctx => { ctx with options := ctx.options.setBool `smartUnfolding true }) do
      let e ← Meta.withTransparency (mode := Meta.TransparencyMode.default) <| Meta.reduce e (skipProofs := false) (skipTypes := false)
      -- logInfoAt tk e
  | _ => throwUnsupportedSyntax

-- #print Lean.Parser.Command.reduce
-- #reduce (⟨5, sorry⟩ : UInt8)
-- #reduce (5 : UInt8)

-- #reduce String.foldr

-- let rec loop (i : Pos) (a : α) :=
--     if i == stopPos then a
--     else loop (s.next i) (f a (s.get i))
--   loop i a

theorem termination (t: String) (i: String.Pos) : String.length t - String.next t i < String.length t - i := by admit
  -- simp [Nat.le_of_add_le_add_right, Nat.lt_of_succ_le]
  -- simp [String.length, String.next, String.get, String.csize]

@[specialize] private def loop [Monad m] (d: σ) (t: String) (i : String.Pos) (f : Char → σ → m (ForInStep σ)) : m σ := do
    if i == t.length then pure d else
    match (← f (t.get i) d) with
      | ForInStep.done d  => pure d
      | ForInStep.yield d => loop d t (t.next i) f
termination_by _ t i _ => (t.length - i)
decreasing_by apply termination

@[inline] private def forIn [Monad m] (t : String) (init : σ) (f : Char → σ → m (ForInStep σ)) : m σ :=
  loop init t 0 f

instance : ForIn m String Char where
  forIn := forIn

-- #redComp fofNat 5
def hexToByteArray'(s: String): Option ByteArray := Id.run do
  if s.length % 2 != 0 then return none
  let mut res := ByteArray.mkEmpty $ s.length / 2
  let mut mem : Option UInt8 := Option.none
  -- s.foldl
  for c in s do
    let Option.some r := hexChar c | return none
    (res, mem) := match mem with
    | none => (res, Option.some ⟨ r , sorry ⟩ )
    | some r2 => (res.push $ (16 * (⟨ r , sorry ⟩ : UInt8) ) + r2, Option.none)
    pure ()
  return res

def hexToByteArray!'_aux (l: List Char) (r: ByteArray) : ByteArray := match l with
| List.cons v1 (List.cons v2 l) => match hexChar v1 with
  | none => panic! "Asdf"
  | some v1 => match hexChar v2 with
    | none => panic! "asdf"
    | some v2 =>
      (hexToByteArray!'_aux l r).push ⟨ 16 * v1 + v2 , sorry ⟩
| List.nil => r
| _ => panic! "wrong size"

def hexToByteArray!' (s: String) :=
  let d := hexToByteArray!'_aux s.data ByteArray.empty
  ByteArray.mk (d.data.reverse)

def hexToByteList!'_aux (l: List Char) (r: List UInt8) : List UInt8 := match l with
| List.cons v1 (List.cons v2 l) => match hexChar v1 with
  | none => panic! "Asdf"
  | some v1 => match hexChar v2 with
    | none => panic! "asdf"
    | some v2 =>
      List.cons ⟨ 16 * v1 + v2 , sorry ⟩ (hexToByteList!'_aux l r)
| List.nil => r
| _ => panic! "wrong size"

def hexToByteList!' (s: String) :=
  let d := hexToByteList!'_aux s.data []
  d

#assert (hexToByteList! "deadbeef00") == (hexToByteList!' "deadbeef00")
-- def hexToByteArray''(s: String): Option ByteArray :=
--   let fn (st : (Option UInt8 × ))
-- s.foldl

-- #print hexToByteArray'

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

-- set_option pp.all true
-- #reduce (5: UInt8)

-- -- private def throwFailedToEval (e : Expr) : MetaM α :=
-- --   throwError "reduceEval: failed to evaluate argument{indentExpr e}"

-- -- instance : Meta.ReduceEval UInt8 where
-- --   reduceEval e := do
-- --     let e ← Meta.whnf e
-- --     let Expr.const c .. ← pure e.getAppFn | throwFailedToEval e
-- --     let nargs := e.getAppNumArgs
-- --     if      c == `UInt8.mk && nargs == 0 then pure none
-- --     else if c == `Option.some && nargs == 1 then some <$> reduceEval e.appArg!
-- --     else throwFailedToEval e

-- #reduce fofNat 5

-- def basicInput := hexToByteArray "604260005260206000F3"
-- -- -- #reduce (22 : UInt8)
-- -- -- set_option maxHeartbeats 200000
-- -- -- #reduce basicInput

-- -- -- #reduce basicInput

-- -- def basicSolcInput := hexToByteArray! "6080604052348015600f57600080fd5b5060405160e338038060e38339818101604052810190602d9190604c565b80600081905550506097565b6000815190506046816083565b92915050565b600060208284031215605f57605e607e565b5b6000606b848285016039565b91505092915050565b6000819050919050565b600080fd5b608a816074565b8114609457600080fd5b50565b603f8060a46000396000f3fe6080604052600080fdfea26469706673582212209c130309b4505633bae9459145bea0f6138a99c38947f11384f39beca020bc9a64736f6c63430008070033"

-- def basicInlined : ByteArray := {data := #[96, 128, 96, 64, 82, 52, 128, 21, 96, 15, 87, 96, 0, 128, 253, 91, 80, 96, 64, 81, 96,
-- 227, 56, 3, 128, 96, 227, 131, 57, 129, 129, 1, 96, 64, 82, 129, 1, 144,
-- 96, 45, 145, 144, 96, 76, 86, 91, 128, 96, 0, 129, 144, 85, 80, 80, 96, 151, 86, 91, 96, 0, 129, 81, 144, 80, 96, 70, 129, 96,
-- 131, 86, 91, 146, 145, 80, 80, 86, 91, 96, 0, 96, 32, 130, 132, 3, 18, 21, 96, 95, 87, 96, 94, 96, 126, 86, 91, 91, 96, 0, 96,
-- 107, 132, 130, 133, 1, 96, 57, 86, 91, 145, 80, 80, 146, 145, 80, 80, 86, 91, 96, 0, 129, 144, 80, 145, 144, 80, 86, 91, 96]}
-- --, 0, 128, 253, 91, 96, 138, 129, 96, 116, 86, 91, 129, 20, 96, 148, 87, 96, 0, 128, 253, 91, 80, 86, 91, 96, 63, 128, 96, 164, 96, 0, 57, 96, 0, 243, 254, 96, 128, 96, 64, 82, 96, 0, 128, 253, 254, 162, 100, 105, 112, 102, 115, 88, 34, 18, 32, 156, 19, 3, 9, 180, 80, 86, 51, 186, 233, 69, 145, 69, 190, 160, 246, 19, 138, 153, 195, 137, 71, 241, 19, 132, 243, 155, 236, 160, 32, 188, 154, 100, 115, 111, 108, 99, 67, 0, 8, 7, 0, 51]}

-- -- set_option pp.all true
-- -- #eval basicInlined
-- set_option maxRecDepth 10000

-- #reduce basicInlined[100]

-- #reduce (20 : UInt8)
-- #reduce {data := #[96, 128, 96, 64, 82, 52, 128, 21, 96, 15] : ByteArray}

-- #redComp hexToByteArray!' "aabbccccdd"
-- #redComp basicInput
-- #redComp (1 : UInt8)


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

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

/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

open Expr Tactic

namespace Tactic

namespace Explode

inductive Status : Type
  | reg
  | intro
  | lam
  | sintro
  deriving Inhabited
#align tactic.explode.status Tactic.Explode.Status

/-- A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
unsafe inductive thm : Type
  | expr (e : expr)
  | Name (n : Name)
  | String (s : String)
#align tactic.explode.thm tactic.explode.thm

/-- Turn a thm into a string.
-/
unsafe def thm.to_string : thm → String
  | thm.expr e => e.toString
  | thm.name n => n.toString
  | thm.string s => s
#align tactic.explode.thm.to_string tactic.explode.thm.to_string

unsafe structure entry : Type where
  expr : expr
  line : Nat
  depth : Nat
  Status : Status
  thm : thm
  deps : List Nat
#align tactic.explode.entry tactic.explode.entry

unsafe def pad_right (l : List String) : List String :=
  let n := l.foldl (fun r (s : String) => max r s.length) 0
  l.map fun s => Nat.iterate (fun s => s.push ' ') (n - s.length) s
#align tactic.explode.pad_right tactic.explode.pad_right

unsafe structure entries : Type where mk' ::
  s : expr_map entry
  l : List entry
  deriving Inhabited
#align tactic.explode.entries tactic.explode.entries

unsafe def entries.find (es : entries) (e : expr) : Option entry :=
  es.s.find e
#align tactic.explode.entries.find tactic.explode.entries.find

unsafe def entries.size (es : entries) : ℕ :=
  es.s.size
#align tactic.explode.entries.size tactic.explode.entries.size

unsafe def entries.add : entries → entry → entries
  | es@⟨s, l⟩, e => if s.contains e.expr then es else ⟨s.insert e.expr e, e :: l⟩
#align tactic.explode.entries.add tactic.explode.entries.add

unsafe def entries.head (es : entries) : Option entry :=
  es.l.head?
#align tactic.explode.entries.head tactic.explode.entries.head

unsafe def format_aux : List String → List String → List String → List entry → tactic format
  | line :: lines, dep :: deps, thm :: thms, en :: es => do
    let fmt ←
      do
        let margin := String.join (List.replicate en.depth " │")
        let margin :=
          match en.Status with
          | status.sintro => " ├" ++ margin
          | status.intro => " │" ++ margin ++ " ┌"
          | status.reg => " │" ++ margin ++ ""
          | status.lam => " │" ++ margin ++ ""
        let p ← infer_type en.expr >>= pp
        let lhs := line ++ "│" ++ dep ++ "│ " ++ thm ++ margin ++ " "
        return <| format.of_string lhs ++ (p lhs).group ++ format.line
    (· ++ fmt) <$> format_aux lines deps thms es
  | _, _, _, _ => return format.nil
#align tactic.explode.format_aux tactic.explode.format_aux

unsafe instance : has_to_tactic_format entries :=
  ⟨fun es : entries =>
    let lines := pad_right <| es.l.map fun en => toString en.line
    let deps := pad_right <| es.l.map fun en => String.intercalate "," (en.deps.map toString)
    let thms := pad_right <| es.l.map fun en => (entry.thm en).toString
    format_aux lines deps thms es.l⟩

unsafe def append_dep (filter : expr → tactic Unit) (es : entries) (e : expr) (deps : List Nat) :
    tactic (List Nat) :=
  (do
      let ei ← es.find e
      Filter ei
      return (ei :: deps)) <|>
    return deps
#align tactic.explode.append_dep tactic.explode.append_dep

unsafe def may_be_proof (e : expr) : tactic Bool := do
  let expr.sort u ← infer_type e >>= infer_type
  return <| not u
#align tactic.explode.may_be_proof tactic.explode.may_be_proof

end Explode

open Explode

mutual
  unsafe def explode.core (filter : expr → tactic Unit) :
      expr → Bool → Nat → entries → tactic entries
    | e@(lam n bi d b), si, depth, es => do
      let m ← mk_fresh_name
      let l := local_const m n bi d
      let b' := instantiate_var b l
      if si then
          let en : entry := ⟨l, es, depth, status.sintro, thm.name n, []⟩
          do
          let es' ← explode.core b' si depth (es en)
          return <| es' ⟨e, es', depth, status.lam, thm.string "∀I", [es, es' - 1]⟩
        else do
          let en : entry := ⟨l, es, depth, status.intro, thm.name n, []⟩
          let es' ← explode.core b' si (depth + 1) (es en)
          let deps'
            ←-- in case of a "have" clause, the b' here has an annotation
                explode.append_dep
                Filter es' b' []
          let deps' ← explode.append_dep Filter es' l deps'
          return <| es' ⟨e, es', depth, status.lam, thm.string "∀I", deps'⟩
    | e@(elet n t a b), si, depth, es => explode.core (reduce_lets e) si depth es
    | e@(macro n l), si, depth, es => explode.core l.headI si depth es
    | e, si, depth, es =>
      Filter e >>
        match get_app_fn_args e with
        | (nm@(const n _), args) => explode.args e args depth es (thm.expr nm) []
        | (fn, []) => do
          let en : entry := ⟨fn, es.size, depth, Status.reg, thm.expr fn, []⟩
          return (es en)
        | (fn, args) => do
          let es' ← explode.core fn false depth es
          let deps
            ←-- in case of a "have" clause, the fn here has an annotation
                explode.append_dep
                Filter es' fn.erase_annotations []
          explode.args e args depth es' (thm.string "∀E") deps
  unsafe def explode.args (filter : expr → tactic Unit) :
      expr → List expr → Nat → entries → thm → List Nat → tactic entries
    | e, arg :: args, depth, es, thm, deps => do
      let es' ← explode.core arg false depth es <|> return es
      let deps' ← explode.append_dep Filter es' arg deps
      explode.args e args depth es' thm deps'
    | e, [], depth, es, thm, deps =>
      return (es.add ⟨e, es.size, depth, Status.reg, thm, deps.reverse⟩)
end
#align tactic.explode.core tactic.explode.core
#align tactic.explode.args tactic.explode.args

unsafe def explode_expr (e : expr) (hide_non_prop := true) : tactic entries :=
  let filter := if hide_non_prop then fun e => may_be_proof e >>= guardb else fun _ => skip
  tactic.explode.core Filter e true 0 default
#align tactic.explode_expr tactic.explode_expr

unsafe def explode (n : Name) : tactic Unit := do
  let const n _ ← resolve_name n |
    fail "cannot resolve name"
  let d ← get_decl n
  let v ←
    match d with
      | declaration.defn _ _ _ v _ _ => return v
      | declaration.thm _ _ _ v => return v.get
      | _ => fail "not a definition"
  let t ← pp d.type
  explode_expr v <* trace (to_fmt n ++ " : " ++ t) >>= trace
#align tactic.explode tactic.explode

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/
@[user_command]
unsafe def explode_cmd (_ : parse <| tk "#explode") : parser Unit := do
  let n ← ident
  explode n
#align tactic.explode_cmd tactic.explode_cmd

add_tactic_doc
  { Name := "#explode / #explode_widget"
    category := DocCategory.cmd
    declNames := [`tactic.explode_cmd, `tactic.explode_widget_cmd]
    inheritDescriptionFrom := `tactic.explode_cmd
    tags := ["proof display", "widgets"] }

end Tactic


open tactic
open interactive
open lean.parser
open interactive.types expr
open expr interactive.types

local postfix `?`:9001 := optional

meta def propagate_tags (tac : tactic unit) : tactic unit :=
do tag ← get_main_tag,
   if tag = [] then tac
   else focus1 $ do
     tac,
     gs ← get_goals,
     when (bnot gs.empty) $ do
       new_tag ← get_main_tag,
       when new_tag.empty $ with_enable_tags (set_main_tag tag)

meta def simp_core_aux (cfg : simp_config) (discharger : tactic unit) (s : simp_lemmas) (u : list name) (hs : list expr) (tgt : bool) : tactic unit :=
do to_remove ← hs.mfilter $ λ h, do {
         h_type ← infer_type h,
         (do (new_h_type, pr) ← simplify s u h_type cfg `eq discharger,
             assert h.local_pp_name new_h_type,
             mk_eq_mp pr h >>= tactic.exact >> return tt)
         <|>
         (return ff) },
   goal_simplified ← if tgt then (simp_target s u cfg discharger >> return tt) <|> (return ff) else return ff,
   guard (cfg.fail_if_unchanged = ff ∨ to_remove.length > 0 ∨ goal_simplified) <|> fail "simplify tactic failed to simplify",
   to_remove.mmap' (λ h, try (clear h))

meta def simp_core' (cfg : simp_config) (discharger : tactic unit)
                   (no_dflt : bool) (hs : list simp_arg_type) (attr_names : list name)
                   (locat : loc) : tactic unit :=
match locat with
| loc.wildcard := do (all_hyps, s, u) ← mk_simp_set_core no_dflt attr_names hs tt,
                     trace all_hyps,
                     if all_hyps then tactic.simp_all s u cfg discharger
                     else do hyps ← non_dep_prop_hyps,
                             trace hyps,
                             simp_core_aux cfg discharger s u hyps tt
| _            := do (s, u) ← mk_simp_set no_dflt attr_names hs,
                     ns ← locat.get_locals,
                     simp_core_aux cfg discharger s u ns locat.include_goal
end
>> try tactic.triv >> try (tactic.reflexivity reducible)

namespace tactic.interactive
meta def simp' (use_iota_eqn : parse $ (tk "!")?) (no_dflt : parse only_flag) (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
              (locat : parse location) (cfg : simp_config_ext := {}) : tactic unit :=
let cfg := if use_iota_eqn.is_none then cfg else {iota_eqn := tt, ..cfg} in
propagate_tags (simp_core' cfg.to_simp_config cfg.discharger no_dflt hs attr_names locat)
end tactic.interactive

lemma foo (p : ite (tt = ff) unit empty) : false :=
begin
simp_all,
simp' at *, -- FIXME this works, but `simp at *` doesn't
induction p
end


import tactic.lint
import algebra.ring.basic

open tactic

def foo1 (n m : ℕ) : ℕ := n + 1
def foo2 (n m : ℕ) : m = m := by refl
noncomputable lemma foo3 (n m : ℕ) : ℕ := n - m
lemma foo.foo (n m : ℕ) : n ≥ n := le_refl n
instance bar.bar : has_add ℕ := by apply_instance  -- we don't check the name of instances
lemma foo.bar (ε > 0) : ε = ε := rfl -- >/≥ is allowed in binders (and in fact, in all hypotheses)
/-- Test exception in `def_lemma` linter. -/
@[pattern] def my_exists_intro := @Exists.intro

meta def fold_over_with_cond {α} (l : list declaration) (tac : declaration → tactic (option α)) :
  tactic (list (declaration × α)) :=
l.mmap_filter $ λ d, option.map (λ x, (d, x)) <$> tac d

run_cmd do
  let t := name × list ℕ,
  e ← get_env,
  let l := e.filter (λ d, e.in_current_file d.to_name ∧ ¬ d.is_auto_or_internal e),
  l2 ← fold_over_with_cond l (return ∘ check_unused_arguments),
  guard (l2.length = 4) <|> fail "wrong length",
  let l2 : list (name × list ℕ) := l2.map (λ x, ⟨x.1.to_name, x.2⟩),
  guard ((⟨`foo1, [2]⟩ : t) ∈ l2) <|> fail "foo1",
  guard ((⟨`foo2, [1]⟩ : t) ∈ l2) <|> fail "foo2",
  guard ((⟨`foo.foo, [2]⟩ : t) ∈ l2) <|> fail "foofoo",
  guard ((⟨`foo.bar, [2]⟩ : t) ∈ l2) <|> fail "foobar",
  l2 ← fold_over_with_cond l linter.def_lemma.test,
  guard $ l2.length = 2,
  let l2 : list (name × _) := l2.map $ λ x, ⟨x.1.to_name, x.2⟩,
  guard $ ∃(x ∈ l2), (x : name × _).1 = `foo2,
  guard $ ∃(x ∈ l2), (x : name × _).1 = `foo3,
  l3 ← fold_over_with_cond l linter.dup_namespace.test,
  guard $ l3.length = 1,
  guard $ ∃(x ∈ l3), (x : declaration × _).1.to_name = `foo.foo,
  l4 ← fold_over_with_cond l linter.ge_or_gt.test,
  guard $ l4.length = 1,
  guard $ ∃(x ∈ l4), (x : declaration × _).1.to_name = `foo.foo,
  -- guard $ ∃(x ∈ l4), (x : declaration × _).1.to_name = `foo4,
  (_, s) ← lint ff,
  guard $ "/- (slow tests skipped) -/\n".is_suffix_of s.to_string,
  (_, s2) ← lint tt,
  guard $ s.to_string ≠ s2.to_string,
  skip

/- check customizability and nolint -/

meta def dummy_check (d : declaration) : tactic (option string) :=
return $ if d.to_name.last = "foo" then some "gotcha!" else none

meta def linter.dummy_linter : linter :=
{ test := dummy_check,
  auto_decls := ff,
  no_errors_found := "found nothing.",
  errors_found := "found something:" }

@[nolint dummy_linter]
def bar.foo : (if 3 = 3 then 1 else 2) = 1 := if_pos (by refl)

run_cmd do
  (_, s) ← lint tt lint_verbosity.medium [`linter.dummy_linter] tt,
  guard $ "/- found something: -/\n#check @foo.foo /- gotcha! -/\n".is_suffix_of s.to_string

def incorrect_type_class_argument_test {α : Type} (x : α) [x = x] [decidable_eq α] [group α] :
  unit := ()

run_cmd do
  d ← get_decl `incorrect_type_class_argument_test,
  x ← linter.incorrect_type_class_argument.test d,
  guard $ x = some "These are not classes. argument 3: [_inst_1 : x = x]"

section
def impossible_instance_test {α β : Type} [add_group α] : has_add α := infer_instance
local attribute [instance] impossible_instance_test
run_cmd do
  d ← get_decl `impossible_instance_test,
  x ← linter.impossible_instance.test d,
  guard $ x = some "Impossible to infer argument 2: {β : Type}"

def dangerous_instance_test {α β γ : Type} [ring α] [add_comm_group β] [has_coe α β]
  [has_inv γ] : has_add β := infer_instance
local attribute [instance] dangerous_instance_test
run_cmd do
  d ← get_decl `dangerous_instance_test,
  x ← linter.dangerous_instance.test d,
  guard $ x = some
    "The following arguments become metavariables. argument 1: {α : Type}, argument 3: {γ : Type}"
end

section
def foo_has_mul {α} [has_mul α] : has_mul α := infer_instance
local attribute [instance, priority 1] foo_has_mul
run_cmd do
  d ← get_decl `foo_has_mul,
  some s ← fails_quickly 20 d,
  guard $ "type-class inference timed out".is_prefix_of s
local attribute [instance, priority 10000] foo_has_mul
run_cmd do
  d ← get_decl `foo_has_mul,
  some s ← fails_quickly 3000 d,
  guard $ "maximum class-instance resolution depth has been reached".is_prefix_of s
end

instance beta_redex_test {α} [monoid α] : (λ (X : Type), has_mul X) α := ⟨(*)⟩
run_cmd do
  d ← get_decl `beta_redex_test,
  x ← linter.instance_priority.test d,
  guard $ x = some "set priority below 1000"

/- Test exception in `def_lemma` linter. -/
run_cmd do
  d ← get_decl `my_exists_intro,
  t ← linter.def_lemma.test d,
  guard $ t = none


example : n.succ = 1 → n = 0 := by
  intros h; injection h

example (h : n.succ = 1) : n = 0 := by
  injection h

opaque T : Type
opaque T.Pred : T → T → Prop

example {ρ} (hρ : ρ.Pred σ) : T.Pred ρ ρ := sorry


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

import category_theory.category
import pseudoelements
import tactic.combinators
import tactic.chase_tactic

open category_theory
open category_theory.abelian
open category_theory.abelian.pseudoelements
open tactic

namespace tactic.chase

section lemmas
universes v u
variables {C : Type u} [𝒞 : category.{v} C] [abelian.{v} C]
include 𝒞

local attribute [instance] object_to_sort
local attribute [instance] hom_to_fun

lemma pseudo_congr {X Y : C} {f g : X ⟶ Y} (h : f = g) (x : X) : f x = g x :=
by rw h

end lemmas

meta def try_apply_comm_lemma_at_aux (l : commutativity_lemma) :
  ℕ → diagram_term → option (diagram_term)
| 0 ⟨ms, elem⟩ :=
  match list.is_prefix_of l.lhs ms with
  | ff := none
  | tt := some ⟨list.append l.rhs (list.drop l.lhs.length ms), elem⟩
  end
| (n + 1) ⟨[], e⟩ := none
| (n + 1) ⟨t::ts, e⟩ :=
  match try_apply_comm_lemma_at_aux n ⟨ts, e⟩ with
  | none := none
  | some ⟨nt, ne⟩ := some ⟨t::nt, ne⟩
  end

meta def try_apply_element_lemma_at_aux (l : element_lemma) :
  ℕ → diagram_term → option (diagram_term)
| 0 ⟨ms, elem⟩ := if l.lhs = ⟨ms, elem⟩ then some l.rhs else none
| (n + 1) ⟨[], e⟩ := none
| (n + 1) ⟨t :: ts, e⟩ :=
  match try_apply_element_lemma_at_aux n ⟨ts, e⟩ with
  | none := none
  | some ⟨nt, ne⟩ := some ⟨t::nt, ne⟩
  end

meta inductive lemma_app
| comm : commutativity_lemma → ℕ → diagram_term → lemma_app
| elem : element_lemma → ℕ → diagram_term → lemma_app

meta instance format_lemma_app : has_to_format lemma_app :=
{ to_format := λ a,
  match a with
  | lemma_app.comm a b c := format!"comm: lemma ({a}) at {b} gives {c}"
  | lemma_app.elem a b c := format!"elem: lemma ({a}) at {b} gives {c}"
  end }

meta def next_term : lemma_app → diagram_term
| (lemma_app.comm _ _ t) := t
| (lemma_app.elem _ _ t) := t

meta def apply_comm_lemma_at_aux : ℕ → diagram_term → tactic (option expr)
| 0 t := some <$> (mk_eq_refl $ as_expr t)
| 1 ⟨t::[], e⟩ := some <$> (mk_eq_refl $ as_expr ⟨[t], e⟩)
| (n + 1) ⟨[], _⟩ := return none
| (n + 1) ⟨t::[], e⟩ := return none
| (n + 1) ⟨t::(u::ts), e⟩ :=
do
  some x ← i_to_expr ``(%%(u.ex) ≫ %%(t.ex)) >>= as_morphism,
  lhs ← mk_app `category_theory.abelian.pseudoelements.comp_apply [u.ex, t.ex, as_expr ⟨ts, e⟩] >>= mk_eq_symm,
  some rhs ← apply_comm_lemma_at_aux n ⟨x::ts, e⟩,
  some <$> mk_eq_trans lhs rhs

meta def apply_comm_lemma_at (l : commutativity_lemma) :
  ℕ → diagram_term → diagram_term → tactic (option expr)
| 0 ⟨ms, elem⟩ goal :=
do
  some one ← apply_comm_lemma_at_aux (l.lhs.length - 1) ⟨ms, elem⟩,
  let inner := as_expr ⟨list.drop (l.lhs.length) ms, elem⟩,
  two ← mk_app `tactic.chase.pseudo_congr [l.ex, inner],
  some three ← apply_comm_lemma_at_aux (l.rhs.length - 1) goal,
  three' ← mk_eq_symm three,
  onetwo ← mk_eq_trans one two,
  some <$> mk_eq_trans onetwo three'
| (n + 1) ⟨[], e⟩ goal := none
| (n + 1) fr ⟨[], e⟩ := none
| (n + 1) ⟨t::ts, e⟩ ⟨u::us, f⟩ :=
do
  some inner ← apply_comm_lemma_at n ⟨ts, e⟩ ⟨us, f⟩,
  some <$> mk_app `congr_arg [t.app, inner]

meta def apply_elem_lemma_at (l : element_lemma) :
  ℕ → diagram_term → tactic (option expr)
| 0 ⟨ms, elem⟩ := return $ some l.ex
| (n + 1) ⟨[], _⟩ := none
| (n + 1) ⟨t::ts, e⟩ :=
do
  some inner ← apply_elem_lemma_at n ⟨ts, e⟩,
  some <$> mk_app `congr_arg [t.app, inner]

meta def build_proof (t : diagram_term) : lemma_app → tactic expr
| (lemma_app.comm x y z) :=
do
  some u ← apply_comm_lemma_at x y t z,
  return u
| (lemma_app.elem x y z) :=
do
  some u ← apply_elem_lemma_at x y t,
  return u

meta def try_apply_comm_lemma_at (l : commutativity_lemma) (n : ℕ) (t : diagram_term) :
  option (lemma_app) :=
match try_apply_comm_lemma_at_aux l n t with
| none := none
| some t := lemma_app.comm l n t
end

meta def try_apply_elem_lemma_at (l : element_lemma) (n : ℕ) (t : diagram_term) :
  option lemma_app :=
match try_apply_element_lemma_at_aux l n t with
| none := none
| some t := lemma_app.elem l n t
end

meta def iota : ℕ → list ℕ
| 0 := [0]
| (n + 1) := (n + 1) :: iota n

meta def try_apply_comm_lemma (l : commutativity_lemma) (t : diagram_term) : list lemma_app :=
list.filter_map (λ n, try_apply_comm_lemma_at l n t) $ iota t.ms.length

meta def try_apply_elem_lemma (l : element_lemma) (t : diagram_term) : list lemma_app :=
list.filter_map (λ n, try_apply_elem_lemma_at l n t) $ iota t.ms.length

meta def try_all_comm (t : diagram_term) : chase_tactic (list lemma_app) :=
do
  l ← get,
  return $ list.join $ list.map (λ l, try_apply_comm_lemma l t) l.comm_lemmas

meta def try_all_elem (t : diagram_term) : chase_tactic (list lemma_app) :=
do
  l ← get,
  return $ list.join $ list.map (λ l, try_apply_elem_lemma l t) l.elem_lemmas

meta mutual def show_via_zero, find_proof_dfs
with show_via_zero : diagram_term → diagram_term → chase_tactic (option expr)
| cur goal := do
  l ← diagram_term.to_zero cur,
  match l with
  | none := return none
  | some e := do
    zer ← goal.zero,
    r ← find_proof_dfs goal zer [],
    match r with
    | none := return none
    | some f := (mk_eq_symm f) >>= (λ g, some <$> mk_eq_trans e g)
    end
  end
with find_proof_dfs :
diagram_term → diagram_term → list diagram_term → chase_tactic (option expr)
| cur goal seen := if cur = goal then some <$> mk_eq_refl (as_expr cur) else
do
  via_zero ← show_via_zero cur goal,
  match via_zero with
  | some e := return $ some e
  | none := do
    cands_comm ← try_all_comm cur,
    cands_elem ← try_all_elem cur,
    let cands := list.append cands_comm cands_elem,

    list.mfoldl (λ r s,
      match r with
      | some q := return $ some q
      | none :=
        ite (list.any seen (λ e, to_bool $ e = (next_term s))) (return none) $
        do
          --trace format!"trying {s}...",
          l ← find_proof_dfs (next_term s) goal (cur::seen),
          match l with
          | none := none
          | some q := do
            f ← build_proof cur s,
            t ← mk_eq_trans f q,
            return $ some t
          end
      end) none cands
    end

meta def find_direct_proof (cur goal : diagram_term) : chase_tactic (option expr) :=
find_proof_dfs cur goal []

meta def find_proof : diagram_term → diagram_term → chase_tactic (option expr)
| ⟨t, e⟩ ⟨t', e'⟩ := do
  mm ← diagram_term.type ⟨t, e⟩ >>= mono_with_domain,
  match mm with
  | none := find_direct_proof ⟨t, e⟩ ⟨t', e'⟩
  | some m := do
    ii ← find_proof ⟨m::t, e⟩ ⟨m::t', e'⟩,
    match ii with
    | none := none
    | some i := some <$> mk_app `category_theory.abelian.pseudoelements.pseudo_injective_of_mono [i]
    end
  end

meta def commutativity : chase_tactic unit :=
do
  (_, l, r) ← target_lhs_rhs,
  some lhs ← as_diagram_term l,
  some rhs ← as_diagram_term r,
  some p ← find_proof lhs rhs,
  tactic.exact p

end tactic.chase

namespace tactic.interactive
open interactive (parse)
open lean.parser (tk pexpr)

meta def commutativity (loc : parse ((tk "at" *> some <$> pexpr) <|> return none)) : tactic unit :=
do
  l ← match loc with
      | none := return none
      | some m := some <$> to_expr m
      end,
  chase.run_chase_tactic l tactic.chase.commutativity

end tactic.interactive