/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.WHNF
import Lean.Meta.DiscrTreeTypes

namespace Lean.Meta.DiscrTree
/-!
  (Imperfect) discrimination trees.
  We use a hybrid representation.
  - A `PersistentHashMap` for the root node which usually contains many children.
  - A sorted array of key/node pairs for inner nodes.

  The edges are labeled by keys:
  - Constant names (and arity). Universe levels are ignored.
  - Free variables (and arity). Thus, an entry in the discrimination tree
    may reference hypotheses from the local context.
  - Literals
  - Star/Wildcard. We use them to represent metavariables and terms
    we want to ignore. We ignore implicit arguments and proofs.
  - Other. We use to represent other kinds of terms (e.g., nested lambda, forall, sort, etc).

  We reduce terms using `TransparencyMode.reducible`. Thus, all reducible
  definitions in an expression `e` are unfolded before we insert it into the
  discrimination tree.

  Recall that projections from classes are **NOT** reducible.
  For example, the expressions `Add.add α (ringAdd ?α ?s) ?x ?x`
  and `Add.add Nat Nat.hasAdd a b` generates paths with the following keys
  respctively
  ```
  ⟨Add.add, 4⟩, *, *, *, *
  ⟨Add.add, 4⟩, *, *, ⟨a,0⟩, ⟨b,0⟩
  ```

  That is, we don't reduce `Add.add Nat inst a b` into `Nat.add a b`.
  We say the `Add.add` applications are the de-facto canonical forms in
  the metaprogramming framework.
  Moreover, it is the metaprogrammer's responsibility to re-pack applications such as
  `Nat.add a b` into `Add.add Nat inst a b`.

  Remark: we store the arity in the keys
  1- To be able to implement the "skip" operation when retrieving "candidate"
     unifiers.
  2- Distinguish partial applications `f a`, `f a b`, and `f a b c`.
-/

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

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

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

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

instance : ToFormat (Key s) := ⟨Key.format⟩

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

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

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

partial def Trie.format [ToFormat α] : Trie α s → Format
  | .node vs cs => Format.group $ Format.paren $
    "node" ++ (if vs.isEmpty then Format.nil else " " ++ Std.format vs)
    ++ Format.join (cs.toList.map fun ⟨k, c⟩ => Format.line ++ Format.paren (Std.format k ++ " => " ++ format c))

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

partial def format [ToFormat α] (d : DiscrTree α s) : Format :=
  let (_, r) := d.root.foldl
    (fun (p : Bool × Format) k c =>
      (false, p.2 ++ (if p.1 then Format.nil else Format.line) ++ Format.paren (Std.format k ++ " => " ++ Std.format c)))
    (true, Format.nil)
  Format.group r

instance [ToFormat α] : ToFormat (DiscrTree α s) := ⟨format⟩

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

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

/--
  Return true iff the argument should be treated as a "wildcard" by the discrimination tree.

  - We ignore proofs because of proof irrelevance. It doesn't make sense to try to
    index their structure.

  - We ignore instance implicit arguments (e.g., `[Add α]`) because they are "morally" canonical.
    Moreover, we may have many definitionally equal terms floating around.
    Example: `Ring.hasAdd Int Int.isRing` and `Int.hasAdd`.

  - We considered ignoring implicit arguments (e.g., `{α : Type}`) since users don't "see" them,
    and may not even understand why some simplification rule is not firing.
    However, in type class resolution, we have instance such as `Decidable (@Eq Nat x y)`,
    where `Nat` is an implicit argument. Thus, we would add the path
    ```
    Decidable -> Eq -> * -> * -> * -> [Nat.decEq]
    ```
    to the discrimination tree IF we ignored the implict `Nat` argument.
    This would be BAD since **ALL** decidable equality instances would be in the same path.
    So, we index implicit arguments if they are types.
    This setting seems sensible for simplification theorems such as:
    ```
    forall (x y : Unit), (@Eq Unit x y) = true
    ```
    If we ignore the implicit argument `Unit`, the `DiscrTree` will say it is a candidate
    simplification theorem for any equality in our goal.

  Remark: if users have problems with the solution above, we may provide a `noIndexing` annotation,
  and `ignoreArg` would return true for any term of the form `noIndexing t`.
-/
private def ignoreArg (a : Expr) (i : Nat) (infos : Array ParamInfo) : MetaM Bool := do
  if h : i < infos.size then
    let info := infos.get ⟨i, h⟩
    if info.isInstImplicit then
      return true
    else if info.isImplicit || info.isStrictImplicit then
      return not (← isType a)
    else
      isProof a
  else
    isProof a

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

/--
  Return true if `e` is one of the following
  - A nat literal (numeral)
  - `Nat.zero`
  - `Nat.succ x` where `isNumeral x`
  - `OfNat.ofNat _ x _` where `isNumeral x` -/
private partial def isNumeral (e : Expr) : Bool :=
  if e.isNatLit then true
  else
    let f := e.getAppFn
    if !f.isConst then false
    else
      let fName := f.constName!
      if fName == ``Nat.succ && e.getAppNumArgs == 1 then isNumeral e.appArg!
      else if fName == ``OfNat.ofNat && e.getAppNumArgs == 3 then isNumeral (e.getArg! 1)
      else if fName == ``Nat.zero && e.getAppNumArgs == 0 then true
      else false

private def isNatType (e : Expr) : MetaM Bool :=
  return (← whnf e).isConstOf ``Nat

/--
  Return true if `e` is one of the following
  - `Nat.add _ k` where `isNumeral k`
  - `Add.add Nat _ _ k` where `isNumeral k`
  - `HAdd.hAdd _ Nat _ _ k` where `isNumeral k`
  - `Nat.succ _`
  This function assumes `e.isAppOf fName`
-/
private def isOffset (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == ``Nat.add && e.getAppNumArgs == 2 then
    return isNumeral e.appArg!
  else if fName == ``Add.add && e.getAppNumArgs == 4 then
    if (← isNatType (e.getArg! 0)) then return isNumeral e.appArg! else return false
  else if fName == ``HAdd.hAdd && e.getAppNumArgs == 6 then
    if (← isNatType (e.getArg! 1)) then return isNumeral e.appArg! else return false
  else
    return fName == ``Nat.succ && e.getAppNumArgs == 1

/--
  TODO: add hook for users adding their own functions for controlling `shouldAddAsStar`
  Different `DiscrTree` users may populate this set using, for example, attributes.

  Remark: we currently tag `Nat.zero` and "offset" terms to avoid having to add special
  support for `Expr.lit` and offset terms.
  Example, suppose the discrimination tree contains the entry
  `Nat.succ ?m |-> v`, and we are trying to retrieve the matches for `Expr.lit (Literal.natVal 1) _`.
  In this scenario, we want to retrieve `Nat.succ ?m |-> v` -/
private def shouldAddAsStar (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == ``Nat.zero then
    return true
  else
    isOffset fName e

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

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

/--
Reduction procedure for the discrimination tree indexing.
The parameter `simpleReduce` controls how aggressive the term is reduced.
The parameter at type `DiscrTree` controls this value.
See comment at `DiscrTree`.
-/
partial def reduce (e : Expr) (simpleReduce : Bool) : MetaM Expr := do
  let e ← whnfCore e (simpleReduceOnly := simpleReduce)
  match (← unfoldDefinition? e) with
  | some e => reduce e simpleReduce
  | none => match e.etaExpandedStrict? with
    | some e => reduce e simpleReduce
    | none   => return e

/--
  Return `true` if `fn` is a "bad" key. That is, `pushArgs` would add `Key.other` or `Key.star`.
  We use this function when processing "root terms, and will avoid unfolding terms.
  Note that without this trick the pattern `List.map f ∘ List.map g` would be mapped into the key `Key.other`
  since the function composition `∘` would be unfolded and we would get `fun x => List.map g (List.map f x)`
-/
private def isBadKey (fn : Expr) : Bool :=
  match fn with
  | .lit ..   => false
  | .const .. => false
  | .fvar ..  => false
  | .proj ..  => false
  | .forallE _ _ b _ => b.hasLooseBVars
  | _ => true

/--
  Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
  is a bad key (see comment at `isBadKey`).
  We use this method instead of `reduce` for root terms at `pushArgs`. -/
private partial def reduceUntilBadKey (e : Expr) (simpleReduce : Bool) : MetaM Expr := do
  let e ← step e
  match e.etaExpandedStrict? with
  | some e => reduceUntilBadKey e simpleReduce
  | none   => return e
where
  step (e : Expr) := do
    let e ← whnfCore e (simpleReduceOnly := simpleReduce)
    match (← unfoldDefinition? e) with
    | some e' => if isBadKey e'.getAppFn then return e else step e'
    | none    => return e

/-- whnf for the discrimination tree module -/
def reduceDT (e : Expr) (root : Bool) (simpleReduce : Bool) : MetaM Expr :=
  if root then reduceUntilBadKey e simpleReduce else reduce e simpleReduce

/- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/

private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) : MetaM (Key s × Array Expr) := do
  if hasNoindexAnnotation e then
    return (.star, todo)
  else
    let e ← reduceDT e root (simpleReduce := s)
    let fn := e.getAppFn
    let push (k : Key s) (nargs : Nat) (todo : Array Expr): MetaM (Key s × Array Expr) := do
      let info ← getFunInfoNArgs fn nargs
      let todo ← pushArgsAux info.paramInfo (nargs-1) e todo
      return (k, todo)
    match fn with
    | .lit v         => return (.lit v, todo)
    | .const c _     =>
      unless root do
        if (← shouldAddAsStar c e) then
          return (.star, todo)
      let nargs := e.getAppNumArgs
      push (.const c nargs) nargs todo
    | .proj s i a =>
      /-
      If `s` is a class, then `a` is an instance. Thus, we annotate `a` with `no_index` since we do not
      index instances. This should only happen if users mark a class projection function as `[reducible]`.

      TODO: add better support for projections that are functions
      -/
      let a := if isClass (← getEnv) s then mkNoindexAnnotation a else a
      let nargs := e.getAppNumArgs
      push (.proj s i nargs) nargs (todo.push a)
    | .fvar fvarId   =>
      let nargs := e.getAppNumArgs
      push (.fvar fvarId nargs) nargs todo
    | .mvar mvarId   =>
      if mvarId == tmpMVarId then
        -- We use `tmp to mark implicit arguments and proofs
        return (.star, todo)
      else if (← mvarId.isReadOnlyOrSyntheticOpaque) then
        return (.other, todo)
      else
        return (.star, todo)
    | .forallE _ d b _ =>
      if b.hasLooseBVars then
        return (.other, todo)
      else
        return (.arrow, todo.push d |>.push b)
    | _ =>
      return (.other, todo)

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

private def initCapacity := 8

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

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

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

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

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

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

private def getKeyArgs (e : Expr) (isMatch root : Bool) : MetaM (Key s × Array Expr) := do
  let e ← reduceDT e root (simpleReduce := s)
  match e.getAppFn with
  | .lit v         => return (.lit v, #[])
  | .const c _     =>
    if (← getConfig).isDefEqStuckEx && e.hasExprMVar then
      if (← isReducible c) then
        /- `e` is a term `c ...` s.t. `c` is reducible and `e` has metavariables, but it was not unfolded.
           This can happen if the metavariables in `e` are "blocking" smart unfolding.
           If `isDefEqStuckEx` is enabled, then we must throw the `isDefEqStuck` exception to postpone TC resolution.
           Here is an example. Suppose we have
           ```
            inductive Ty where
              | bool | fn (a ty : Ty)

            @[reducible] def Ty.interp : Ty → Type
              | bool   => Bool
              | fn a b => a.interp → b.interp
           ```
           and we are trying to synthesize `BEq (Ty.interp ?m)`
        -/
        Meta.throwIsDefEqStuck
      else if let some matcherInfo := isMatcherAppCore? (← getEnv) e then
        -- A matcher application is stuck is one of the discriminants has a metavariable
        let args := e.getAppArgs
        for arg in args[matcherInfo.getFirstDiscrPos: matcherInfo.getFirstDiscrPos + matcherInfo.numDiscrs] do
          if arg.hasExprMVar then
            Meta.throwIsDefEqStuck
      else if (← isRec c) then
        /- Similar to the previous case, but for `match` and recursor applications. It may be stuck (i.e., did not reduce)
           because of metavariables. -/
        Meta.throwIsDefEqStuck
    let nargs := e.getAppNumArgs
    return (.const c nargs, e.getAppRevArgs)
  | .fvar fvarId   =>
    let nargs := e.getAppNumArgs
    return (.fvar fvarId nargs, e.getAppRevArgs)
  | .mvar mvarId   =>
    if isMatch then
      return (.other, #[])
    else do
      let ctx ← read
      if ctx.config.isDefEqStuckEx then
        /-
          When the configuration flag `isDefEqStuckEx` is set to true,
          we want `isDefEq` to throw an exception whenever it tries to assign
          a read-only metavariable.
          This feature is useful for type class resolution where
          we may want to notify the caller that the TC problem may be solveable
          later after it assigns `?m`.
          The method `DiscrTree.getUnify e` returns candidates `c` that may "unify" with `e`.
          That is, `isDefEq c e` may return true. Now, consider `DiscrTree.getUnify d (Add ?m)`
          where `?m` is a read-only metavariable, and the discrimination tree contains the keys
          `HadAdd Nat` and `Add Int`. If `isDefEqStuckEx` is set to true, we must treat `?m` as
          a regular metavariable here, otherwise we return the empty set of candidates.
          This is incorrect because it is equivalent to saying that there is no solution even if
          the caller assigns `?m` and try again. -/
        return (.star, #[])
      else if (← mvarId.isReadOnlyOrSyntheticOpaque) then
        return (.other, #[])
      else
        return (.star, #[])
  | .proj s i a .. =>
    let nargs := e.getAppNumArgs
    return (.proj s i nargs, #[a] ++ e.getAppRevArgs)
  | .forallE _ d b _ =>
    if b.hasLooseBVars then
      return (.other, #[])
    else
      return (.arrow, #[d, b])
  | _ =>
    return (.other, #[])

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

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

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

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

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

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

private def getMatchCore (d : DiscrTree α s) (e : Expr) : MetaM (Key s × Array α) :=
  withReducible do
    let result := getStarResult d
    let (k, args) ← getMatchKeyArgs e (root := true)
    match k with
    | .star  => return (k, result)
    /- See note about "dep-arrow vs arrow" at `getMatchLoop` -/
    | .arrow => return (k, (← getMatchRoot d k args (← getMatchRoot d .other #[] result)))
    | _      => return (k, (← getMatchRoot d k args result))

/--
  Find values that match `e` in `d`.
-/
def getMatch (d : DiscrTree α s) (e : Expr) : MetaM (Array α) :=
  return (← getMatchCore d e).2

/--
  Similar to `getMatch`, but returns solutions that are prefixes of `e`.
  We store the number of ignored arguments in the result.-/
partial def getMatchWithExtra (d : DiscrTree α s) (e : Expr) : MetaM (Array (α × Nat)) := do
  let (k, result) ← getMatchCore d e
  let result := result.map (·, 0)
  if !e.isApp then
    return result
  else if !(← mayMatchPrefix k) then
    return result
  else
    go e.appFn! 1 result
where
  mayMatchPrefix (k : Key s) : MetaM Bool :=
    let cont (k : Key s) : MetaM Bool :=
      if d.root.find? k |>.isSome then
        return true
      else
        mayMatchPrefix k
    match k with
    | .const f (n+1)  => cont (.const f n)
    | .fvar f (n+1)   => cont (.fvar f n)
    | .proj s i (n+1) => cont (.proj s i n)
    | _               => return false

  go (e : Expr) (numExtra : Nat) (result : Array (α × Nat)) : MetaM (Array (α × Nat)) := do
    let result := result ++ (← getMatch d e).map (., numExtra)
    if e.isApp then
      go e.appFn! (numExtra + 1) result
    else
      return result

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

end Lean.Meta.DiscrTree


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

import Aesop

set_option aesop.check.all true

-- We used to add local rules to the `default` rule set, but this is doesn't
-- work well when the default rule set is disabled. Now we add local rules to
-- a separate `local` rule set.
example : Unit := by
  fail_if_success
    aesop (rule_sets [-default, -builtin]) (options := { terminal := true })
  fail_if_success
    aesop (add safe PUnit.unit) (rule_sets [-default, -builtin, -«local»])
      (options := { terminal := true })
  aesop (add safe PUnit.unit) (rule_sets [-default, -builtin])


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.morphisms.basic
import topology.spectral.hom
import algebraic_geometry.limits

/-!
# Quasi-compact morphisms

A morphism of schemes is quasi-compact if the preimages of quasi-compact open sets are
quasi-compact.

It suffices to check that preimages of affine open sets are compact
(`quasi_compact_iff_forall_affine`).

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/--
A morphism is `quasi-compact` if the underlying map of topological spaces is, i.e. if the preimages
of quasi-compact open sets are quasi-compact.
-/
@[mk_iff]
class quasi_compact (f : X ⟶ Y) : Prop :=
(is_compact_preimage : ∀ U : set Y.carrier, is_open U → is_compact U → is_compact (f.1.base ⁻¹' U))

lemma quasi_compact_iff_spectral : quasi_compact f ↔ is_spectral_map f.1.base :=
⟨λ ⟨h⟩, ⟨by continuity, h⟩, λ h, ⟨h.2⟩⟩

/-- The `affine_target_morphism_property` corresponding to `quasi_compact`, asserting that the
domain is a quasi-compact scheme. -/
def quasi_compact.affine_property : affine_target_morphism_property :=
λ X Y f hf, compact_space X.carrier

@[priority 900]
instance quasi_compact_of_is_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] : quasi_compact f :=
begin
  constructor,
  intros U hU hU',
  convert hU'.image (inv f.1.base).continuous_to_fun using 1,
  rw set.image_eq_preimage_of_inverse,
  delta function.left_inverse,
  exacts [is_iso.inv_hom_id_apply f.1.base, is_iso.hom_inv_id_apply f.1.base]
end

instance quasi_compact_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [quasi_compact f] [quasi_compact g] : quasi_compact (f ≫ g) :=
begin
  constructor,
  intros U hU hU',
  rw [Scheme.comp_val_base, coe_comp, set.preimage_comp],
  apply quasi_compact.is_compact_preimage,
  { exact continuous.is_open_preimage (by continuity) _ hU },
  apply quasi_compact.is_compact_preimage; assumption
end

lemma is_compact_open_iff_eq_finset_affine_union {X : Scheme} (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set X.affine_opens), s.finite ∧ U = ⋃ (i : X.affine_opens) (h : i ∈ s), i :=
begin
  apply opens.is_basis.is_compact_open_iff_eq_finite_Union
    (coe : X.affine_opens → opens X.carrier),
  { rw subtype.range_coe, exact is_basis_affine_open X },
  { exact λ i, i.2.is_compact }
end

lemma is_compact_open_iff_eq_basic_open_union {X : Scheme} [is_affine X] (U : set X.carrier) :
  is_compact U ∧ is_open U ↔
    ∃ (s : set (X.presheaf.obj (op ⊤))), s.finite ∧
      U = ⋃ (i : X.presheaf.obj (op ⊤)) (h : i ∈ s), X.basic_open i :=
(is_basis_basic_open X).is_compact_open_iff_eq_finite_Union _
  (λ i, ((top_is_affine_open _).basic_open_is_affine _).is_compact) _

lemma quasi_compact_iff_forall_affine : quasi_compact f ↔
  ∀ U : opens Y.carrier, is_affine_open U → is_compact (f.1.base ⁻¹' (U : set Y.carrier)) :=
begin
  rw quasi_compact_iff,
  refine ⟨λ H U hU, H U U.is_open hU.is_compact, _⟩,
  intros H U hU hU',
  obtain ⟨S, hS, rfl⟩ := (is_compact_open_iff_eq_finset_affine_union U).mp ⟨hU', hU⟩,
  simp only [set.preimage_Union, subtype.val_eq_coe],
  exact hS.is_compact_bUnion (λ i _, H i i.prop)
end

@[simp] lemma quasi_compact.affine_property_to_property {X Y : Scheme} (f : X ⟶ Y) :
  (quasi_compact.affine_property : _).to_property f ↔
    is_affine Y ∧ compact_space X.carrier :=
by { delta affine_target_morphism_property.to_property quasi_compact.affine_property, simp }

lemma quasi_compact_iff_affine_property :
  quasi_compact f ↔ target_affine_locally quasi_compact.affine_property f :=
begin
  rw quasi_compact_iff_forall_affine,
  transitivity (∀ U : Y.affine_opens, is_compact (f.1.base ⁻¹' (U : set Y.carrier))),
  { exact ⟨λ h U, h U U.prop, λ h U hU, h ⟨U, hU⟩⟩ },
  apply forall_congr,
  exact λ _, is_compact_iff_compact_space,
end

lemma quasi_compact_eq_affine_property :
  @quasi_compact = target_affine_locally quasi_compact.affine_property :=
by { ext, exact quasi_compact_iff_affine_property _ }

lemma is_compact_basic_open (X : Scheme) {U : opens X.carrier} (hU : is_compact (U : set X.carrier))
   (f : X.presheaf.obj (op U)) : is_compact (X.basic_open f : set X.carrier) :=
begin
  classical,
  refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1,
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union _).mp ⟨hU, U.is_open⟩,
  let g : s → X.affine_opens,
  { intro V,
    use V.1 ⊓ X.basic_open f,
    have : V.1.1 ⟶ U,
    { apply hom_of_le, change _ ⊆ (U : set X.carrier), rw e,
      convert @set.subset_Union₂ _ _ _ (λ (U : X.affine_opens) (h : U ∈ s), ↑U) V V.prop using 1,
      refl },
    erw ← X.to_LocallyRingedSpace.to_RingedSpace.basic_open_res this.op,
    exact is_affine_open.basic_open_is_affine V.1.prop _ },
  haveI : finite s := hs.to_subtype,
  refine ⟨set.range g, set.finite_range g, _⟩,
  refine (set.inter_eq_right_iff_subset.mpr (set_like.coe_subset_coe.2 $
    RingedSpace.basic_open_le _ _)).symm.trans _,
  rw [e, set.Union₂_inter],
  apply le_antisymm; apply set.Union₂_subset,
  { intros i hi,
    refine set.subset.trans _ (set.subset_Union₂ _ (set.mem_range_self ⟨i, hi⟩)),
    exact set.subset.rfl },
  { rintro ⟨i, hi⟩ ⟨⟨j, hj⟩, hj'⟩,
    rw ← hj',
    refine set.subset.trans _ (set.subset_Union₂ j hj),
    exact set.subset.rfl }
end

lemma quasi_compact.affine_property_is_local :
  (quasi_compact.affine_property : _).is_local :=
begin
  split,
  { apply affine_target_morphism_property.respects_iso_mk; rintros X Y Z _ _ _ H,
    exacts [@@homeomorph.compact_space _ _ H (Top.homeo_of_iso (as_iso e.inv.1.base)), H] },
  { introv H,
    delta quasi_compact.affine_property at H ⊢,
    change compact_space ((opens.map f.val.base).obj (Y.basic_open r)),
    rw Scheme.preimage_basic_open f r,
    erw ← is_compact_iff_compact_space,
    rw ← is_compact_univ_iff at H,
    exact is_compact_basic_open X H _ },
  { rintros X Y H f S hS hS',
    resetI,
    rw ← is_affine_open.basic_open_union_eq_self_iff at hS,
    delta quasi_compact.affine_property,
    rw ← is_compact_univ_iff,
    change is_compact ((opens.map f.val.base).obj ⊤).1,
    rw ← hS,
    dsimp [opens.map],
    simp only [opens.coe_supr, set.preimage_Union, subtype.val_eq_coe],
    exacts [is_compact_Union (λ i, is_compact_iff_compact_space.mpr (hS' i)),
      top_is_affine_open _] }
end

lemma quasi_compact.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), compact_space (pullback f (𝒰.map i)).carrier,
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      compact_space (pullback f (𝒰.map i)).carrier,
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      compact_space (pullback f g).carrier,
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤) (hU' : ∀ i, is_affine_open (U i)),
      ∀ i, compact_space (f.1.base ⁻¹' (U i).1)] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_tfae f

lemma quasi_compact.is_local_at_target :
  property_is_local_at_target @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local

lemma quasi_compact.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [quasi_compact f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      quasi_compact (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), quasi_compact (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      quasi_compact (pullback.snd : pullback f g ⟶ _),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), ∀ i, quasi_compact (f ∣_ (U i))] :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_tfae f

lemma quasi_compact_over_affine_iff {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  quasi_compact f ↔ compact_space X.carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_target_iff f

lemma compact_space_iff_quasi_compact (X : Scheme) :
  compact_space X.carrier ↔ quasi_compact (terminal.from X) :=
(quasi_compact_over_affine_iff _).symm

lemma quasi_compact.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, compact_space (pullback f (𝒰.map i)).carrier :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma quasi_compact.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y) (f : X ⟶ Y) :
  quasi_compact f ↔ ∀ i, quasi_compact (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

lemma quasi_compact_stable_under_composition :
  morphism_property.stable_under_composition @quasi_compact :=
λ _ _ _ _ _ _ _, by exactI infer_instance

local attribute [-simp] PresheafedSpace.as_coe SheafedSpace.as_coe

lemma quasi_compact.affine_property_stable_under_base_change :
  quasi_compact.affine_property.stable_under_base_change :=
begin
  intros X Y S _ _ f g h,
  rw quasi_compact.affine_property at h ⊢,
  resetI,
  let 𝒰 := Scheme.pullback.open_cover_of_right Y.affine_cover.finite_subcover f g,
  haveI : finite 𝒰.J,
  { dsimp [𝒰], apply_instance },
  haveI : ∀ i, compact_space (𝒰.obj i).carrier,
  { intro i, dsimp, apply_instance },
  exact 𝒰.compact_space,
end

lemma quasi_compact_stable_under_base_change :
  morphism_property.stable_under_base_change @quasi_compact :=
quasi_compact_eq_affine_property.symm ▸
  quasi_compact.affine_property_is_local.stable_under_base_change
    quasi_compact.affine_property_stable_under_base_change

variables {Z : Scheme.{u}}

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact g] :
  quasi_compact (pullback.fst : pullback f g ⟶ X) :=
quasi_compact_stable_under_base_change.fst f g infer_instance

instance (f : X ⟶ Z) (g : Y ⟶ Z) [quasi_compact f] :
  quasi_compact (pullback.snd : pullback f g ⟶ Y) :=
quasi_compact_stable_under_base_change.snd f g infer_instance

@[elab_as_eliminator]
lemma compact_open_induction_on {P : opens X.carrier → Prop} (S : opens X.carrier)
  (hS : is_compact S.1)
  (h₁ : P ⊥)
  (h₂ : ∀ (S : opens X.carrier) (hS : is_compact S.1) (U : X.affine_opens), P S → P (S ⊔ U)) :
    P S :=
begin
  classical,
  obtain ⟨s, hs, hs'⟩ := (is_compact_open_iff_eq_finset_affine_union S.1).mp ⟨hS, S.2⟩,
  replace hs' : S = supr (λ i : s, (i : opens X.carrier)) := by { ext1, simpa using hs' },
  subst hs',
  apply hs.induction_on,
  { convert h₁, rw supr_eq_bot, rintro ⟨_, h⟩, exact h.elim },
  { intros x s h₃ hs h₄,
    have : is_compact (⨆ i : s, (i : opens X.carrier)).1,
    { refine ((is_compact_open_iff_eq_finset_affine_union _).mpr _).1, exact ⟨s, hs, by simp⟩ },
    convert h₂ _ this x h₄,
    simp only [coe_coe],
    rw [supr_subtype, sup_comm],
    conv_rhs { rw supr_subtype },
    exact supr_insert }
end

lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open (X : Scheme)
  {U : opens X.carrier} (hU : is_affine_open U) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  rw ← map_zero (X.presheaf.map (hom_of_le $ X.basic_open_le f : X.basic_open f ⟶ U).op) at H,
  have := (is_localization_basic_open hU f).3,
  obtain ⟨⟨_, n, rfl⟩, e⟩ := this.mp H,
  exact ⟨n, by simpa [mul_comm x] using e⟩,
end

/-- If `x : Γ(X, U)` is zero on `D(f)` for some `f : Γ(X, U)`, and `U` is quasi-compact, then
`f ^ n * x = 0` for some `n`. -/
lemma exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_compact (X : Scheme)
  {U : opens X.carrier} (hU : is_compact U.1) (x f : X.presheaf.obj (op U))
  (H : x |_ X.basic_open f = 0) :
  ∃ n : ℕ, f ^ n * x = 0 :=
begin
  obtain ⟨s, hs, e⟩ := (is_compact_open_iff_eq_finset_affine_union U.1).mp ⟨hU, U.2⟩,
  replace e : U = supr (λ i : s, (i : opens X.carrier)),
  { ext1, simpa using e },
  have h₁ : ∀ i : s, i.1.1 ≤ U,
  { intro i, change (i : opens X.carrier) ≤ U, rw e, exact le_supr _ _ },
  have H' := λ (i : s), exists_pow_mul_eq_zero_of_res_basic_open_eq_zero_of_is_affine_open X i.1.2
    (X.presheaf.map (hom_of_le (h₁ i)).op x) (X.presheaf.map (hom_of_le (h₁ i)).op f) _,
  swap,
  { delta Top.presheaf.restrict_open Top.presheaf.restrict at H ⊢,
    convert congr_arg (X.presheaf.map (hom_of_le _).op) H,
    { simp only [← comp_apply, ← functor.map_comp], congr },
    { rw map_zero },
    { rw X.basic_open_res, exact set.inter_subset_right _ _ } },
  choose n hn using H',
  haveI := hs.to_subtype,
  casesI nonempty_fintype s,
  use finset.univ.sup n,
  suffices : ∀ (i : s), X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n) * x) = 0,
  { subst e,
    apply X.sheaf.eq_of_locally_eq (λ (i : s), (i : opens X.carrier)),
    intro i,
    rw map_zero,
    apply this },
  intro i,
  replace hn := congr_arg
    (λ x, X.presheaf.map (hom_of_le (h₁ i)).op (f ^ (finset.univ.sup n - n i)) * x) (hn i),
  dsimp at hn,
  simp only [← map_mul, ← map_pow] at hn,
  rwa [mul_zero, ← mul_assoc, ← pow_add, tsub_add_cancel_of_le] at hn,
  apply finset.le_sup (finset.mem_univ i)
end

end algebraic_geometry


import Smt

theorem comm (f : Bool → Bool → Bool) (p q : Bool) : f p q == f q p := by
  smt
  admit


/-
Copyright (c) 2020 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.string.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Parsers

`parser α` is the type that describes a computation that can ingest a `char_buffer`
and output, if successful, a term of type `α`.
This file expands on the definitions in the core library, proving that all the core library
parsers are `valid`. There are also lemmas on the composability of parsers.

## Main definitions

* `parse_result.pos` : The position of a `char_buffer` at which a `parser α` has finished.
* `parser.valid` : The property that a parser only moves forward within a buffer,
  in both cases of success or failure.

## Implementation details

Lemmas about how parsers are valid are in the `valid` namespace. That allows using projection
notation for shorter term proofs that are parallel to the definitions of the parsers in structure.

-/

/--
For some `parse_result α`, give the position at which the result was provided, in either the
`done` or the `fail` case.
-/
@[simp] def parse_result.pos {α : Type} : parse_result α → ℕ := sorry

namespace parser

/--
A `parser α` is defined to be `valid` if the result `p cb n` it gives,
for some `cb : char_buffer` and `n : ℕ`, (whether `done` or `fail`),
is always at a `parse_result.pos` that is at least `n`. Additionally, if the position of the result
of the parser was within the size of the `cb`, then the input to the parser must have been within
`cb.size` too.
-/
def valid {α : Type} (p : parser α) :=
  ∀ (cb : char_buffer) (n : ℕ),
    n ≤ parse_result.pos (p cb n) ∧
      (parse_result.pos (p cb n) ≤ buffer.size cb → n ≤ buffer.size cb)

theorem fail_iff {α : Type} (p : parser α) (cb : char_buffer) (n : ℕ) :
    (∀ (pos' : ℕ) (result : α), p cb n ≠ parse_result.done pos' result) ↔
        ∃ (pos' : ℕ), ∃ (err : dlist string), p cb n = parse_result.fail pos' err :=
  sorry

theorem success_iff {α : Type} (p : parser α) (cb : char_buffer) (n : ℕ) :
    (∀ (pos' : ℕ) (err : dlist string), p cb n ≠ parse_result.fail pos' err) ↔
        ∃ (pos' : ℕ), ∃ (result : α), p cb n = parse_result.done pos' result :=
  sorry

theorem decorate_errors_fail {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    (h : p cb n = parse_result.fail n' err) :
    decorate_errors msgs p cb n =
        parse_result.fail n (dlist.lazy_of_list fun (_ : Unit) => msgs Unit.unit) :=
  sorry

theorem decorate_errors_success {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} (h : p cb n = parse_result.done n' a) :
    decorate_errors msgs p cb n = parse_result.done n' a :=
  sorry

theorem decorate_error_fail {α : Type} {msg : thunk string} {p : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (h : p cb n = parse_result.fail n' err) :
    decorate_error msg p cb n =
        parse_result.fail n (dlist.lazy_of_list fun (_ : Unit) => [msg Unit.unit]) :=
  decorate_errors_fail h

theorem decorate_error_success {α : Type} {msg : thunk string} {p : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {a : α} (h : p cb n = parse_result.done n' a) :
    decorate_error msg p cb n = parse_result.done n' a :=
  decorate_errors_success h

@[simp] theorem decorate_errors_eq_done {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    decorate_errors msgs p cb n = parse_result.done n' a ↔ p cb n = parse_result.done n' a :=
  sorry

@[simp] theorem decorate_error_eq_done {α : Type} {msg : thunk string} {p : parser α}
    {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    decorate_error msg p cb n = parse_result.done n' a ↔ p cb n = parse_result.done n' a :=
  decorate_errors_eq_done

@[simp] theorem decorate_errors_eq_fail {α : Type} {msgs : thunk (List string)} {p : parser α}
    {cb : char_buffer} {n : ℕ} {err : dlist string} :
    decorate_errors msgs p cb n = parse_result.fail n err ↔
        (err = dlist.lazy_of_list fun (_ : Unit) => msgs Unit.unit) ∧
          ∃ (np : ℕ), ∃ (err' : dlist string), p cb n = parse_result.fail np err' :=
  sorry

@[simp] theorem decorate_error_eq_fail {α : Type} {msg : thunk string} {p : parser α}
    {cb : char_buffer} {n : ℕ} {err : dlist string} :
    decorate_error msg p cb n = parse_result.fail n err ↔
        (err = dlist.lazy_of_list fun (_ : Unit) => [msg Unit.unit]) ∧
          ∃ (np : ℕ), ∃ (err' : dlist string), p cb n = parse_result.fail np err' :=
  decorate_errors_eq_fail

@[simp] theorem return_eq_pure {α : Type} {a : α} : return a = pure a := rfl

theorem pure_eq_done {α : Type} {a : α} :
    pure a = fun (_x : char_buffer) (n : ℕ) => parse_result.done n a :=
  rfl

@[simp] theorem pure_ne_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    {a : α} : pure a cb n ≠ parse_result.fail n' err :=
  sorry

@[simp] theorem bind_eq_bind {α : Type} {β : Type} {p : parser α} (f : α → parser β) :
    parser.bind p f = p >>= f :=
  rfl

@[simp] theorem bind_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {f : α → parser β} :
    bind p f cb n = parse_result.done n' b ↔
        ∃ (np : ℕ),
          ∃ (a : α), p cb n = parse_result.done np a ∧ f a cb np = parse_result.done n' b :=
  sorry

@[simp] theorem bind_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {f : α → parser β} :
    bind p f cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ f a cb np = parse_result.fail n' err :=
  sorry

@[simp] theorem and_then_eq_bind {α : Type} {β : Type} {m : Type → Type} [Monad m] (a : m α)
    (b : m β) :
    a >> b =
        do
          a
          b :=
  rfl

theorem and_then_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} :
    has_bind.and_then p (return Unit.unit) cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err :=
  sorry

theorem and_then_success {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    has_bind.and_then p (return Unit.unit) cb n = parse_result.done n' Unit.unit ↔
        ∃ (a : α), p cb n = parse_result.done n' a :=
  sorry

@[simp] theorem map_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β} :
    Functor.map f p cb n = parse_result.done n' b ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ f a = b :=
  sorry

@[simp] theorem map_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {f : α → β} :
    Functor.map f p cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

@[simp] theorem map_const_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {b' : β} :
    Functor.mapConst b p cb n = parse_result.done n' b' ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ b = b' :=
  sorry

@[simp] theorem map_const_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {b : β} :
    Functor.mapConst b p cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

theorem map_const_rev_eq_done {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {b : β} {b' : β} :
    functor.map_const_rev p b cb n = parse_result.done n' b' ↔
        ∃ (a : α), p cb n = parse_result.done n' a ∧ b = b' :=
  map_const_eq_done

theorem map_rev_const_eq_fail {α : Type} {β : Type} {p : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {err : dlist string} {b : β} :
    functor.map_const_rev p b cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  map_const_eq_fail

@[simp] theorem orelse_eq_orelse {α : Type} {p : parser α} {q : parser α} :
    parser.orelse p q = (p <|> q) :=
  rfl

@[simp] theorem orelse_eq_done {α : Type} {p : parser α} {q : parser α} {cb : char_buffer} {n : ℕ}
    {n' : ℕ} {a : α} :
    has_orelse.orelse p q cb n = parse_result.done n' a ↔
        p cb n = parse_result.done n' a ∨
          q cb n = parse_result.done n' a ∧
            ∃ (err : dlist string), p cb n = parse_result.fail n err :=
  sorry

@[simp] theorem orelse_eq_fail_eq {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {err : dlist string} :
    has_orelse.orelse p q cb n = parse_result.fail n err ↔
        (p cb n = parse_result.fail n err ∧
            ∃ (nq : ℕ), ∃ (errq : dlist string), n < nq ∧ q cb n = parse_result.fail nq errq) ∨
          ∃ (errp : dlist string),
            ∃ (errq : dlist string),
              p cb n = parse_result.fail n errp ∧
                q cb n = parse_result.fail n errq ∧ errp ++ errq = err :=
  sorry

theorem orelse_eq_fail_invalid_lt {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (hn : n' < n) :
    has_orelse.orelse p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          q cb n = parse_result.fail n' err ∧
            ∃ (errp : dlist string), p cb n = parse_result.fail n errp :=
  sorry

theorem orelse_eq_fail_of_valid_ne {α : Type} {p : parser α} {q : parser α} {cb : char_buffer}
    {n : ℕ} {n' : ℕ} {err : dlist string} (hv : valid q) (hn : n ≠ n') :
    has_orelse.orelse p q cb n = parse_result.fail n' err ↔ p cb n = parse_result.fail n' err :=
  sorry

@[simp] theorem failure_eq_failure {α : Type} : parser.failure = failure := rfl

@[simp] theorem failure_def {α : Type} {cb : char_buffer} {n : ℕ} :
    failure cb n = parse_result.fail n dlist.empty :=
  rfl

theorem not_failure_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} :
    ¬failure cb n = parse_result.done n' a :=
  sorry

theorem failure_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string} :
    failure cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem seq_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : parser (α → β)} {p : parser α} :
    Seq.seq f p cb n = parse_result.done n' b ↔
        ∃ (nf : ℕ),
          ∃ (f' : α → β),
            ∃ (a : α),
              f cb n = parse_result.done nf f' ∧ p cb nf = parse_result.done n' a ∧ f' a = b :=
  sorry

theorem seq_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    {f : parser (α → β)} {p : parser α} :
    Seq.seq f p cb n = parse_result.fail n' err ↔
        f cb n = parse_result.fail n' err ∨
          ∃ (nf : ℕ),
            ∃ (f' : α → β), f cb n = parse_result.done nf f' ∧ p cb nf = parse_result.fail n' err :=
  sorry

theorem seq_left_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {p : parser α} {q : parser β} :
    SeqLeft.seqLeft p q cb n = parse_result.done n' a ↔
        ∃ (np : ℕ), ∃ (b : β), p cb n = parse_result.done np a ∧ q cb np = parse_result.done n' b :=
  sorry

theorem seq_left_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {p : parser α} {q : parser β} :
    SeqLeft.seqLeft p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.fail n' err :=
  sorry

theorem seq_right_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {p : parser α} {q : parser β} :
    SeqRight.seqRight p q cb n = parse_result.done n' b ↔
        ∃ (np : ℕ), ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.done n' b :=
  sorry

theorem seq_right_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {p : parser α} {q : parser β} :
    SeqRight.seqRight p q cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ q cb np = parse_result.fail n' err :=
  sorry

theorem mmap_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {f : α → parser β}
    {a : α} {l : List α} {b : β} {l' : List β} :
    mmap f (a :: l) cb n = parse_result.done n' (b :: l') ↔
        ∃ (np : ℕ), f a cb n = parse_result.done np b ∧ mmap f l cb np = parse_result.done n' l' :=
  sorry

theorem mmap'_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {f : α → parser β}
    {a : α} {l : List α} :
    mmap' f (a :: l) cb n = parse_result.done n' Unit.unit ↔
        ∃ (np : ℕ),
          ∃ (b : β),
            f a cb n = parse_result.done np b ∧ mmap' f l cb np = parse_result.done n' Unit.unit :=
  sorry

theorem guard_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : Prop} [Decidable p] :
    guard p cb n = parse_result.done n' Unit.unit ↔ p ∧ n = n' :=
  sorry

theorem guard_eq_fail {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string} {p : Prop}
    [Decidable p] : guard p cb n = parse_result.fail n' err ↔ ¬p ∧ n = n' ∧ err = dlist.empty :=
  sorry

namespace valid

theorem mono_done {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    (hp : valid p) (h : p cb n = parse_result.done n' a) : n ≤ n' :=
  sorry

theorem mono_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ} {err : dlist string}
    (hp : valid p) (h : p cb n = parse_result.fail n' err) : n ≤ n' :=
  sorry

theorem pure {α : Type} {a : α} : valid (pure a) := sorry

@[simp] theorem bind {α : Type} {β : Type} {p : parser α} {f : α → parser β} (hp : valid p)
    (hf : ∀ (a : α), valid (f a)) : valid (p >>= f) :=
  sorry

theorem and_then {α : Type} {β : Type} {p : parser α} {q : parser β} (hp : valid p) (hq : valid q) :
    valid (p >> q) :=
  bind hp fun (_x : α) => hq

@[simp] theorem map {α : Type} {β : Type} {p : parser α} (hp : valid p) {f : α → β} :
    valid (f <$> p) :=
  bind hp fun (_x : α) => pure

@[simp] theorem seq {α : Type} {β : Type} {p : parser α} {f : parser (α → β)} (hf : valid f)
    (hp : valid p) : valid (f <*> p) :=
  bind hf fun (_x : α → β) => map hp

@[simp] theorem mmap {α : Type} {β : Type} {l : List α} {f : α → parser β}
    (h : ∀ (a : α), a ∈ l → valid (f a)) : valid (mmap f l) :=
  sorry

@[simp] theorem mmap' {α : Type} {β : Type} {l : List α} {f : α → parser β}
    (h : ∀ (a : α), a ∈ l → valid (f a)) : valid (mmap' f l) :=
  sorry

@[simp] theorem failure {α : Type} : valid failure := sorry

@[simp] theorem guard {p : Prop} [Decidable p] : valid (guard p) := sorry

@[simp] theorem orelse {α : Type} {p : parser α} {q : parser α} (hp : valid p) (hq : valid q) :
    valid (p <|> q) :=
  sorry

@[simp] theorem decorate_errors {α : Type} {msgs : thunk (List string)} {p : parser α}
    (hp : valid p) : valid (decorate_errors msgs p) :=
  sorry

@[simp] theorem decorate_error {α : Type} {msg : thunk string} {p : parser α} (hp : valid p) :
    valid (decorate_error msg p) :=
  decorate_errors hp

@[simp] theorem any_char : valid any_char := sorry

@[simp] theorem sat {p : char → Prop} [decidable_pred p] : valid (sat p) := sorry

@[simp] theorem eps : valid eps := pure

theorem ch {c : char} : valid (ch c) := decorate_error (and_then sat eps)

theorem char_buf {s : char_buffer} : valid (char_buf s) :=
  decorate_error (mmap' fun (_x : char) (_x_1 : _x ∈ buffer.to_list s) => ch)

theorem one_of {cs : List char} : valid (one_of cs) := decorate_errors sat

theorem one_of' {cs : List char} : valid (one_of' cs) := and_then one_of eps

theorem str {s : string} : valid (str s) :=
  decorate_error (mmap' fun (_x : char) (_x_1 : _x ∈ string.to_list s) => ch)

theorem remaining : valid remaining :=
  fun (_x : char_buffer) (_x_1 : ℕ) =>
    { left := le_refl _x_1,
      right := fun (h : parse_result.pos (remaining _x _x_1) ≤ buffer.size _x) => h }

theorem eof : valid eof := decorate_error (bind remaining fun (_x : ℕ) => guard)

theorem foldr_core_zero {α : Type} {β : Type} {p : parser α} {f : α → β → β} {b : β} :
    valid (foldr_core f p b 0) :=
  failure

theorem foldr_core {α : Type} {β : Type} {p : parser α} {f : α → β → β} {b : β} (hp : valid p)
    {reps : ℕ} : valid (foldr_core f p b reps) :=
  sorry

theorem foldr {α : Type} {β : Type} {p : parser α} {b : β} {f : α → β → β} (hp : valid p) :
    valid (foldr f p b) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => foldr_core hp _x _x_1

theorem foldl_core_zero {α : Type} {β : Type} {p : parser α} {f : β → α → β} {b : β} :
    valid (foldl_core f b p 0) :=
  failure

theorem foldl_core {α : Type} {β : Type} {f : α → β → α} {p : parser β} (hp : valid p) {a : α}
    {reps : ℕ} : valid (foldl_core f a p reps) :=
  sorry

theorem foldl {α : Type} {β : Type} {a : α} {f : α → β → α} {p : parser β} (hp : valid p) :
    valid (foldl f a p) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => foldl_core hp _x _x_1

theorem many {α : Type} {p : parser α} (hp : valid p) : valid (many p) := foldr hp

theorem many_char {p : parser char} (hp : valid p) : valid (many_char p) := map (many hp)

theorem many' {α : Type} {p : parser α} (hp : valid p) : valid (many' p) := and_then (many hp) eps

theorem many1 {α : Type} {p : parser α} (hp : valid p) : valid (many1 p) := seq (map hp) (many hp)

theorem many_char1 {p : parser char} (hp : valid p) : valid (many_char1 p) := map (many1 hp)

theorem sep_by1 {α : Type} {p : parser α} {sep : parser Unit} (hp : valid p) (hs : valid sep) :
    valid (sep_by1 sep p) :=
  seq (map hp) (many (and_then hs hp))

theorem sep_by {α : Type} {p : parser α} {sep : parser Unit} (hp : valid p) (hs : valid sep) :
    valid (sep_by sep p) :=
  orelse (sep_by1 hp hs) pure

theorem fix_core {α : Type} {F : parser α → parser α} (hF : ∀ (p : parser α), valid p → valid (F p))
    (max_depth : ℕ) : valid (fix_core F max_depth) :=
  sorry

theorem digit : valid digit := decorate_error (bind sat fun (_x : char) => pure)

theorem nat : valid nat := decorate_error (bind (many1 digit) fun (_x : List ℕ) => pure)

theorem fix {α : Type} {F : parser α → parser α} (hF : ∀ (p : parser α), valid p → valid (F p)) :
    valid (fix F) :=
  fun (_x : char_buffer) (_x_1 : ℕ) => fix_core hF (buffer.size _x - _x_1 + 1) _x _x_1

end valid

@[simp] theorem orelse_pure_eq_fail {α : Type} {p : parser α} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {err : dlist string} {a : α} :
    has_orelse.orelse p (pure a) cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∧ n ≠ n' :=
  sorry

theorem any_char_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char} :
    any_char cb n = parse_result.done n' c ↔
        n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem sat_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char}
    {p : char → Prop} [decidable_pred p] :
    sat p cb n = parse_result.done n' c ↔
        p c ∧ n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem eps_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    eps cb n = parse_result.done n' Unit.unit ↔ n = n' :=
  sorry

theorem ch_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char} :
    ch c cb n = parse_result.done n' Unit.unit ↔
        n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

-- TODO: add char_buf_eq_done, needs lemmas about matching buffers

theorem one_of_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {c : char}
    {cs : List char} :
    one_of cs cb n = parse_result.done n' c ↔
        c ∈ cs ∧ n' = n + 1 ∧ buffer.read cb { val := n, property := hn } = c :=
  sorry

theorem one_of'_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb)
    {cs : List char} :
    one_of' cs cb n = parse_result.done n' Unit.unit ↔
        buffer.read cb { val := n, property := hn } ∈ cs ∧ n' = n + 1 :=
  sorry

theorem remaining_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {r : ℕ} :
    remaining cb n = parse_result.done n' r ↔ n = n' ∧ buffer.size cb - n = r :=
  sorry

theorem eof_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} :
    eof cb n = parse_result.done n' Unit.unit ↔ n = n' ∧ buffer.size cb ≤ n :=
  sorry

@[simp] theorem foldr_core_zero_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {b' : β} :
    foldr_core f p b 0 cb n ≠ parse_result.done n' b' :=
  sorry

theorem foldr_core_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {reps : ℕ} {b' : β} :
    foldr_core f p b (reps + 1) cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              ∃ (xs : β),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b reps cb np = parse_result.done n' xs ∧ f a xs = b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldr_core f p b reps cb np = parse_result.fail n err :=
  sorry

@[simp] theorem foldr_core_zero_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {err : dlist string} :
    foldr_core f p b 0 cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem foldr_core_succ_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {reps : ℕ} {err : dlist string} :
    foldr_core f p b (reps + 1) cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b reps cb np = parse_result.fail n' err) :=
  sorry

theorem foldr_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {b' : β} :
    foldr f p b cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              ∃ (x : β),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b (buffer.size cb - n) cb np = parse_result.done n' x ∧
                    f a x = b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (x : α),
                      p cb n = parse_result.done np x ∧
                        foldr_core f p b (buffer.size cb - n) cb np = parse_result.fail n err :=
  sorry

theorem foldr_eq_fail_of_valid_at_end {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : α → β → β} {p : parser α} {err : dlist string} (hp : valid p)
    (hc : buffer.size cb ≤ n) :
    foldr f p b cb n = parse_result.fail n' err ↔
        n < n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (a : α), p cb n = parse_result.done n' a ∧ err = dlist.empty) :=
  sorry

theorem foldr_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : α → β → β} {p : parser α} {err : dlist string} :
    foldr f p b cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core f p b (buffer.size cb - n) cb np = parse_result.fail n' err) :=
  sorry

@[simp] theorem foldl_core_zero_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : β → α → β} {p : parser α} {b' : β} :
    foldl_core f b p 0 cb n = parse_result.done n' b' ↔ False :=
  sorry

theorem foldl_core_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {reps : ℕ} {b' : β} :
    foldl_core f b p (reps + 1) cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              p cb n = parse_result.done np a ∧
                foldl_core f (f b a) p reps cb np = parse_result.done n' b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldl_core f (f b a) p reps cb np = parse_result.fail n err :=
  sorry

@[simp] theorem foldl_core_zero_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {b : β} {f : β → α → β} {p : parser α} {err : dlist string} :
    foldl_core f b p 0 cb n = parse_result.fail n' err ↔ n = n' ∧ err = dlist.empty :=
  sorry

theorem foldl_core_succ_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {reps : ℕ} {err : dlist string} :
    foldl_core f b p (reps + 1) cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldl_core f (f b a) p reps cb np = parse_result.fail n' err) :=
  sorry

theorem foldl_eq_done {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {b' : β} :
    foldl f b p cb n = parse_result.done n' b' ↔
        (∃ (np : ℕ),
            ∃ (a : α),
              p cb n = parse_result.done np a ∧
                foldl_core f (f b a) p (buffer.size cb - n) cb np = parse_result.done n' b') ∨
          n = n' ∧
            b = b' ∧
              ∃ (err : dlist string),
                p cb n = parse_result.fail n err ∨
                  ∃ (np : ℕ),
                    ∃ (a : α),
                      p cb n = parse_result.done np a ∧
                        foldl_core f (f b a) p (buffer.size cb - n) cb np =
                          parse_result.fail n err :=
  sorry

theorem foldl_eq_fail {α : Type} {β : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {b : β}
    {f : β → α → β} {p : parser α} {err : dlist string} :
    foldl f b p cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldl_core f (f b a) p (buffer.size cb - n) cb np = parse_result.fail n' err) :=
  sorry

theorem many_eq_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many p cb n = parse_result.done n' [] ↔
        n = n' ∧
          ∃ (err : dlist string),
            p cb n = parse_result.fail n err ∨
              ∃ (np : ℕ),
                ∃ (a : α),
                  p cb n = parse_result.done np a ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np =
                      parse_result.fail n err :=
  sorry

theorem many_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} {x : α}
    {xs : List α} :
    many p cb n = parse_result.done n' (x :: xs) ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np x ∧
            foldr_core List.cons p [] (buffer.size cb - n) cb np = parse_result.done n' xs :=
  sorry

theorem many_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α}
    {err : dlist string} :
    many p cb n = parse_result.fail n' err ↔
        n ≠ n' ∧
          (p cb n = parse_result.fail n' err ∨
            ∃ (np : ℕ),
              ∃ (a : α),
                p cb n = parse_result.done np a ∧
                  foldr_core List.cons p [] (buffer.size cb - n) cb np =
                    parse_result.fail n' err) :=
  sorry

theorem many_char_eq_done_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} :
    many_char p cb n = parse_result.done n' string.empty ↔
        n = n' ∧
          ∃ (err : dlist string),
            p cb n = parse_result.fail n err ∨
              ∃ (np : ℕ),
                ∃ (c : char),
                  p cb n = parse_result.done np c ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np =
                      parse_result.fail n err :=
  sorry

theorem many_char_eq_done_not_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char}
    {s : string} (h : s ≠ string.empty) :
    many_char p cb n = parse_result.done n' s ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np (string.head s) ∧
            foldr_core List.cons p [] (buffer.size cb - n) cb np =
              parse_result.done n' (string.to_list (string.popn s 1)) :=
  sorry

theorem many_char_eq_many_of_to_list {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char}
    {s : string} :
    many_char p cb n = parse_result.done n' s ↔
        many p cb n = parse_result.done n' (string.to_list s) :=
  sorry

theorem many'_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many' p cb n = parse_result.done n' Unit.unit ↔
        many p cb n = parse_result.done n' [] ∨
          ∃ (np : ℕ),
            ∃ (a : α),
              ∃ (l : List α),
                many p cb n = parse_result.done n' (a :: l) ∧
                  p cb n = parse_result.done np a ∧
                    foldr_core List.cons p [] (buffer.size cb - n) cb np = parse_result.done n' l :=
  sorry

@[simp] theorem many1_ne_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α} :
    many1 p cb n ≠ parse_result.done n' [] :=
  sorry

theorem many1_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} {p : parser α}
    {l : List α} :
    many1 p cb n = parse_result.done n' (a :: l) ↔
        ∃ (np : ℕ), p cb n = parse_result.done np a ∧ many p cb np = parse_result.done n' l :=
  sorry

theorem many1_eq_fail {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser α}
    {err : dlist string} :
    many1 p cb n = parse_result.fail n' err ↔
        p cb n = parse_result.fail n' err ∨
          ∃ (np : ℕ),
            ∃ (a : α), p cb n = parse_result.done np a ∧ many p cb np = parse_result.fail n' err :=
  sorry

@[simp] theorem many_char1_ne_empty {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} :
    many_char1 p cb n ≠ parse_result.done n' string.empty :=
  sorry

theorem many_char1_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} {p : parser char} {s : string}
    (h : s ≠ string.empty) :
    many_char1 p cb n = parse_result.done n' s ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np (string.head s) ∧
            many_char p cb np = parse_result.done n' (string.popn s 1) :=
  sorry

@[simp] theorem sep_by1_ne_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ}
    {sep : parser Unit} {p : parser α} : sep_by1 sep p cb n ≠ parse_result.done n' [] :=
  sorry

theorem sep_by1_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α} {sep : parser Unit}
    {p : parser α} {l : List α} :
    sep_by1 sep p cb n = parse_result.done n' (a :: l) ↔
        ∃ (np : ℕ),
          p cb n = parse_result.done np a ∧ many (sep >> p) cb np = parse_result.done n' l :=
  sorry

theorem sep_by_eq_done_nil {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {sep : parser Unit}
    {p : parser α} :
    sep_by sep p cb n = parse_result.done n' [] ↔
        n = n' ∧ ∃ (err : dlist string), sep_by1 sep p cb n = parse_result.fail n err :=
  sorry

@[simp] theorem fix_core_ne_done_zero {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {F : parser α → parser α} : fix_core F 0 cb n ≠ parse_result.done n' a :=
  sorry

theorem fix_core_eq_done {α : Type} {cb : char_buffer} {n : ℕ} {n' : ℕ} {a : α}
    {F : parser α → parser α} {max_depth : ℕ} :
    fix_core F (max_depth + 1) cb n = parse_result.done n' a ↔
        F (fix_core F max_depth) cb n = parse_result.done n' a :=
  sorry

theorem digit_eq_done {cb : char_buffer} {n : ℕ} {n' : ℕ} (hn : n < buffer.size cb) {k : ℕ} :
    digit cb n = parse_result.done n' k ↔
        n' = n + 1 ∧
          k ≤ bit1 (bit0 (bit0 1)) ∧
            char.to_nat (buffer.read cb { val := n, property := hn }) -
                  char.to_nat (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit1 1)))))) =
                k ∧
              char.of_nat (bit0 (bit0 (bit0 (bit0 (bit1 1))))) ≤
                  buffer.read cb { val := n, property := hn } ∧
                buffer.read cb { val := n, property := hn } ≤
                  char.of_nat (bit1 (bit0 (bit0 (bit1 (bit1 1))))) :=
  sorry

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yury Kudryashov, Floris van Doorn
-/
import tactic.transform_decl
import tactic.algebra
import tactic.lint.basic

/-!
# Transport multiplicative to additive

This file defines an attribute `to_additive` that can be used to
automatically transport theorems and definitions (but not inductive
types and structures) from a multiplicative theory to an additive theory.

Usage information is contained in the doc string of `to_additive.attr`.

### Missing features

* Automatically transport structures and other inductive types.

* For structures, automatically generate theorems like `group α ↔
  add_group (additive α)`.
-/

namespace to_additive
open tactic
setup_tactic_parser

section performance_hack -- see Note [user attribute parameters]

local attribute [semireducible] reflected

/-- Temporarily change the `has_reflect` instance for `name`. -/
local attribute [instance, priority 9000]
meta def hacky_name_reflect : has_reflect name :=
λ n, `(id %%(expr.const n []) : name)

/-- An auxiliary attribute used to store the names of the additive versions of declarations
that have been processed by `to_additive`. -/
@[user_attribute]
meta def aux_attr : user_attribute (name_map name) name :=
{ name      := `to_additive_aux,
  descr     := "Auxiliary attribute for `to_additive`. DON'T USE IT",
  parser    := failed,
  cache_cfg := ⟨λ ns,
                ns.mfoldl
                  (λ dict n', do
                   let n := match n' with
                            | name.mk_string s pre := if s = "_to_additive" then pre else n'
                            | _ := n'
                            end,
                    param ← aux_attr.get_param_untyped n',
                    pure $ dict.insert n param.app_arg.const_name)
                  mk_name_map, []⟩ }

end performance_hack

section extra_attributes

/--
An attribute that tells `@[to_additive]` that certain arguments of this definition are not
involved when using `@[to_additive]`.
This helps the heuristic of `@[to_additive]` by also transforming definitions if `ℕ` or another
fixed type occurs as one of these arguments.
-/
@[user_attribute]
meta def ignore_args_attr : user_attribute (name_map $ list ℕ) (list ℕ) :=
{ name      := `to_additive_ignore_args,
  descr     :=
    "Auxiliary attribute for `to_additive` stating that certain arguments are not additivized.",
  cache_cfg :=
    ⟨λ ns, ns.mfoldl
      (λ dict n, do
        param ← ignore_args_attr.get_param_untyped n, -- see Note [user attribute parameters]
        return $ dict.insert n (param.to_list expr.to_nat).iget)
      mk_name_map, []⟩,
  parser    := (lean.parser.small_nat)* }

/--
An attribute that is automatically added to declarations tagged with `@[to_additive]`, if needed.

This attribute tells which argument is the type where this declaration uses the multiplicative
structure. If there are multiple argument, we typically tag the first one.
If this argument contains a fixed type, this declaration will note be additivized.
See the Heuristics section of `to_additive.attr` for more details.

If a declaration is not tagged, it is presumed that the first argument is relevant.
`@[to_additive]` uses the function `to_additive.first_multiplicative_arg` to automatically tag
declarations. It is ok to update it manually if the automatic tagging made an error.

Implementation note: we only allow exactly 1 relevant argument, even though some declarations
(like `prod.group`) have multiple arguments with a multiplicative structure on it.
The reason is that whether we additivize a declaration is an all-or-nothing decision, and if
we will not be able to additivize declarations that (e.g.) talk about multiplication on `ℕ × α`
anyway.

Warning: adding `@[to_additive_reorder]` with an equal or smaller number than the number in this
attribute is currently not supported.
-/
@[user_attribute]
meta def relevant_arg_attr : user_attribute (name_map ℕ) ℕ :=
{ name      := `to_additive_relevant_arg,
  descr     :=
    "Auxiliary attribute for `to_additive` stating which arguments are the types with a " ++
    "multiplicative structure.",
  cache_cfg :=
    ⟨λ ns, ns.mfoldl
      (λ dict n, do
        param ← relevant_arg_attr.get_param_untyped n, -- see Note [user attribute parameters]
        -- we subtract 1 from the values provided by the user.
        return $ dict.insert n $ param.to_nat.iget.pred)
      mk_name_map, []⟩,
  parser    := lean.parser.small_nat }

/--
An attribute that stores all the declarations that needs their arguments reordered when
applying `@[to_additive]`. Currently, we only support swapping consecutive arguments.
The list of the natural numbers contains the positions of the first of the two arguments
to be swapped.
If the first two arguments are swapped, the first two universe variables are also swapped.
Example: `@[to_additive_reorder 1 4]` swaps the first two arguments and the arguments in
positions 4 and 5.
-/
@[user_attribute]
meta def reorder_attr : user_attribute (name_map $ list ℕ) (list ℕ) :=
{ name      := `to_additive_reorder,
  descr     :=
    "Auxiliary attribute for `to_additive` that stores arguments that need to be reordered.",
  cache_cfg :=
    ⟨λ ns, ns.mfoldl
      (λ dict n, do
        param ← reorder_attr.get_param_untyped n, -- see Note [user attribute parameters]
        return $ dict.insert n (param.to_list expr.to_nat).iget)
      mk_name_map, []⟩,
  parser    := do
    l ← (lean.parser.small_nat)*,
    guard (l.all (≠ 0)) <|> exceptional.fail "The reorder positions must be positive",
    return l }

end extra_attributes

/--
Find the first argument of `nm` that has a multiplicative type-class on it.
Returns 1 if there are no types with a multiplicative class as arguments.
E.g. `prod.group` returns 1, and `pi.has_one` returns 2.
-/
meta def first_multiplicative_arg (nm : name) : tactic ℕ := do
  d ← get_decl nm,
  let (es, _) := d.type.pi_binders,
  l ← es.mmap_with_index $ λ n bi, do
  { let tgt := bi.type.pi_codomain,
    let n_bi := bi.type.pi_binders.fst.length,
    tt ← has_attribute' `to_additive tgt.get_app_fn.const_name | return none,
    let n2 := tgt.get_app_args.head.get_app_fn.match_var.map $ λ m, n + n_bi - m,
    return $ n2 },
  let l := l.reduce_option,
  return $ if l = [] then 1 else l.foldr min l.head

/-- A command that can be used to have future uses of `to_additive` change the `src` namespace
to the `tgt` namespace.

For example:
```
run_cmd to_additive.map_namespace `quotient_group `quotient_add_group
```

Later uses of `to_additive` on declarations in the `quotient_group` namespace will be created
in the `quotient_add_group` namespaces.
-/
meta def map_namespace (src tgt : name) : command :=
do let n := src.mk_string "_to_additive",
   let decl := declaration.thm n [] `(unit) (pure (reflect ())),
   add_decl decl,
   aux_attr.set n tgt tt

/-- `value_type` is the type of the arguments that can be provided to `to_additive`.
`to_additive.parser` parses the provided arguments:
* `replace_all`: replace all multiplicative declarations, do not use the heuristic.
* `trace`: output the generated additive declaration.
* `tgt : name`: the name of the target (the additive declaration).
* `doc`: an optional doc string.
* if `allow_auto_name` is `ff` (default) then `@[to_additive]` will check whether the given name
  can be auto-generated.
-/
@[derive has_reflect, derive inhabited]
structure value_type : Type :=
(replace_all : bool)
(trace : bool)
(tgt : name)
(doc : option string)
(allow_auto_name : bool)

/-- `add_comm_prefix x s` returns `"comm_" ++ s` if `x = tt` and `s` otherwise. -/
meta def add_comm_prefix : bool → string → string
| tt s := "comm_" ++ s
| ff s := s

/-- Dictionary used by `to_additive.guess_name` to autogenerate names. -/
meta def tr : bool → list string → list string
| is_comm ("one" :: "le" :: s)        := add_comm_prefix is_comm "nonneg"    :: tr ff s
| is_comm ("one" :: "lt" :: s)        := add_comm_prefix is_comm "pos"       :: tr ff s
| is_comm ("le" :: "one" :: s)        := add_comm_prefix is_comm "nonpos"    :: tr ff s
| is_comm ("lt" :: "one" :: s)        := add_comm_prefix is_comm "neg"       :: tr ff s
| is_comm ("mul" :: "single" :: s)    := add_comm_prefix is_comm "single"    :: tr ff s
| is_comm ("mul" :: "support" :: s)   := add_comm_prefix is_comm "support"   :: tr ff s
| is_comm ("mul" :: "tsupport" :: s)  := add_comm_prefix is_comm "tsupport"  :: tr ff s
| is_comm ("mul" :: "indicator" :: s) := add_comm_prefix is_comm "indicator" :: tr ff s
| is_comm ("mul" :: s)                := add_comm_prefix is_comm "add"       :: tr ff s
| is_comm ("smul" :: s)               := add_comm_prefix is_comm "vadd"      :: tr ff s
| is_comm ("inv" :: s)                := add_comm_prefix is_comm "neg"       :: tr ff s
| is_comm ("div" :: s)                := add_comm_prefix is_comm "sub"       :: tr ff s
| is_comm ("one" :: s)                := add_comm_prefix is_comm "zero"      :: tr ff s
| is_comm ("prod" :: s)               := add_comm_prefix is_comm "sum"       :: tr ff s
| is_comm ("finprod" :: s)            := add_comm_prefix is_comm "finsum"    :: tr ff s
| is_comm ("pow" :: s)                := add_comm_prefix is_comm "nsmul"     :: tr ff s
| is_comm ("npow" :: s)               := add_comm_prefix is_comm "nsmul"     :: tr ff s
| is_comm ("zpow" :: s)               := add_comm_prefix is_comm "zsmul"     :: tr ff s
| is_comm ("is" :: "square" :: s)     := add_comm_prefix is_comm "even"      :: tr ff s
| is_comm ("is" :: "regular" :: s)    := add_comm_prefix is_comm "is_add_regular"   :: tr ff s
| is_comm ("is" :: "left" :: "regular" :: s)  :=
  add_comm_prefix is_comm "is_add_left_regular"  :: tr ff s
| is_comm ("is" :: "right" :: "regular" :: s) :=
  add_comm_prefix is_comm "is_add_right_regular" :: tr ff s
| is_comm ("monoid" :: s)      := ("add_" ++ add_comm_prefix is_comm "monoid")    :: tr ff s
| is_comm ("submonoid" :: s)   := ("add_" ++ add_comm_prefix is_comm "submonoid") :: tr ff s
| is_comm ("group" :: s)       := ("add_" ++ add_comm_prefix is_comm "group")     :: tr ff s
| is_comm ("subgroup" :: s)    := ("add_" ++ add_comm_prefix is_comm "subgroup")  :: tr ff s
| is_comm ("semigroup" :: s)   := ("add_" ++ add_comm_prefix is_comm "semigroup") :: tr ff s
| is_comm ("magma" :: s)       := ("add_" ++ add_comm_prefix is_comm "magma")     :: tr ff s
| is_comm ("haar" :: s)        := ("add_" ++ add_comm_prefix is_comm "haar")      :: tr ff s
| is_comm ("prehaar" :: s)     := ("add_" ++ add_comm_prefix is_comm "prehaar")   :: tr ff s
| is_comm ("unit" :: s)        := ("add_" ++ add_comm_prefix is_comm "unit")      :: tr ff s
| is_comm ("units" :: s)       := ("add_" ++ add_comm_prefix is_comm "units")     :: tr ff s
| is_comm ("comm" :: s)        := tr tt s
| is_comm (x :: s)             := (add_comm_prefix is_comm x :: tr ff s)
| tt []                        := ["comm"]
| ff []                        := []

/-- Autogenerate target name for `to_additive`. -/
meta def guess_name : string → string :=
string.map_tokens ''' $
λ s, string.intercalate (string.singleton '_') $
tr ff (s.split_on '_')

/-- Return the provided target name or autogenerate one if one was not provided. -/
meta def target_name (src tgt : name) (dict : name_map name) (allow_auto_name : bool) :
  tactic name :=
(if tgt.get_prefix ≠ name.anonymous ∨ allow_auto_name -- `tgt` is a full name
 then pure tgt
 else match src with
      | (name.mk_string s pre) :=
        do let tgt_auto := guess_name s,
           guard (tgt.to_string ≠ tgt_auto ∨ tgt = src)
             <|> trace ("`to_additive " ++ src.to_string ++ "`: correctly autogenerated target " ++
               "name, you may remove the explicit " ++ tgt_auto ++ " argument."),
           pure $ name.mk_string
                 (if tgt = name.anonymous then tgt_auto else tgt.to_string)
                 (pre.map_prefix dict.find)
      | _ := fail ("to_additive: can't transport " ++ src.to_string)
      end) >>=
(λ res,
  if res = src ∧ tgt ≠ src
  then fail ("to_additive: can't transport " ++ src.to_string ++ " to itself.
Give the desired additive name explicitly using `@[to_additive additive_name]`. ")
  else pure res)

/-- the parser for the arguments to `to_additive`. -/
meta def parser : lean.parser value_type :=
do
  bang ← option.is_some <$> (tk "!")?,
  ques ← option.is_some <$> (tk "?")?,
  tgt ← ident?,
  e ← texpr?,
  doc ← match e with
      | some pe := some <$> ((to_expr pe >>= eval_expr string) : tactic string)
      | none := pure none
      end,
  return ⟨bang, ques, tgt.get_or_else name.anonymous, doc, ff⟩

private meta def proceed_fields_aux (src tgt : name) (prio : ℕ) (f : name → tactic (list string)) :
  command :=
do
  src_fields ← f src,
  tgt_fields ← f tgt,
  guard (src_fields.length = tgt_fields.length) <|>
    fail ("Failed to map fields of " ++ src.to_string),
  (src_fields.zip tgt_fields).mmap' $
    λ names, guard (names.fst = names.snd) <|>
      aux_attr.set (src.append names.fst) (tgt.append names.snd) tt prio

/-- Add the `aux_attr` attribute to the structure fields of `src`
so that future uses of `to_additive` will map them to the corresponding `tgt` fields. -/
meta def proceed_fields (env : environment) (src tgt : name) (prio : ℕ) : command :=
let aux := proceed_fields_aux src tgt prio in
do
aux (λ n, pure $ list.map name.to_string $ (env.structure_fields n).get_or_else []) >>
aux (λ n, (list.map (λ (x : name), "to_" ++ x.to_string) <$> get_tagged_ancestors n)) >>
aux (λ n, (env.constructors_of n).mmap $
          λ cs, match cs with
                | (name.mk_string s pre) :=
                  (guard (pre = n) <|> fail "Bad constructor name") >>
                  pure s
                | _ := fail "Bad constructor name"
                end)

/--
The attribute `to_additive` can be used to automatically transport theorems
and definitions (but not inductive types and structures) from a multiplicative
theory to an additive theory.

To use this attribute, just write:

```
@[to_additive]
theorem mul_comm' {α} [comm_semigroup α] (x y : α) : x * y = y * x := comm_semigroup.mul_comm
```

This code will generate a theorem named `add_comm'`. It is also
possible to manually specify the name of the new declaration:

```
@[to_additive add_foo]
theorem foo := sorry
```

An existing documentation string will _not_ be automatically used, so if the theorem or definition
has a doc string, a doc string for the additive version should be passed explicitly to
`to_additive`.

```
/-- Multiplication is commutative -/
@[to_additive "Addition is commutative"]
theorem mul_comm' {α} [comm_semigroup α] (x y : α) : x * y = y * x := comm_semigroup.mul_comm
```

The transport tries to do the right thing in most cases using several
heuristics described below.  However, in some cases it fails, and
requires manual intervention.

If the declaration to be transported has attributes which need to be
copied to the additive version, then `to_additive` should come last:

```
@[simp, to_additive] lemma mul_one' {G : Type*} [group G] (x : G) : x * 1 = x := mul_one x
```

The following attributes are supported and should be applied correctly by `to_additive` to
the new additivized declaration, if they were present on the original one:
```
reducible, _refl_lemma, simp, norm_cast, instance, refl, symm, trans, elab_as_eliminator, no_rsimp,
continuity, ext, ematch, measurability, alias, _ext_core, _ext_lemma_core, nolint
```

The exception to this rule is the `simps` attribute, which should come after `to_additive`:

```
@[to_additive, simps]
instance {M N} [has_mul M] [has_mul N] : has_mul (M × N) := ⟨λ p q, ⟨p.1 * q.1, p.2 * q.2⟩⟩
```

Additionally the `mono` attribute is not handled by `to_additive` and should be applied afterwards
to both the original and additivized lemma.

## Implementation notes

The transport process generally works by taking all the names of
identifiers appearing in the name, type, and body of a declaration and
creating a new declaration by mapping those names to additive versions
using a simple string-based dictionary and also using all declarations
that have previously been labeled with `to_additive`.

In the `mul_comm'` example above, `to_additive` maps:
* `mul_comm'` to `add_comm'`,
* `comm_semigroup` to `add_comm_semigroup`,
* `x * y` to `x + y` and `y * x` to `y + x`, and
* `comm_semigroup.mul_comm'` to `add_comm_semigroup.add_comm'`.

### Heuristics

`to_additive` uses heuristics to determine whether a particular identifier has to be
mapped to its additive version. The basic heuristic is

* Only map an identifier to its additive version if its first argument doesn't
  contain any unapplied identifiers.

Examples:
* `@has_mul.mul ℕ n m` (i.e. `(n * m : ℕ)`) will not change to `+`, since its
  first argument is `ℕ`, an identifier not applied to any arguments.
* `@has_mul.mul (α × β) x y` will change to `+`. It's first argument contains only the identifier
  `prod`, but this is applied to arguments, `α` and `β`.
* `@has_mul.mul (α × ℤ) x y` will not change to `+`, since its first argument contains `ℤ`.

The reasoning behind the heuristic is that the first argument is the type which is "additivized",
and this usually doesn't make sense if this is on a fixed type.

There are some exceptions to this heuristic:

* Identifiers that have the `@[to_additive]` attribute are ignored.
  For example, multiplication in `↥Semigroup` is replaced by addition in `↥AddSemigroup`.
* If an identifier `d` has attribute `@[to_additive_relevant_arg n]` then the argument
  in position `n` is checked for a fixed type, instead of checking the first argument.
  `@[to_additive]` will automatically add the attribute `@[to_additive_relevant_arg n]` to a
  declaration when the first argument has no multiplicative type-class, but argument `n` does.
* If an identifier has attribute `@[to_additive_ignore_args n1 n2 ...]` then all the arguments in
  positions `n1`, `n2`, ... will not be checked for unapplied identifiers (start counting from 1).
  For example, `cont_mdiff_map` has attribute `@[to_additive_ignore_args 21]`, which means
  that its 21st argument `(n : with_top ℕ)` can contain `ℕ`
  (usually in the form `has_top.top ℕ ...`) and still be additivized.
  So `@has_mul.mul (C^∞⟮I, N; I', G⟯) _ f g` will be additivized.

### Troubleshooting

If `@[to_additive]` fails because the additive declaration raises a type mismatch, there are
various things you can try.
The first thing to do is to figure out what `@[to_additive]` did wrong by looking at the type
mismatch error.

* Option 1: It additivized a declaration `d` that should remain multiplicative. Solution:
  * Make sure the first argument of `d` is a type with a multiplicative structure. If not, can you
    reorder the (implicit) arguments of `d` so that the first argument becomes a type with a
    multiplicative structure (and not some indexing type)?
    The reason is that `@[to_additive]` doesn't additivize declarations if their first argument
    contains fixed types like `ℕ` or `ℝ`. See section Heuristics.
    If the first argument is not the argument with a multiplicative type-class, `@[to_additive]`
    should have automatically added the attribute `@[to_additive_relevant_arg]` to the declaration.
    You can test this by running the following (where `d` is the full name of the declaration):
    ```
      run_cmd to_additive.relevant_arg_attr.get_param `d >>= tactic.trace
    ```
    The expected output is `n` where the `n`-th argument of `d` is a type (family) with a
    multiplicative structure on it. If you get a different output (or a failure), you could add
    the attribute `@[to_additive_relevant_arg n]` manually, where `n` is an argument with a
    multiplicative structure.
* Option 2: It didn't additivize a declaration that should be additivized.
  This happened because the heuristic applied, and the first argument contains a fixed type,
  like `ℕ` or `ℝ`. Solutions:
  * If the fixed type has an additive counterpart (like `↥Semigroup`), give it the `@[to_additive]`
    attribute.
  * If the fixed type occurs inside the `k`-th argument of a declaration `d`, and the
    `k`-th argument is not connected to the multiplicative structure on `d`, consider adding
    attribute `[to_additive_ignore_args k]` to `d`.
  * If you want to disable the heuristic and replace all multiplicative
    identifiers with their additive counterpart, use `@[to_additive!]`.
* Option 3: Arguments / universe levels are incorrectly ordered in the additive version.
  This likely only happens when the multiplicative declaration involves `pow`/`^`. Solutions:
  * Ensure that the order of arguments of all relevant declarations are the same for the
    multiplicative and additive version. This might mean that arguments have an "unnatural" order
    (e.g. `monoid.npow n x` corresponds to `x ^ n`, but it is convenient that `monoid.npow` has this
    argument order, since it matches `add_monoid.nsmul n x`.
  * If this is not possible, add the `[to_additive_reorder k]` to the multiplicative declaration
    to indicate that the `k`-th and `(k+1)`-st arguments are reordered in the additive version.

If neither of these solutions work, and `to_additive` is unable to automatically generate the
additive version of a declaration, manually write and prove the additive version.
Often the proof of a lemma/theorem can just be the multiplicative version of the lemma applied to
`multiplicative G`.
Afterwards, apply the attribute manually:

```
attribute [to_additive foo_add_bar] foo_bar
```

This will allow future uses of `to_additive` to recognize that
`foo_bar` should be replaced with `foo_add_bar`.

### Handling of hidden definitions

Before transporting the “main” declaration `src`, `to_additive` first
scans its type and value for names starting with `src`, and transports
them. This includes auxiliary definitions like `src._match_1`,
`src._proof_1`.

In addition to transporting the “main” declaration, `to_additive` transports
its equational lemmas and tags them as equational lemmas for the new declaration,
attributes present on the original equational lemmas are also transferred first (notably
`_refl_lemma`).

### Structure fields and constructors

If `src` is a structure, then `to_additive` automatically adds
structure fields to its mapping, and similarly for constructors of
inductive types.

For new structures this means that `to_additive` automatically handles
coercions, and for old structures it does the same, if ancestry
information is present in `@[ancestor]` attributes. The `ancestor`
attribute must come before the `to_additive` attribute, and it is
essential that the order of the base structures passed to `ancestor` matches
between the multiplicative and additive versions of the structure.

### Name generation

* If `@[to_additive]` is called without a `name` argument, then the
  new name is autogenerated.  First, it takes the longest prefix of
  the source name that is already known to `to_additive`, and replaces
  this prefix with its additive counterpart. Second, it takes the last
  part of the name (i.e., after the last dot), and replaces common
  name parts (“mul”, “one”, “inv”, “prod”) with their additive versions.

* Namespaces can be transformed using `map_namespace`. For example:
  ```
  run_cmd to_additive.map_namespace `quotient_group `quotient_add_group
  ```

  Later uses of `to_additive` on declarations in the `quotient_group`
  namespace will be created in the `quotient_add_group` namespaces.

* If `@[to_additive]` is called with a `name` argument `new_name`
  /without a dot/, then `to_additive` updates the prefix as described
  above, then replaces the last part of the name with `new_name`.

* If `@[to_additive]` is called with a `name` argument
  `new_namespace.new_name` /with a dot/, then `to_additive` uses this
  new name as is.

As a safety check, in the first case `to_additive` double checks
that the new name differs from the original one.

-/
@[user_attribute]
protected meta def attr : user_attribute unit value_type :=
{ name      := `to_additive,
  descr     := "Transport multiplicative to additive",
  parser    := parser,
  after_set := some $ λ src prio persistent, do
    guard persistent <|> fail "`to_additive` can't be used as a local attribute",
    env ← get_env,
    val ← attr.get_param src,
    dict ← aux_attr.get_cache,
    ignore ← ignore_args_attr.get_cache,
    relevant ← relevant_arg_attr.get_cache,
    reorder ← reorder_attr.get_cache,
    tgt ← target_name src val.tgt dict val.allow_auto_name,
    aux_attr.set src tgt tt,
    let dict := dict.insert src tgt,
    first_mult_arg ← first_multiplicative_arg src,
    when (first_mult_arg ≠ 1) $ relevant_arg_attr.set src first_mult_arg tt,
    if env.contains tgt
    then proceed_fields env src tgt prio
    else do
      transform_decl_with_prefix_dict dict val.replace_all val.trace relevant ignore reorder src tgt
        [`reducible, `_refl_lemma, `simp, `norm_cast, `instance, `refl, `symm, `trans,
          `elab_as_eliminator, `no_rsimp, `continuity, `ext, `ematch, `measurability, `alias,
          `_ext_core, `_ext_lemma_core, `nolint, `protected],
      mwhen (has_attribute' `simps src)
        (trace "Apply the simps attribute after the to_additive attribute"),
      mwhen (has_attribute' `mono src)
        (trace $ "to_additive does not work with mono, apply the mono attribute to both" ++
          "versions after"),
      match val.doc with
      | some doc := add_doc_string tgt doc
      | none := skip
      end }

add_tactic_doc
{ name                     := "to_additive",
  category                 := doc_category.attr,
  decl_names               := [`to_additive.attr],
  tags                     := ["transport", "environment", "lemma derivation"] }

end to_additive

/- map operations -/
attribute [to_additive] has_mul has_one has_inv has_div
/- the following types are supported by `@[to_additive]` and mapped to themselves. -/
attribute [to_additive empty] empty
attribute [to_additive pempty] pempty
attribute [to_additive punit] punit
attribute [to_additive unit] unit

section linter

open tactic expr

/-- A linter that checks that multiplicative and additive lemmas have both doc strings if one of
them has one -/
@[linter] meta def linter.to_additive_doc : linter :=
{ test := (λ d, do
    let mul_name := d.to_name,
    dict ← to_additive.aux_attr.get_cache,
    match dict.find mul_name with
    | some add_name := do
      mul_doc ← try_core $ doc_string mul_name,
      add_doc ← try_core $ doc_string add_name,
      match mul_doc.is_some, add_doc.is_some with
      | tt, ff := return $ some $ "declaration has a docstring, but its additive version `" ++
          add_name.to_string ++ "` does not. You might want to pass a string argument to " ++
          "`to_additive`."
      | ff, tt := return $ some $ "declaration has no docstring, but its additive version `" ++
          add_name.to_string ++ "` does. You might want to add a doc string to the declaration."
      | _, _ := return none
      end
    | none := return none
    end),
  auto_decls := ff,
  no_errors_found := "Multiplicative and additive lemmas are consistently documented",
  errors_found := "The following declarations have doc strings, but their additive versions do " ++
  "not (or vice versa).",
  is_fast := ff }

end linter