/-
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, Jon Eugster
Ported by: E.W.Ayers
-/
import Mathlib.Init.Data.Nat.Notation
import Mathlib.Data.String.Defs
import Mathlib.Data.KVMap
import Mathlib.Lean.Expr.ReplaceRec
import Mathlib.Lean.EnvExtension
import Mathlib.Lean.Meta.Simp
import Std.Lean.NameMapAttribute
import Std.Data.Option.Basic
import Std.Tactic.CoeExt -- just to copy the attribute
import Std.Tactic.Ext.Attr -- just to copy the attribute
import Std.Tactic.Lint -- useful to lint this file and for for DiscrTree.elements
import Mathlib.Tactic.Relation.Rfl -- just to copy the attribute
import Mathlib.Tactic.Relation.Symm -- just to copy the attribute
import Mathlib.Tactic.Relation.Trans -- just to copy the attribute
import Mathlib.Tactic.Simps.Basic

/-!
# The `@[to_additive]` attribute.

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

open Lean Meta Elab Command Std

/-- The  `to_additive_ignore_args` attribute. -/
syntax (name := to_additive_ignore_args) "to_additive_ignore_args" num* : attr
/-- The  `to_additive_relevant_arg` attribute. -/
syntax (name := to_additive_relevant_arg) "to_additive_relevant_arg" num : attr
/-- The  `to_additive_reorder` attribute. -/
syntax (name := to_additive_reorder) "to_additive_reorder" num* : attr
/-- The  `to_additive_change_numeral` attribute. -/
syntax (name := to_additive_change_numeral) "to_additive_change_numeral" num* : attr
/-- An `attr := ...` option for `to_additive`. -/
syntax toAdditiveAttrOption := &"attr" ":=" Parser.Term.attrInstance,*
/-- An `reorder := ...` option for `to_additive`. -/
syntax toAdditiveReorderOption := &"reorder" ":=" num+
/-- Options to `to_additive`. -/
syntax toAdditiveParenthesizedOption := "(" toAdditiveAttrOption <|> toAdditiveReorderOption ")"
/-- Options to `to_additive`. -/
syntax toAdditiveOption := toAdditiveParenthesizedOption <|> &"existing"
/-- Remaining arguments of `to_additive`. -/
syntax toAdditiveRest := toAdditiveOption* (ppSpace ident)? (ppSpace str)?
/-- The `to_additive` attribute. -/
syntax (name := to_additive) "to_additive" "?"? toAdditiveRest : attr

/-- The `to_additive` attribute. -/
macro "to_additive?" rest:toAdditiveRest : attr => `(attr| to_additive ? $rest)

/-- A set of strings of names that end in a capital letter.
* If the string contains a lowercase letter, the string should be split between the first occurrence
  of a lower-case letter followed by a upper-case letter.
* If multiple strings have the same prefix, they should be grouped by prefix
* In this case, the second list should be prefix-free
  (no element can be a prefix of a later element)

Todo: automate the translation from `String` to an element in this `RBMap`
  (but this would require having something similar to the `rb_lmap` from Lean 3). -/
def endCapitalNames : Lean.RBMap String (List String) compare :=
-- todo: we want something like
-- endCapitalNamesOfList ["LE", "LT", "WF", "CoeTC", "CoeT", "CoeHTCT"]
.ofList [("LE", [""]), ("LT", [""]), ("WF", [""]), ("Coe", ["TC", "T", "HTCT"])]

/--
This function takes a String and splits it into separate parts based on the following
(naming conventions)[https://github.com/leanprover-community/mathlib4/wiki#naming-convention].

E.g. `#eval  "InvHMulLEConjugate₂SMul_ne_top".splitCase` yields
`["Inv", "HMul", "LE", "Conjugate₂", "SMul", "_", "ne", "_", "top"]`.
-/
partial def String.splitCase (s : String) (i₀ : Pos := 0) (r : List String := []) : List String :=
Id.run do
  -- We test if we need to split between `i₀` and `i₁`.
  let i₁ := s.next i₀
  if s.atEnd i₁ then
    -- If `i₀` is the last position, return the list.
    let r := s::r
    return r.reverse
  /- We split the string in three cases
  * We split on both sides of `_` to keep them there when rejoining the string;
  * We split after a name in `endCapitalNames`;
  * We split after a lower-case letter that is followed by an upper-case letter
    (unless it is part of a name in `endCapitalNames`). -/
  if s.get i₀ == '_' || s.get i₁ == '_' then
    return splitCase (s.extract i₁ s.endPos) 0 <| (s.extract 0 i₁)::r
  if (s.get i₁).isUpper then
    if let some strs := endCapitalNames.find? (s.extract 0 i₁) then
      if let some (pref, newS) := strs.findSome?
        fun x ↦ x.isPrefixOf? (s.extract i₁ s.endPos) |>.map (x, ·) then
        return splitCase newS 0 <| (s.extract 0 i₁ ++ pref)::r
    if !(s.get i₀).isUpper then
      return splitCase (s.extract i₁ s.endPos) 0 <| (s.extract 0 i₁)::r
  return splitCase s i₁ r

namespace ToAdditive

initialize registerTraceClass `to_additive
initialize registerTraceClass `to_additive_detail

/-- Linter to check that the reorder attribute is not given manually -/
register_option linter.toAdditiveReorder : Bool := {
  defValue := true
  descr := "Linter to check that the reorder attribute is not given manually." }

/-- Linter, mostly used by `@[to_additive]`, that checks that the source declaration doesn't have
certain attributes -/
register_option linter.existingAttributeWarning : Bool := {
  defValue := true
  descr := "Linter, mostly used by `@[to_additive]`, that checks that the source declaration " ++
    "doesn't have certain attributes" }

/-- Linter to check that the reorder attribute is not given manually -/
register_option linter.toAdditiveGenerateName : Bool := {
  defValue := true
  descr := "Linter used by `@[to_additive]` that checks if `@[to_additive]` automatically " ++
    "generates the user-given name" }

/-- Linter to check whether the user correctly specified that the additive declaration already
exists -/
register_option linter.toAdditiveExisting : Bool := {
  defValue := true
  descr := "Linter used by `@[to_additive]` that checks whether the user correctly specified that
    the additive declaration already exists" }

/--
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.
-/
initialize ignoreArgsAttr : NameMapExtension (List Nat) ←
  registerNameMapAttribute {
    name  := `to_additive_ignore_args
    descr :=
      "Auxiliary attribute for `to_additive` stating that certain arguments are not additivized."
    add   := fun _ stx ↦ do
        let ids ← match stx with
          | `(attr| to_additive_ignore_args $[$ids:num]*) => pure <| ids.map (·.1.isNatLit?.get!)
          | _ => throwUnsupportedSyntax
        return ids.toList }

/--
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.
-/
initialize reorderAttr : NameMapExtension (List Nat) ←
  registerNameMapAttribute {
    name := `to_additive_reorder
    descr :=
      "Auxiliary attribute for `to_additive` that stores arguments that need to be reordered.
        This should not appear in any file.
        We keep it as an attribute for now so that mathport can still use it, and it can generate a
        warning."
    add := fun
    | _, stx@`(attr| to_additive_reorder $[$ids:num]*) => do
      Linter.logLintIf linter.toAdditiveReorder stx
        m!"Using this attribute is deprecated. Use `@[to_additive (reorder := <num>)]` {""
        }instead.\nThat will also generate the additive version with the arguments swapped, {""
        }so you are probably able to remove the manually written additive declaration."
      pure <| Array.toList <| ids.map (·.1.isNatLit?.get!)
    | _, _ => throwUnsupportedSyntax }

/--
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.
-/
initialize relevantArgAttr : NameMapExtension Nat ←
  registerNameMapAttribute {
    name := `to_additive_relevant_arg
    descr := "Auxiliary attribute for `to_additive` stating" ++
      " which arguments are the types with a multiplicative structure."
    add := fun
    | _, `(attr| to_additive_relevant_arg $id) => pure <| id.1.isNatLit?.get!.pred
    | _, _ => throwUnsupportedSyntax }

/--
An attribute that stores all the declarations that deal with numeric literals on variable types.

Numeral literals occur in expressions without type information, so in order to decide whether `1`
needs to be changed to `0`, the context around the numeral is relevant.
Most numerals will be in an `OfNat.ofNat` application, though tactics can add numeral literals
inside arbitrary functions. By default we assume that we do not change numerals, unless it is
in a function application with the `to_additive_change_numeral` attribute.

`@[to_additive_change_numeral n₁ ...]` should be added to all functions that take one or more
numerals as argument that should be changed if `additiveTest` succeeds on the first argument,
i.e. when the numeral is only translated if the first argument is a variable
(or consists of variables).
The arguments `n₁ ...` are the positions of the numeral arguments (starting counting from 1).
-/
initialize changeNumeralAttr : NameMapExtension (List Nat) ←
  registerNameMapAttribute {
    name := `to_additive_change_numeral
    descr :=
      "Auxiliary attribute for `to_additive` that stores functions that have numerals as argument."
    add := fun
    | _, `(attr| to_additive_change_numeral $[$arg]*) =>
      pure <| arg.map (·.1.isNatLit?.get!.pred) |>.toList
    | _, _ => throwUnsupportedSyntax }

/-- Maps multiplicative names to their additive counterparts. -/
initialize translations : NameMapExtension Name ← registerNameMapExtension _

/-- Get the multiplicative → additive translation for the given name. -/
def findTranslation? (env : Environment) : Name → Option Name :=
  (ToAdditive.translations.getState env).find?

/-- Add a (multiplicative → additive) name translation to the translations map. -/
def insertTranslation (src tgt : Name) (failIfExists := true) : CoreM Unit := do
  if let some tgt' := findTranslation? (← getEnv) src then
    if failIfExists then
      throwError "The translation {src} ↦ {tgt'} already exists"
    else
      trace[to_additive] "The translation {src} ↦ {tgt'} already exists"
      return
  modifyEnv (ToAdditive.translations.addEntry · (src, tgt))
  trace[to_additive] "Added translation {src} ↦ {tgt}"

/-- `Config` is the type of the arguments that can be provided to `to_additive`. -/
structure Config : Type where
  /-- View the trace of the to_additive procedure.
  Equivalent to `set_option trace.to_additive true`. -/
  trace : Bool := false
  /-- The name of the target (the additive declaration).-/
  tgt : Name := Name.anonymous
  /-- An optional doc string.-/
  doc : Option String := none
  /-- If `allowAutoName` is `false` (default) then
  `@[to_additive]` will check whether the given name can be auto-generated. -/
  allowAutoName : Bool := false
  /-- The arguments that should be reordered by `to_additive` -/
  reorder : List Nat := []
  /-- The attributes which we want to give to both the multiplicative and additive versions.
  For certain attributes (such as `simp` and `simps`) this will also add generated lemmas to the
  translation dictionary. -/
  attrs : Array Syntax := #[]
  /-- The `Syntax` element corresponding to the original multiplicative declaration
  (or the `to_additive` attribute if it is added later),
  which we need for adding definition ranges. -/
  ref : Syntax
  /-- An optional flag stating whether the additive declaration already exists.
    If this flag is set but wrong about whether the additive declaration exists, `to_additive` will
    raise a linter error.
    Note: the linter will never raise an error for inductive types and structures. -/
  existing : Option Bool := none
  deriving Repr

variable [Monad M] [MonadOptions M] [MonadEnv M]

/-- Auxilliary function for `additiveTest`. The bool argument *only* matters when applied
to exactly a constant. -/
def additiveTestAux (findTranslation? : Name → Option Name)
  (ignore : Name → Option (List ℕ)) : Bool → Expr → Bool := visit where
  /-- see `additiveTestAux` -/
  visit : Bool → Expr → Bool
  | b, .const n _         => b || (findTranslation? n).isSome
  | _, x@(.app e a)       => Id.run do
      if !visit true e then
        return false
      -- make sure that we don't treat `(fun x => α) (n + 1)` as a type that depends on `Nat`
      if x.isConstantApplication then
        return true
      if let some n := e.getAppFn.constName? then
        if let some l := ignore n then
          if e.getAppNumArgs + 1 ∈ l then
            return true
      visit false a
  | _, .lam _ _ t _       => visit false t
  | _, .forallE _ _ t _   => visit false t
  | _, .letE _ _ e body _ => visit false e && visit false body
  | _, _                  => true

/--
`additiveTest e` tests whether the expression `e` contains no constant
`nm` that is not applied to any arguments, and such that `translations.find?[nm] = none`.
This is used in `@[to_additive]` for deciding which subexpressions to transform: we only transform
constants if `additiveTest` applied to their first argument returns `true`.
This means we will replace expression applied to e.g. `α` or `α × β`, but not when applied to
e.g. `ℕ` or `ℝ × α`.
We ignore all arguments specified by the `ignore` `NameMap`.
-/
def additiveTest (findTranslation? : Name → Option Name)
  (ignore : Name → Option (List ℕ)) (e : Expr) : Bool :=
  additiveTestAux findTranslation? ignore false e

/-- Swap the first two elements of a list -/
def _root_.List.swapFirstTwo {α : Type _} : List α → List α
| []      => []
| [x]     => [x]
| x::y::l => y::x::l

/-- Change the numeral `nat_lit 1` to the numeral `nat_lit 0`.
Leave all other expressions unchanged. -/
def changeNumeral : Expr → Expr
| .lit (.natVal 1) => mkRawNatLit 0
| e                => e

/--
`applyReplacementFun e` replaces the expression `e` with its additive counterpart.
It translates each identifier (inductive type, defined function etc) in an expression, unless
* The identifier occurs in an application with first argument `arg`; and
* `test arg` is false.
However, if `f` is in the dictionary `relevant`, then the argument `relevant.find f`
is tested, instead of the first argument.

It will also reorder arguments of certain functions, using `reorderFn`:
e.g. `g x₁ x₂ x₃ ... xₙ` becomes `g x₂ x₁ x₃ ... xₙ` if `reorderFn g = some [1]`.
-/
def applyReplacementFun (e : Expr) : MetaM Expr := do
  let env ← getEnv
  let reorderFn : Name → List ℕ := fun nm ↦ (reorderAttr.find? env nm |>.getD [])
  let isRelevant : Name → ℕ → Bool := fun nm i ↦ i == (relevantArgAttr.find? env nm).getD 0
  return aux
      (findTranslation? <| ← getEnv) reorderFn (ignoreArgsAttr.find? env)
      (changeNumeralAttr.find? env) isRelevant (← getBoolOption `trace.to_additive_detail) e
where /-- Implementation of `applyReplacementFun`. -/
  aux (findTranslation? : Name → Option Name)
    (reorderFn : Name → List ℕ) (ignore : Name → Option (List ℕ))
    (changeNumeral? : Name → Option (List Nat)) (isRelevant : Name → ℕ → Bool) (trace : Bool) :
    Expr → Expr :=
  Lean.Expr.replaceRec fun r e ↦ Id.run do
    if trace then
      dbg_trace s!"replacing at {e}"
    match e with
    | .const n₀ ls => do
      let n₁ := n₀.mapPrefix findTranslation?
      if trace && n₀ != n₁ then
        dbg_trace s!"changing {n₀} to {n₁}"
      let ls : List Level := if 1 ∈ reorderFn n₀ then ls.swapFirstTwo else ls
      return some <| Lean.mkConst n₁ ls
    | .app g x => do
      let gf := g.getAppFn
      if gf.isBVar && x.isLit then
        if trace then
          dbg_trace s!"applyReplacementFun: Variables applied to numerals are not changed {g.app x}"
        return some <| g.app x
      if let some nm := gf.constName? then
        let gArgs := g.getAppArgs
        -- e = `(nm y₁ .. yₙ x)
        /- Test if arguments should be reordered. -/
        if h : gArgs.size > 0 then
          let c1 : Bool := gArgs.size ∈ reorderFn nm
          let c2 := additiveTest findTranslation? ignore gArgs[0]
          if c1 && c2 then
            -- interchange `x` and the last argument of `g`
            let x := r x
            let gf := r g.appFn!
            let ga := r g.appArg!
            let e₂ := mkApp2 gf x ga
            if trace then
              dbg_trace s!"reordering {nm}: {x} ↔ {ga}\nBefore: {e}\nAfter: {e₂}"
            return some e₂
        /- Test if the head should not be replaced. -/
        let c1 := isRelevant nm gArgs.size
        let c2 := gf.isConst
        let c3 := additiveTest findTranslation? ignore x
        if trace && c1 && c2 && c3 then
          dbg_trace s!"{x} doesn't contain a fixed type, so we will change {nm}"
        if c1 && c2 && not c3 then
          if trace then
            dbg_trace s!"{x} contains a fixed type, so {nm} is not changed"
          let x ← r x
          let args ← gArgs.mapM r
          return some $ mkApp (mkAppN gf args) x
        /- Do not replace numerals in specific types. -/
        let gAllArgs := gArgs.push x
        let firstArg := gAllArgs[0]
        if let some changedArgNrs := changeNumeral? nm then
          if additiveTest findTranslation? ignore firstArg then
            if trace then
              dbg_trace s!"applyReplacementFun: We change the numerals in {g.app x}. {
                ""}However, we will still recurse into all the non-numeral arguments."
            -- In this case, we still update all arguments of `g` that are not numerals,
            -- since all other arguments can contain subexpressions like
            -- `(fun x ↦ ℕ) (1 : G)`, and we have to update the `(1 : G)` to `(0 : G)`
            let newArgs ← gAllArgs.mapIdx fun argNr arg ↦
              if changedArgNrs.contains argNr then
                r <| changeNumeral arg
              else
                r arg
            return some <| mkAppN gf newArgs
      return e.updateApp! (← r g) (← r x)
    | .proj n₀ idx e => do
      let n₁ := n₀.mapPrefix findTranslation?
      if trace then
        dbg_trace s!"applyReplacementFun: in projection {e}.{idx} of type {n₀}, {""
          }replace type with {n₁}"
      return some <| .proj n₁ idx <| ← r e
    | _ => return none

/-- Eta expands `e` at most `n` times.-/
def etaExpandN (n : Nat) (e : Expr): MetaM Expr := do
  forallBoundedTelescope (← inferType e) (some n) fun xs _ ↦ mkLambdaFVars xs (mkAppN e xs)

/-- `e.expand` eta-expands all expressions that have as head a constant `n` in
`reorder`. They are expanded until they are applied to one more argument than the maximum in
`reorder.find n`. -/
def expand (e : Expr) : MetaM Expr := do
  let env ← getEnv
  let reorderFn : Name → List ℕ := fun nm ↦ (reorderAttr.find? env nm |>.getD [])
  let e₂ ← Lean.Meta.transform (input := e) (post := fun e => return .done e) <| fun e ↦ do
    let e0 := e.getAppFn
    let es := e.getAppArgs
    let some e0n := e0.constName? | return .continue
    let reorder := reorderFn e0n
    if reorder.isEmpty then
      -- no need to expand if nothing needs reordering
      return .continue
    let needed_n := reorder.foldr Nat.max 0 + 1
    -- the second disjunct is a temporary fix to avoid infinite loops.
    -- We may need to use `replaceRec` or something similar to not change the head of an application
    if needed_n ≤ es.size || es.size == 0 then
      return .continue
    else
      -- in this case, we need to reorder arguments that are not yet
      -- applied, so first η-expand the function.
      let e' ← etaExpandN (needed_n - es.size) e
      trace[to_additive_detail] "expanded {e} to {e'}"
      return .continue e'
  if e != e₂ then
    trace[to_additive_detail] "expand:\nBefore: {e}\nAfter:  {e₂}"
  return e₂

/-- Reorder pi-binders. See doc of `reorderAttr` for the interpretation of the argument -/
def reorderForall (src : Expr) (reorder : List Nat := []) : MetaM Expr := do
  if reorder == [] then
    return src
  forallTelescope src fun xs e => do
    let xs ← reorder.foldrM (init := xs) fun i xs =>
      if h : i < xs.size then
        pure <| xs.swap ⟨i - 1, Nat.lt_of_le_of_lt i.pred_le h⟩ ⟨i, h⟩
      else
        throwError "the declaration does not have enough arguments to reorder the given arguments: {
          xs.size} ≤ {i}"
    mkForallFVars xs e

/-- Reorder lambda-binders. See doc of `reorderAttr` for the interpretation of the argument -/
def reorderLambda (src : Expr) (reorder : List Nat := []) : MetaM Expr := do
  if reorder == [] then
    return src
  lambdaTelescope src fun xs e => do
    let xs ← reorder.foldrM (init := xs) fun i xs =>
      if h : i < xs.size then
        pure <| xs.swap ⟨i - 1, Nat.lt_of_le_of_lt i.pred_le h⟩ ⟨i, h⟩
      else
        throwError "the declaration does not have enough arguments to reorder the given arguments. {
          xs.size} ≤ {i}.\nIf this is a field projection, make sure to use `@[to_additive]` on {""
          }the field first."
    mkLambdaFVars xs e

/-- Run applyReplacementFun on the given `srcDecl` to make a new declaration with name `tgt` -/
def updateDecl
  (tgt : Name) (srcDecl : ConstantInfo) (reorder : List Nat := [])
  : MetaM ConstantInfo := do
  let mut decl := srcDecl.updateName tgt
  if 1 ∈ reorder then
    decl := decl.updateLevelParams decl.levelParams.swapFirstTwo
  decl := decl.updateType <| ← applyReplacementFun <| ← reorderForall (← expand decl.type) reorder
  if let some v := decl.value? then
    decl := decl.updateValue <| ← applyReplacementFun <| ← reorderLambda (← expand v) reorder
  return decl

/-- Find the target name of `pre` and all created auxiliary declarations. -/
def findTargetName (env : Environment) (src pre tgt_pre : Name) : CoreM Name :=
  /- This covers auxiliary declarations like `match_i` and `proof_i`. -/
  if let some post := pre.isPrefixOf? src then
    return tgt_pre ++ post
  /- This covers equation lemmas (for other declarations). -/
  else if let some post := privateToUserName? src then
    match findTranslation? env post.getPrefix with
    -- this is an equation lemma for a declaration without `to_additive`. We will skip this.
    | none => return src
    -- this is an equation lemma for a declaration with `to_additive`. We will additivize this.
    -- Note: if this errors we could do this instead by calling `getEqnsFor?`
    | some addName => return src.updatePrefix <| mkPrivateName env addName
  -- Note: this additivizes lemmas generated by `simp`.
  -- Todo: we do not currently check whether such lemmas actually should be additivized.
  else if let some post := env.mainModule ++ `_auxLemma |>.isPrefixOf? src then
    return env.mainModule ++ `_auxAddLemma ++ post
  else
    throwError "internal @[to_additive] error."

/-- Returns a `NameSet` of all auxiliary constants in `e` that might have been generated
when adding `pre` to the environment.
Examples include `pre.match_5`, `Mathlib.MyFile._auxLemma.3` and
`_private.Mathlib.MyFile.someOtherNamespace.someOtherDeclaration._eq_2`.
The last two examples may or may not have been generated by this declaration.
The last example may or may not be the equation lemma of a declaration with the `@[to_additive]`
attribute. We will only translate it has the `@[to_additive]` attribute.
-/
def findAuxDecls (e : Expr) (pre mainModule : Name) : NameSet :=
let auxLemma := mainModule ++ `_auxLemma
e.foldConsts ∅ fun n l ↦
  if n.getPrefix == pre || n.getPrefix == auxLemma || isPrivateName n then
    l.insert n
  else
    l

/-- transform the declaration `src` and all declarations `pre._proof_i` occurring in `src`
using the transforms dictionary.
`replace_all`, `trace`, `ignore` and `reorder` are configuration options.
`pre` is the declaration that got the `@[to_additive]` attribute and `tgt_pre` is the target of this
declaration. -/
partial def transformDeclAux
  (cfg : Config) (pre tgt_pre : Name) : Name → CoreM Unit := fun src ↦ do
  let env ← getEnv
  trace[to_additive_detail] "visiting {src}"
  -- if we have already translated this declaration, we do nothing.
  if (findTranslation? env src).isSome && src != pre then
      return
  -- if this declaration is not `pre` and not an internal declaration, we return an error,
  -- since we should have already translated this declaration.
  if src != pre && !src.isInternal' then
    throwError "The declaration {pre} depends on the declaration {src} which is in the namespace {
      pre}, but does not have the `@[to_additive]` attribute. This is not supported.\n{""
      }Workaround: move {src} to a different namespace."
  -- we find the additive name of `src`
  let tgt ← findTargetName env src pre tgt_pre
  -- we skip if we already transformed this declaration before.
  if env.contains tgt then
    if tgt == src then
      -- Note: this can happen for equation lemmas of declarations without `@[to_additive]`.
      trace[to_additive_detail] "Auxiliary declaration {src} will be translated to itself."
    else
      trace[to_additive_detail] "Already visited {tgt} as translation of {src}."
    return
  let srcDecl ← getConstInfo src
  -- we first transform all auxiliary declarations generated when elaborating `pre`
  for n in findAuxDecls srcDecl.type pre env.mainModule do
    transformDeclAux cfg pre tgt_pre n
  if let some value := srcDecl.value? then
    for n in findAuxDecls value pre env.mainModule do
      transformDeclAux cfg pre tgt_pre n
  -- if the auxilliary declaration doesn't have prefix `pre`, then we have to add this declaration
  -- to the translation dictionary, since otherwise we cannot find the additive name.
  if !pre.isPrefixOf src then
    insertTranslation src tgt
  -- now transform the source declaration
  let trgDecl : ConstantInfo ←
    MetaM.run' <| updateDecl tgt srcDecl <| if src == pre then cfg.reorder else []
  if !trgDecl.hasValue then
    throwError "Expected {tgt} to have a value."
  trace[to_additive] "generating\n{tgt} : {trgDecl.type} :=\n  {trgDecl.value!}"
  try
    -- make sure that the type is correct,
    -- and emit a more helpful error message if it fails
    discard <| MetaM.run' <| inferType trgDecl.value!
  catch
    | Exception.error _ msg => throwError "@[to_additive] failed.
      Type mismatch in additive declaration. For help, see the docstring
      of `to_additive.attr`, section `Troubleshooting`.
      Failed to add declaration\n{tgt}:\n{msg}"
    | _ => panic! "unreachable"
  if isNoncomputable env src then
    addDecl trgDecl.toDeclaration!
    setEnv $ addNoncomputable (← getEnv) tgt
  else
    addAndCompile trgDecl.toDeclaration!
  -- now add declaration ranges so jump-to-definition works
  -- note: we currently also do this for auxiliary declarations, while they are not normally
  -- generated for those. We could change that.
  addDeclarationRanges tgt {
    range := ← getDeclarationRange (← getRef)
    selectionRange := ← getDeclarationRange cfg.ref }
  if isProtected (← getEnv) src then
    setEnv $ addProtected (← getEnv) tgt

/-- Copy the instance attribute in a `to_additive`

[todo] it seems not to work when the `to_additive` is added as an attribute later. -/
def copyInstanceAttribute (src tgt : Name) : CoreM Unit := do
  if (← isInstance src) then
    let prio := (← getInstancePriority? src).getD 100
    let attr_kind := (← getInstanceAttrKind? src).getD .global
    trace[to_additive_detail] "Making {tgt} an instance with priority {prio}."
    addInstance tgt attr_kind prio |>.run'

/-- Warn the user when the multiplicative declaration has an attribute. -/
def warnExt [Inhabited σ] (stx : Syntax) (ext : PersistentEnvExtension α β σ) (f : σ → Name → Bool)
  (thisAttr attrName src tgt : Name) : CoreM Unit := do
  if f (ext.getState (← getEnv)) src then
    Linter.logLintIf linter.existingAttributeWarning stx <|
      m!"The source declaration {src} was given attribute {attrName} before calling @[{thisAttr}]. {
      ""}The preferred method is to use `@[{thisAttr} (attr := {attrName})]` to apply the {
      ""}attribute to both {src} and the target declaration {tgt}." ++
      if thisAttr == `to_additive then
      m!"\nSpecial case: If this declaration was generated by @[to_additive] {
      ""}itself, you can use @[to_additive (attr := to_additive, {attrName})] on the original {
      ""}declaration." else ""

/-- Warn the user when the multiplicative declaration has a simple scoped attribute. -/
def warnAttr [Inhabited β] (stx : Syntax) (attr : SimpleScopedEnvExtension α β)
  (f : β → Name → Bool) (thisAttr attrName src tgt : Name) : CoreM Unit :=
warnExt stx attr.ext (f ·.stateStack.head!.state ·) thisAttr attrName src tgt

/-- Warn the user when the multiplicative declaration has a parametric attribute. -/
def warnParametricAttr (stx : Syntax) (attr : ParametricAttribute β)
  (thisAttr attrName src tgt : Name) : CoreM Unit :=
warnExt stx attr.ext (·.contains ·) thisAttr attrName src tgt

/-- `runAndAdditivize names desc t` runs `t` on all elements of `names`
and adds translations between the generated lemmas (the output of `t`).
`names` must be non-empty. -/
def additivizeLemmas [Monad m] [MonadError m] [MonadLiftT CoreM m]
  (names : Array Name) (desc : String) (t : Name → m (Array Name)) : m Unit := do
  let auxLemmas ← names.mapM t
  let nLemmas := auxLemmas[0]!.size
  for (nm, lemmas) in names.zip auxLemmas do
    unless lemmas.size == nLemmas do
      throwError "{names[0]!} and {nm} do not generate the same number of {desc}."
  for (srcLemmas, tgtLemmas) in auxLemmas.zip <| auxLemmas.eraseIdx 0 do
    for (srcLemma, tgtLemma) in srcLemmas.zip tgtLemmas do
      insertTranslation srcLemma tgtLemma

/--
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.One` returns 2.
Note: we only consider the first argument of each type-class.
E.g. `[Pow A N]` is a multiplicative type-class on `A`, not on `N`.
-/
def firstMultiplicativeArg (nm : Name) : MetaM Nat := do
  forallTelescopeReducing (← getConstInfo nm).type fun xs _ ↦ do
    -- xs are the arguments to the constant
    let xs := xs.toList
    let l ← xs.filterMapM fun x ↦ do
      -- x is an argument and i is the index
      -- write `x : (y₀ : α₀) → ... → (yₙ : αₙ) → tgt_fn tgt_args₀ ... tgt_argsₘ`
      forallTelescopeReducing (← inferType x) fun _ys tgt ↦ do
        let (_tgt_fn, tgt_args) := tgt.getAppFnArgs
        if let some c := tgt.getAppFn.constName? then
          if findTranslation? (← getEnv) c |>.isNone then
            return none
        return tgt_args[0]?.bind fun tgtArg ↦
          xs.findIdx? fun x ↦ Expr.containsFVar tgtArg x.fvarId!
    trace[to_additive_detail] "firstMultiplicativeArg: {l}"
    match l with
    | [] => return 0
    | (head :: tail) => return tail.foldr Nat.min head

/-- Helper for `capitalizeLike`. -/
partial def capitalizeLikeAux (s : String) (i : String.Pos := 0) (p : String) : String :=
  if p.atEnd i || s.atEnd i then
    p
  else
    let j := p.next i
    if (s.get i).isLower then
      capitalizeLikeAux s j <| p.set i (p.get i |>.toLower)
    else if (s.get i).isUpper then
      capitalizeLikeAux s j <| p.set i (p.get i |>.toUpper)
    else
      capitalizeLikeAux s j p

/-- Capitalizes `s` char-by-char like `r`. If `s` is longer, it leaves the tail untouched. -/
def capitalizeLike (r : String) (s : String) :=
  capitalizeLikeAux r 0 s

/-- Capitalize First element of a list like `s`.
Note that we need to capitalize multiple characters in some cases,
in examples like `HMul` or `hAdd`. -/
def capitalizeFirstLike (s : String) : List String → List String
  | x :: r => capitalizeLike s x :: r
  | [] => []

/--
Dictionary used by `guessName` to autogenerate names.

Note: `guessName` capitalizes first element of the output according to
capitalization of the input. Input and first element should therefore be lower-case,
2nd element should be capitalized properly.
-/
def nameDict : String → List String
| "one"         => ["zero"]
| "mul"         => ["add"]
| "smul"        => ["vadd"]
| "inv"         => ["neg"]
| "div"         => ["sub"]
| "prod"        => ["sum"]
| "hmul"        => ["hadd"]
| "hsmul"       => ["hvadd"]
| "hdiv"        => ["hsub"]
| "hpow"        => ["hsmul"]
| "finprod"     => ["finsum"]
| "pow"         => ["nsmul"]
| "npow"        => ["nsmul"]
| "zpow"        => ["zsmul"]
| "monoid"      => ["add", "Monoid"]
| "submonoid"   => ["add", "Submonoid"]
| "group"       => ["add", "Group"]
| "subgroup"    => ["add", "Subgroup"]
| "semigroup"   => ["add", "Semigroup"]
| "magma"       => ["add", "Magma"]
| "haar"        => ["add", "Haar"]
| "prehaar"     => ["add", "Prehaar"]
| "unit"        => ["add", "Unit"]
| "units"       => ["add", "Units"]
| "rootable"    => ["divisible"]
| x             => [x]

/--
Turn each element to lower-case, apply the `nameDict` and
capitalize the output like the input.
-/
def applyNameDict : List String → List String
| x :: s => (capitalizeFirstLike x (nameDict x.toLower)) ++ applyNameDict s
| [] => []

/--
There are a few abbreviations we use. For example "Nonneg" instead of "ZeroLE"
or "addComm" instead of "commAdd".
Note: The input to this function is case sensitive!
Todo: A lot of abbreviations here are manual fixes and there might be room to
      improve the naming logic to reduce the size of `fixAbbreviation`.
-/
def fixAbbreviation : List String → List String
| "cancel" :: "Add" :: s            => "addCancel" :: fixAbbreviation s
| "Cancel" :: "Add" :: s            => "AddCancel" :: fixAbbreviation s
| "left" :: "Cancel" :: "Add" :: s  => "addLeftCancel" :: fixAbbreviation s
| "Left" :: "Cancel" :: "Add" :: s  => "AddLeftCancel" :: fixAbbreviation s
| "right" :: "Cancel" :: "Add" :: s => "addRightCancel" :: fixAbbreviation s
| "Right" :: "Cancel" :: "Add" :: s => "AddRightCancel" :: fixAbbreviation s
| "cancel" :: "Comm" :: "Add" :: s  => "addCancelComm" :: fixAbbreviation s
| "Cancel" :: "Comm" :: "Add" :: s  => "AddCancelComm" :: fixAbbreviation s
| "comm" :: "Add" :: s              => "addComm" :: fixAbbreviation s
| "Comm" :: "Add" :: s              => "AddComm" :: fixAbbreviation s
| "Zero" :: "LE" :: s               => "Nonneg" :: fixAbbreviation s
| "zero" :: "_" :: "le" :: s        => "nonneg" :: fixAbbreviation s
| "Zero" :: "LT" :: s               => "Pos" :: fixAbbreviation s
| "zero" :: "_" :: "lt" :: s        => "pos" :: fixAbbreviation s
| "LE" :: "Zero" :: s               => "Nonpos" :: fixAbbreviation s
| "le" :: "_" :: "zero" :: s        => "nonpos" :: fixAbbreviation s
| "LT" :: "Zero" :: s               => "Neg" :: fixAbbreviation s
| "lt" :: "_" :: "zero" :: s        => "neg" :: fixAbbreviation s
| "Add" :: "Single" :: s            => "Single" :: fixAbbreviation s
| "add" :: "Single" :: s            => "single" :: fixAbbreviation s
| "add" :: "_" :: "single" :: s     => "single" :: fixAbbreviation s
| "Add" :: "Support" :: s           => "Support" :: fixAbbreviation s
| "add" :: "Support" :: s           => "support" :: fixAbbreviation s
| "add" :: "_" :: "support" :: s    => "support" :: fixAbbreviation s
| "Add" :: "TSupport" :: s          => "TSupport" :: fixAbbreviation s
| "add" :: "TSupport" :: s          => "tsupport" :: fixAbbreviation s
| "add" :: "_" :: "tsupport" :: s   => "tsupport" :: fixAbbreviation s
| "Add" :: "Indicator" :: s         => "Indicator" :: fixAbbreviation s
| "add" :: "Indicator" :: s         => "indicator" :: fixAbbreviation s
| "add" :: "_" :: "indicator" :: s  => "indicator" :: fixAbbreviation s
| "is" :: "Square" :: s             => "even" :: fixAbbreviation s
| "Is" :: "Square" :: s             => "Even" :: fixAbbreviation s
-- "Regular" is well-used in mathlib3 with various meanings (e.g. in
-- measure theory) and a direct translation
-- "regular" --> ["add", "Regular"] in `nameDict` above seems error-prone.
| "is" :: "Regular" :: s            => "isAddRegular" :: fixAbbreviation s
| "Is" :: "Regular" :: s            => "IsAddRegular" :: fixAbbreviation s
| "is" :: "Left" :: "Regular" :: s  => "isAddLeftRegular" :: fixAbbreviation s
| "Is" :: "Left" :: "Regular" :: s  => "IsAddLeftRegular" :: fixAbbreviation s
| "is" :: "Right" :: "Regular" :: s => "isAddRightRegular" :: fixAbbreviation s
| "Is" :: "Right" :: "Regular" :: s => "IsAddRightRegular" :: fixAbbreviation s
-- the capitalization heuristic of `applyNameDict` doesn't work in the following cases
| "HSmul" :: s                      => "HSMul" :: fixAbbreviation s -- from `HPow`
| "NSmul" :: s                      => "NSMul" :: fixAbbreviation s -- from `NPow`
| "Nsmul" :: s                      => "NSMul" :: fixAbbreviation s -- from `Pow`
| "ZSmul" :: s                      => "ZSMul" :: fixAbbreviation s -- from `ZPow`
| "neg" :: "Fun" :: s               => "invFun" :: fixAbbreviation s
| "Neg" :: "Fun" :: s               => "InvFun" :: fixAbbreviation s
| "order" :: "Of" :: s              => "addOrderOf" :: fixAbbreviation s
| "Order" :: "Of" :: s              => "AddOrderOf" :: fixAbbreviation s
| "is"::"Of"::"Fin"::"Order"::s     => "isOfFinAddOrder" :: fixAbbreviation s
| "Is"::"Of"::"Fin"::"Order"::s     => "IsOfFinAddOrder" :: fixAbbreviation s
| "is" :: "Central" :: "Scalar" :: s  => "isCentralVAdd" :: fixAbbreviation s
| "Is" :: "Central" :: "Scalar" :: s  => "IsCentralVAdd" :: fixAbbreviation s
| x :: s                            => x :: fixAbbreviation s
| []                                => []

/--
Autogenerate additive name.
This runs in several steps:
1) Split according to capitalisation rule and at `_`.
2) Apply word-by-word translation rules.
3) Fix up abbreviations that are not word-by-word translations, like "addComm" or "Nonneg".
-/
def guessName : String → String :=
  String.mapTokens '\'' <|
  fun s =>
    String.join <|
    fixAbbreviation <|
    applyNameDict <|
    s.splitCase

/-- Return the provided target name or autogenerate one if one was not provided. -/
def targetName (cfg : Config) (src : Name) : CoreM Name := do
  let .str pre s := src | throwError "to_additive: can't transport {src}"
  trace[to_additive_detail] "The name {s} splits as {s.splitCase}"
  let tgt_auto := guessName s
  let depth := cfg.tgt.getNumParts
  let pre := pre.mapPrefix <| findTranslation? (← getEnv)
  let (pre1, pre2) := pre.splitAt (depth - 1)
  if cfg.tgt == pre2.str tgt_auto && !cfg.allowAutoName && cfg.tgt != src then
    Linter.logLintIf linter.toAdditiveGenerateName cfg.ref
      m!"to_additive correctly autogenerated target name for {src}. {"\n"
      }You may remove the explicit argument {cfg.tgt}."
  let res := if cfg.tgt == .anonymous then pre.str tgt_auto else pre1 ++ cfg.tgt
  -- we allow translating to itself if `tgt == src`, which is occasionally useful for `additiveTest`
  if res == src && cfg.tgt != src then
    throwError "to_additive: can't transport {src} to itself."
  if cfg.tgt != .anonymous then
    trace[to_additive_detail] "The automatically generated name would be {pre.str tgt_auto}"
  return res

/-- if `f src = #[a_1, ..., a_n]` and `f tgt = #[b_1, ... b_n]` then `proceedFieldsAux src tgt f`
  will insert translations from `src.a_i` to `tgt.b_i`. -/
def proceedFieldsAux (src tgt : Name) (f : Name → CoreM (Array Name)) : CoreM Unit := do
  let srcFields ← f src
  let tgtFields ← f tgt
  if srcFields.size != tgtFields.size then
    throwError "Failed to map fields of {src}, {tgt} with {srcFields} ↦ {tgtFields}"
  for (srcField, tgtField) in srcFields.zip tgtFields do
    if srcField != tgtField then
      insertTranslation (src ++ srcField) (tgt ++ tgtField)
    else
      trace[to_additive] "Translation {src ++ srcField} ↦ {tgt ++ tgtField} is automatic."

/-- Add the structure fields of `src` to the translations dictionary
so that future uses of `to_additive` will map them to the corresponding `tgt` fields. -/
def proceedFields (src tgt : Name) : CoreM Unit := do
  let aux := proceedFieldsAux src tgt
  aux fun declName ↦ do
    if isStructure (← getEnv) declName then
      return getStructureFields (← getEnv) declName
    else
      return #[]
  aux fun declName ↦ do match (← getEnv).find? declName with
    | some (ConstantInfo.inductInfo {ctors := ctors, ..}) => return ctors.toArray.map (·.getString)
    | _ => pure #[]

/-- Elaboration of the configuration options for `to_additive`. -/
def elabToAdditive : Syntax → CoreM Config
  | `(attr| to_additive%$tk $[?%$trace]? $[$opts:toAdditiveOption]* $[$tgt]? $[$doc]?) => do
    let mut attrs : Array Syntax := #[]
    let mut reorder := []
    let mut existing := some false
    for stx in opts do
      match stx with
      | `(toAdditiveOption| (attr := $[$stxs],*)) =>
        attrs := attrs ++ stxs
      | `(toAdditiveOption| (reorder := $[$reorders:num]*)) =>
        reorder := reorder ++ reorders.toList.map (·.raw.isNatLit?.get!)
      | `(toAdditiveOption| existing) =>
        existing := some true
      | _ => throwUnsupportedSyntax
    trace[to_additive_detail] "attributes: {attrs}; reorder arguments: {reorder}"
    return { trace := trace.isSome
             tgt := match tgt with | some tgt => tgt.getId | none => Name.anonymous
             doc := doc.bind (·.raw.isStrLit?)
             allowAutoName := false
             attrs
             reorder
             existing
             ref := (tgt.map (·.raw)).getD tk }
  | _ => throwUnsupportedSyntax

mutual
/-- Apply attributes to the multiplicative and additive declarations. -/
partial def applyAttributes (stx : Syntax) (rawAttrs : Array Syntax) (thisAttr src tgt : Name) :
  TermElabM (Array Name) := do
  -- we only copy the `instance` attribute, since `@[to_additive] instance` is nice to allow
  copyInstanceAttribute src tgt
  -- Warn users if the multiplicative version has an attribute
  if linter.existingAttributeWarning.get (← getOptions) then
    let appliedAttrs ← getAllSimpAttrs src
    if appliedAttrs.size > 0 then
      Linter.logLintIf linter.existingAttributeWarning stx <|
        m!"The source declaration {src} was given the simp-attribute(s) {appliedAttrs} before {
        ""}calling @[{thisAttr}]. The preferred method is to use {
        ""}`@[{thisAttr} (attr := {appliedAttrs})]` to apply the attribute to both {
        src} and the target declaration {tgt}."
    warnAttr stx Std.Tactic.Ext.extExtension (fun b n => (b.elements.any fun t => t.declName = n))
      thisAttr `ext src tgt
    warnAttr stx Mathlib.Tactic.reflExt (·.elements.contains ·) thisAttr `refl src tgt
    warnAttr stx Mathlib.Tactic.symmExt (·.elements.contains ·) thisAttr `symm src tgt
    warnAttr stx Mathlib.Tactic.transExt (·.elements.contains ·) thisAttr `trans src tgt
    warnAttr stx Std.Tactic.Coe.coeExt (·.contains ·) thisAttr `coe src tgt
    warnParametricAttr stx Lean.Linter.deprecatedAttr thisAttr `deprecated src tgt
    -- the next line also warns for `@[to_additive, simps]`, because of the application times
    warnParametricAttr stx simpsAttr thisAttr `simps src tgt
    warnExt stx Term.elabAsElim.ext (·.contains ·) thisAttr `elab_as_elim src tgt
  -- add attributes
  -- the following is similar to `Term.ApplyAttributesCore`, but we hijack the implementation of
  -- `simp`, `simps` and `to_additive`.
  let attrs ← elabAttrs rawAttrs
  let (additiveAttrs, attrs) := attrs.partition (·.name == `to_additive)
  let nestedDecls ←
    match additiveAttrs.size with
      | 0 => pure #[]
      | 1 => addToAdditiveAttr tgt (← elabToAdditive additiveAttrs[0]!.stx) additiveAttrs[0]!.kind
      | _ => throwError "cannot apply {thisAttr} multiple times."
  let allDecls := #[src, tgt] ++ nestedDecls
  if attrs.size > 0 then
    trace[to_additive_detail] "Applying attributes {attrs.map (·.stx)} to {allDecls}"
  for attr in attrs do
    withRef attr.stx do withLogging do
    -- todo: also support other simp-attributes,
    -- and attributes that generate simp-attributes, like `norm_cast`
    if attr.name == `simp then
      additivizeLemmas allDecls "simp lemmas"
        (Meta.Simp.addSimpAttrFromSyntax · simpExtension attr.kind attr.stx)
      return
    if attr.name == `simps then
      additivizeLemmas allDecls "simps lemmas" (simpsTacFromSyntax · attr.stx)
      return
    let env ← getEnv
    match getAttributeImpl env attr.name with
    | Except.error errMsg => throwError errMsg
    | Except.ok attrImpl  =>
      let runAttr := do
        attrImpl.add src attr.stx attr.kind
        attrImpl.add tgt attr.stx attr.kind
      -- not truly an elaborator, but a sensible target for go-to-definition
      let elaborator := attrImpl.ref
      if (← getInfoState).enabled && (← getEnv).contains elaborator then
        withInfoContext (mkInfo := return .ofCommandInfo { elaborator, stx := attr.stx }) do
          try runAttr
          finally if attr.stx[0].isIdent || attr.stx[0].isAtom then
            -- Add an additional node over the leading identifier if there is one
            -- to make it look more function-like.
            -- Do this last because we want user-created infos to take precedence
            pushInfoLeaf <| .ofCommandInfo { elaborator, stx := attr.stx[0] }
      else
        runAttr
  return nestedDecls

/--
Copies equation lemmas and attributes from `src` to `tgt`
-/
partial def copyMetaData (cfg : Config) (src tgt : Name) : CoreM (Array Name) := do
  /- We need to generate all equation lemmas for `src` and `tgt`, even for non-recursive
  definitions. If we don't do that, the equation lemma for `src` might be generated later
  when doing a `rw`, but it won't be generated for `tgt`. -/
  additivizeLemmas #[src, tgt] "equation lemmas" fun nm ↦
    (·.getD #[]) <$> MetaM.run' (getEqnsFor? nm true)
  MetaM.run' <| Elab.Term.TermElabM.run' <|
    applyAttributes cfg.ref cfg.attrs `to_additive src tgt

/--
Make a new copy of a declaration, replacing fragments of the names of identifiers in the type and
the body using the `translations` dictionary.
This is used to implement `@[to_additive]`.
-/
partial def transformDecl (cfg : Config) (src tgt : Name) : CoreM (Array Name) := do
  transformDeclAux cfg src tgt src
  copyMetaData cfg src tgt

/-- `addToAdditiveAttr src cfg` adds a `@[to_additive]` attribute to `src` with configuration `cfg`.
See the attribute implementation for more details.
It returns an array with names of additive declarations (usually 1, but more if there are nested
`to_additive` calls. -/
partial def addToAdditiveAttr (src : Name) (cfg : Config) (kind := AttributeKind.global) :
  AttrM (Array Name) := do
  if (kind != AttributeKind.global) then
    throwError "`to_additive` can only be used as a global attribute"
  withOptions (· |>.updateBool `trace.to_additive (cfg.trace || ·)) <| do
  let tgt ← targetName cfg src
  let alreadyExists := (← getEnv).contains tgt
  if cfg.existing == some !alreadyExists && !(← isInductive src) then
    Linter.logLintIf linter.toAdditiveExisting cfg.ref <|
      if alreadyExists then
        m!"The additive declaration already exists. Please specify this explicitly using {
          ""}`@[to_additive existing]`."
      else
        "The additive declaration doesn't exist. Please remove the option `existing`."
  if cfg.reorder != [] then
    trace[to_additive] "@[to_additive] will reorder the arguments of {tgt}."
    reorderAttr.add src cfg.reorder
    -- we allow using this attribute if it's only to add the reorder configuration
    if findTranslation? (← getEnv) src |>.isSome then
      return #[tgt]
  let firstMultArg ← MetaM.run' <| firstMultiplicativeArg src
  if firstMultArg != 0 then
    trace[to_additive_detail] "Setting relevant_arg for {src} to be {firstMultArg}."
    relevantArgAttr.add src firstMultArg
  insertTranslation src tgt alreadyExists
  let nestedNames ←
    if alreadyExists then
      -- since `tgt` already exists, we just need to copy metadata and
      -- add translations `src.x ↦ tgt.x'` for any subfields.
      trace[to_additive_detail] "declaration {tgt} already exists."
      proceedFields src tgt
      copyMetaData cfg src tgt
    else
      -- tgt doesn't exist, so let's make it
      transformDecl cfg src tgt
  -- add pop-up information when mousing over `additive_name` of `@[to_additive additive_name]`
  -- (the information will be over the attribute of no additive name is given)
  pushInfoLeaf <| .ofTermInfo {
    elaborator := .anonymous, lctx := {}, expectedType? := none, isBinder := !alreadyExists,
    stx := cfg.ref, expr := ← mkConstWithLevelParams tgt }
  if let some doc := cfg.doc then
    addDocString tgt doc
  return nestedNames.push tgt

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.

Use the `(attr := ...)` syntax to apply attributes to both the multiplicative and the additive
version:

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

For `simp` and `simps` this also ensures that some generated lemmas are added to the additive
dictionary.
`@[to_additive (attr := to_additive)]` is a special case, where the `to_additive`
attribute is added to the generated lemma only, to additivize it again.
This is useful for lemmas about `Pow` to generate both lemmas about `SMul` and `VAdd`. Example:
```
@[to_additive (attr := to_additive VAdd_lemma, simp) SMul_lemma]
lemma Pow_lemma ...
```
In the above example, the `simp` is added to all 3 lemmas. All other options to `to_additive`
(like the generated name or `(reorder := ...)`) are not passed down,
and can be given manually to each individual `to_additive` call.

## 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:
* `@Mul.mul Nat n m` (i.e. `(n * m : Nat)`) will not change to `+`, since its
  first argument is `ℕ`, an identifier not applied to any arguments.
* `@Mul.mul (α × β) x y` will change to `+`. It's first argument contains only the identifier
  `prod`, but this is applied to arguments, `α` and `β`.
* `@Mul.mul (α × Int) x y` will not change to `+`, since its first argument contains `Int`.

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 : WithTop Nat)` can contain `ℕ`
  (usually in the form `Top.top Nat ...`) and still be additivized.
  So `@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):
    ```
      #eval (do isRelevant `d >>= 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`.
* 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 `AddMonoid.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.

### Structure fields and constructors

If `src` is a structure, then the additive version has to be already written manually.
In this case `to_additive` adds all structure fields to its mapping.

### 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.

* [todo] 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.

-/
initialize registerBuiltinAttribute {
    name := `to_additive
    descr := "Transport multiplicative to additive"
    add := fun src stx kind ↦ do _ ← addToAdditiveAttr src (← elabToAdditive stx) kind
    -- we (presumably) need to run after compilation to properly add the `simp` attribute
    applicationTime := .afterCompilation
  }

end ToAdditive


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Eqns
import Lean.Meta.Tactic.Split
import Lean.Meta.Tactic.Apply
import Lean.Elab.PreDefinition.Basic
import Lean.Elab.PreDefinition.Eqns
import Lean.Elab.PreDefinition.Structural.Basic

namespace Lean.Elab
open Meta
open Eqns

namespace Structural

structure EqnInfo extends EqnInfoCore where
  recArgPos   : Nat
  deriving Inhabited

private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
  trace[Elab.definition.structural.eqns] "proving: {type}"
  withNewMCtxDepth do
    let main ← mkFreshExprSyntheticOpaqueMVar type
    let (_, mvarId) ← intros main.mvarId!
    unless (← tryURefl mvarId) do -- catch easy cases
      go (← deltaLHS mvarId)
    instantiateMVars main
where
  go (mvarId : MVarId) : MetaM Unit := do
    trace[Elab.definition.structural.eqns] "step\n{MessageData.ofGoal mvarId}"
    if (← tryURefl mvarId) then
      return ()
    else if (← tryContradiction mvarId) then
      return ()
    else if let some mvarId ← simpMatch? mvarId then
      go mvarId
    else if let some mvarId ← simpIf? mvarId then
      go mvarId
    else if let some mvarId ← whnfReducibleLHS? mvarId then
      go mvarId
    else if let some mvarId ← deltaRHS? mvarId declName then
      go mvarId
    else if let some mvarIds ← casesOnStuckLHS? mvarId then
      mvarIds.forM go
    else
      throwError "failed to generate equational theorem for '{declName}'\n{MessageData.ofGoal mvarId}"

def mkEqns (info : EqnInfo) : MetaM (Array Name) :=
  withOptions (tactic.hygienic.set . false) do
  let eqnTypes ← withNewMCtxDepth <| lambdaTelescope info.value fun xs body => do
    let us := info.levelParams.map mkLevelParam
    let target ← mkEq (mkAppN (Lean.mkConst info.declName us) xs) body
    let goal ← mkFreshExprSyntheticOpaqueMVar target
    mkEqnTypes #[info.declName] goal.mvarId!
  let baseName := mkPrivateName (← getEnv) info.declName
  let mut thmNames := #[]
  for i in [: eqnTypes.size] do
    let type := eqnTypes[i]
    trace[Elab.definition.structural.eqns] "{eqnTypes[i]}"
    let name := baseName ++ (`_eq).appendIndexAfter (i+1)
    thmNames := thmNames.push name
    let value ← mkProof info.declName type
    addDecl <| Declaration.thmDecl {
      name, type, value
      levelParams := info.levelParams
    }
  return thmNames

builtin_initialize eqnInfoExt : MapDeclarationExtension EqnInfo ← mkMapDeclarationExtension `structEqInfo

def registerEqnsInfo (preDef : PreDefinition) (recArgPos : Nat) : CoreM Unit := do
  modifyEnv fun env => eqnInfoExt.insert env preDef.declName { preDef with recArgPos }

def getEqnsFor? (declName : Name) : MetaM (Option (Array Name)) := do
  let env ← getEnv
  if let some eqs := eqnsExt.getState env |>.map.find? declName then
    return some eqs
  else if let some info := eqnInfoExt.find? env declName then
    let eqs ← mkEqns info
    modifyEnv fun env => eqnsExt.modifyState env fun s => { s with map := s.map.insert declName eqs }
    return some eqs
  else
    return none

def getUnfoldFor? (declName : Name) : MetaM (Option Name) := do
  let env ← getEnv
  Eqns.getUnfoldFor? declName fun _ => eqnInfoExt.find? env declName |>.map (·.toEqnInfoCore)

builtin_initialize
  registerGetEqnsFn getEqnsFor?
  registerGetUnfoldEqnFn getUnfoldFor?
  registerTraceClass `Elab.definition.structural.eqns

end Structural
end Lean.Elab


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.adjunction
import category_theory.adjunction.limits
import category_theory.limits.preserves.shapes.terminal

namespace category_theory
open category
open category_theory.limits

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

namespace monad

variables {C : Type u₁} [category.{v₁} C]
variables {T : monad C}

variables {J : Type v₁} [small_category J]

namespace forget_creates_limits

variables (D : J ⥤ algebra T) (c : cone (D ⋙ forget T)) (t : is_limit c)

/-- (Impl) The natural transformation used to define the new cone -/
@[simps] def γ : (D ⋙ forget T ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simps] def new_cone : cone (D ⋙ forget T) :=
{ X := T.obj c.X,
  π := (functor.const_comp _ _ ↑T).inv ≫ whisker_right c.π T ≫ (γ D) }

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simps] def cone_point : algebra T :=
{ A := c.X,
  a := t.lift (new_cone D c),
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    erw [category.assoc, t.fac (new_cone D c), id_comp],
    dsimp,
    erw [id_comp, ← category.assoc, ← T.η.naturality, functor.id_map, category.assoc,
         (D.obj j).unit, comp_id],
  end,
  assoc' :=
  begin
    apply t.hom_ext,
    intro j,
    rw [category.assoc, category.assoc, t.fac (new_cone D c)],
    dsimp,
    erw id_comp,
    slice_lhs 1 2 {rw ← T.μ.naturality},
    slice_lhs 2 3 {rw (D.obj j).assoc},
    slice_rhs 1 2 {rw ← (T : C ⥤ C).map_comp},
    rw t.fac (new_cone D c),
    dsimp,
    erw [id_comp, functor.map_comp, category.assoc]
  end }

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simps] def lifted_cone : cone D :=
{ X := cone_point D c t,
  π := { app := λ j, { f := c.π.app j },
         naturality' := λ X Y f, by { ext1, dsimp, erw c.w f, simp } } }

/-- (Impl) Prove that the lifted cone is limiting. -/
@[simps]
def lifted_cone_is_limit : is_limit (lifted_cone D c t) :=
{ lift := λ s,
  { f := t.lift ((forget T).map_cone s),
    h' :=
    begin
      apply t.hom_ext, intro j,
      slice_rhs 2 3 {rw t.fac ((forget T).map_cone s) j},
      dsimp,
      slice_lhs 2 3 {rw t.fac (new_cone D c) j},
      dsimp,
      rw category.id_comp,
      slice_lhs 1 2 {rw ← (T : C ⥤ C).map_comp},
      rw t.fac ((forget T).map_cone s) j,
      exact (s.π.app j).h
    end },
  uniq' := λ s m J,
  begin
    ext1,
    apply t.hom_ext,
    intro j,
    simpa [t.fac (functor.map_cone (forget T) s) j] using congr_arg algebra.hom.f (J j),
  end }

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]
/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
noncomputable
instance forget_creates_limits : creates_limits (forget T) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ D,
    creates_limit_of_reflects_iso (λ c t,
    { lifted_cone := forget_creates_limits.lifted_cone D c t,
      valid_lift := cones.ext (iso.refl _) (λ j, (id_comp _).symm),
      makes_limit := forget_creates_limits.lifted_cone_is_limit _ _ _ } ) } }

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
lemma has_limit_of_comp_forget_has_limit (D : J ⥤ algebra T) [has_limit (D ⋙ forget T)] :
  has_limit D :=
has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace
variables {D : J ⥤ algebra T} (c : cocone (D ⋙ forget T)) (t : is_colimit c)

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a
-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.
-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.
-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`
-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.
-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.
-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it
-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simps] def γ : ((D ⋙ forget T) ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simps]
def new_cocone : cocone ((D ⋙ forget T) ⋙ ↑T) :=
{ X := c.X,
  ι := γ ≫ c.ι }

variables [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
@[reducible]
def lambda : ((T : C ⥤ C).map_cocone c).X ⟶ c.X :=
(preserves_colimit.preserves t).desc (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
lemma commuting (j : J) :
T.map (c.ι.app j) ≫ lambda c t = (D.obj j).a ≫ c.ι.app j :=
is_colimit.fac (preserves_colimit.preserves t) (new_cocone c) j

variables [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)]

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simps] def cocone_point :
algebra T :=
{ A := c.X,
  a := lambda c t,
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    erw [comp_id, ← category.assoc, T.η.naturality, category.assoc, commuting, ← category.assoc],
    erw algebra.unit, apply id_comp
  end,
  assoc' :=
  begin
    apply is_colimit.hom_ext (preserves_colimit.preserves (preserves_colimit.preserves t)),
    intro j,
    erw [← category.assoc, T.μ.naturality, ← functor.map_cocone_ι_app, category.assoc,
         is_colimit.fac _ (new_cocone c) j],
    rw ← category.assoc,
    erw [← functor.map_comp, commuting],
    dsimp,
    erw [← category.assoc, algebra.assoc, category.assoc, functor.map_comp, category.assoc,
      commuting],
    apply_instance, apply_instance
  end }

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simps] def lifted_cocone : cocone D :=
{ X := cocone_point c t,
  ι := { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
         naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } }

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simps]
def lifted_cocone_is_colimit : is_colimit (lifted_cocone c t) :=
{ desc := λ s,
  { f := t.desc ((forget T).map_cocone s),
    h' :=
    begin
      dsimp,
      apply is_colimit.hom_ext (preserves_colimit.preserves t),
      intro j,
      rw ← category.assoc, erw ← functor.map_comp,
      erw t.fac',
      rw ← category.assoc, erw forget_creates_colimits.commuting,
      rw category.assoc, rw t.fac',
      apply algebra.hom.h,
      apply_instance
    end },
  uniq' := λ s m J,
  by { ext1, apply t.hom_ext, intro j, simpa using congr_arg algebra.hom.f (J j) } }

end forget_creates_colimits

open forget_creates_colimits

-- TODO: the converse of this is true as well
/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
instance forget_creates_colimit (D : J ⥤ algebra T)
  [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]
  [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)] :
  creates_colimit D (forget T) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone :=
  { X := cocone_point c t,
    ι :=
    { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
      naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } },
  valid_lift := cocones.ext (iso.refl _) (by tidy),
  makes_colimit := lifted_cocone_is_colimit _ _ }

noncomputable
instance forget_creates_colimits_of_shape
  [preserves_colimits_of_shape J (T : C ⥤ C)] :
  creates_colimits_of_shape J (forget T) :=
{ creates_colimit := λ K, by apply_instance }

noncomputable
instance forget_creates_colimits
  [preserves_colimits (T : C ⥤ C)] :
  creates_colimits (forget T) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by apply_instance }

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
lemma forget_creates_colimits_of_monad_preserves
  [preserves_colimits_of_shape J (T : C ⥤ C)] (D : J ⥤ algebra T) [has_colimit (D ⋙ forget T)] :
has_colimit D :=
has_colimit_of_created D (forget T)

end monad

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₁} D]
variables {J : Type v₁} [small_category J]

instance comp_comparison_forget_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit ((F ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) :=
@has_limit_of_iso _ _ _ _ (F ⋙ R) _ _
  (iso_whisker_left F (monad.comparison_forget (adjunction.of_right_adjoint R)).symm)

instance comp_comparison_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R)) :=
monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R))

/-- Any monadic functor creates limits. -/
noncomputable
def monadic_creates_limits (R : D ⥤ C) [monadic_right_adjoint R] :
  creates_limits R :=
creates_limits_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R))

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
def monadic_creates_colimit_of_preserves_colimit (R : D ⥤ C) (K : J ⥤ D)
  [monadic_right_adjoint R]
  [preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)]
  [preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] :
  creates_colimit K R :=
begin
  apply creates_colimit_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.comp_creates_colimit _ _,
  apply_instance,
  let i : ((K ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) ≅ K ⋙ R :=
    functor.associator _ _ _ ≪≫
      iso_whisker_left K (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.monad.forget_creates_colimit _,
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ i.symm },
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ (iso_whisker_right i (left_adjoint R ⋙ R)).symm },
end

/-- A monadic functor creates any colimits of shapes it preserves. -/
noncomputable
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape (R : D ⥤ C)
  [monadic_right_adjoint R] [preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
begin
  have : preserves_colimits_of_shape J (left_adjoint R ⋙ R),
  { apply category_theory.limits.comp_preserves_colimits_of_shape _ _,
    { haveI := adjunction.left_adjoint_preserves_colimits (adjunction.of_right_adjoint R),
      apply_instance },
    apply_instance },
  exactI ⟨λ K, monadic_creates_colimit_of_preserves_colimit _ _⟩,
end

/-- A monadic functor creates colimits if it preserves colimits. -/
noncomputable
def monadic_creates_colimits_of_preserves_colimits (R : D ⥤ C) [monadic_right_adjoint R]
  [preserves_colimits R] : creates_colimits R :=
{ creates_colimits_of_shape := λ J 𝒥₁,
    by exactI monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape _ }

section

lemma has_limit_of_reflective (F : J ⥤ D) (R : D ⥤ C) [has_limit (F ⋙ R)] [reflective R] :
  has_limit F :=
by { haveI := monadic_creates_limits R, exact has_limit_of_created F R }

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
lemma has_limits_of_shape_of_reflective [has_limits_of_shape J C] (R : D ⥤ C) [reflective R] :
  has_limits_of_shape J D :=
{ has_limit := λ F, has_limit_of_reflective F R }

/-- If `C` has limits then any reflective subcategory has limits. -/
lemma has_limits_of_reflective (R : D ⥤ C) [has_limits C] [reflective R] : has_limits D :=
{ has_limits_of_shape := λ J 𝒥₁, by exactI has_limits_of_shape_of_reflective R }

/-- If `C` has colimits of shape `J` then any reflective subcategory has colimits of shape `J`. -/
lemma has_colimits_of_shape_of_reflective (R : D ⥤ C)
  [reflective R] [has_colimits_of_shape J C] : has_colimits_of_shape J D :=
{ has_colimit := λ F,
begin
  let c := (left_adjoint R).map_cocone (colimit.cocone (F ⋙ R)),
  letI := (adjunction.of_right_adjoint R).left_adjoint_preserves_colimits,
  let t : is_colimit c := is_colimit_of_preserves (left_adjoint R) (colimit.is_colimit _),
  apply has_colimit.mk ⟨_, (is_colimit.precompose_inv_equiv _ _).symm t⟩,
  apply (iso_whisker_left F (as_iso (adjunction.of_right_adjoint R).counit) : _) ≪≫ F.right_unitor,
end }

/-- If `C` has colimits then any reflective subcategory has colimits. -/
lemma has_colimits_of_reflective (R : D ⥤ C) [reflective R] [has_colimits C] :
  has_colimits D :=
{ has_colimits_of_shape := λ J 𝒥, by exactI has_colimits_of_shape_of_reflective R }

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
noncomputable def left_adjoint_preserves_terminal_of_reflective
  (R : D ⥤ C) [reflective R] [has_terminal C] :
  preserves_limits_of_shape (discrete pempty) (left_adjoint R) :=
{ preserves_limit := λ K,
  begin
    letI : has_terminal D := has_limits_of_shape_of_reflective R,
    letI := monadic_creates_limits R,
    letI := category_theory.preserves_limit_of_creates_limit_and_has_limit (functor.empty _) R,
    letI : preserves_limit (functor.empty _) (left_adjoint R),
    { apply preserves_terminal_of_iso,
      apply _ ≪≫ as_iso ((adjunction.of_right_adjoint R).counit.app (⊤_ D)),
      apply (left_adjoint R).map_iso (preserves_terminal.iso R).symm },
    apply preserves_limit_of_iso_diagram (left_adjoint R) (functor.unique_from_empty _).symm,
  end }

end
end category_theory


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.geom_sum
import Mathlib.data.nat.choose.sum
import Mathlib.data.complex.basic
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Exponential, trigonometric and hyperbolic trigonometric functions

This file contains the definitions of the real and complex exponential, sine, cosine, tangent,
hyperbolic sine, hyperbolic cosine, and hyperbolic tangent functions.

-/

theorem forall_ge_le_of_forall_le_succ {α : Type u_1} [preorder α] (f : ℕ → α) {m : ℕ}
    (h : ∀ (n : ℕ), n ≥ m → f (Nat.succ n) ≤ f n) {l : ℕ} (k : ℕ) (H : k ≥ m) : k ≤ l → f l ≤ f k :=
  sorry

theorem is_cau_of_decreasing_bounded {α : Type u_1} [linear_ordered_field α] [archimedean α]
    (f : ℕ → α) {a : α} {m : ℕ} (ham : ∀ (n : ℕ), n ≥ m → abs (f n) ≤ a)
    (hnm : ∀ (n : ℕ), n ≥ m → f (Nat.succ n) ≤ f n) : is_cau_seq abs f :=
  sorry

theorem is_cau_of_mono_bounded {α : Type u_1} [linear_ordered_field α] [archimedean α] (f : ℕ → α)
    {a : α} {m : ℕ} (ham : ∀ (n : ℕ), n ≥ m → abs (f n) ≤ a)
    (hnm : ∀ (n : ℕ), n ≥ m → f n ≤ f (Nat.succ n)) : is_cau_seq abs f :=
  sorry

theorem is_cau_series_of_abv_le_cau {α : Type u_1} {β : Type u_2} [ring β] [linear_ordered_field α]
    {abv : β → α} [is_absolute_value abv] {f : ℕ → β} {g : ℕ → α} (n : ℕ) :
    (∀ (m : ℕ), n ≤ m → abv (f m) ≤ g m) →
        (is_cau_seq abs fun (n : ℕ) => finset.sum (finset.range n) fun (i : ℕ) => g i) →
          is_cau_seq abv fun (n : ℕ) => finset.sum (finset.range n) fun (i : ℕ) => f i :=
  sorry

theorem is_cau_series_of_abv_cau {α : Type u_1} {β : Type u_2} [ring β] [linear_ordered_field α]
    {abv : β → α} [is_absolute_value abv] {f : ℕ → β} :
    (is_cau_seq abs fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => abv (f n)) →
        is_cau_seq abv fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => f n :=
  is_cau_series_of_abv_le_cau 0 fun (n : ℕ) (h : 0 ≤ n) => le_refl (abv (f n))

theorem is_cau_geo_series {α : Type u_1} [linear_ordered_field α] [archimedean α] {β : Type u_2}
    [field β] {abv : β → α} [is_absolute_value abv] (x : β) (hx1 : abv x < 1) :
    is_cau_seq abv fun (n : ℕ) => finset.sum (finset.range n) fun (m : ℕ) => x ^ m :=
  sorry

theorem is_cau_geo_series_const {α : Type u_1} [linear_ordered_field α] [archimedean α] (a : α)
    {x : α} (hx1 : abs x < 1) :
    is_cau_seq abs fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => a * x ^ n :=
  sorry

theorem series_ratio_test {α : Type u_1} {β : Type u_2} [ring β] [linear_ordered_field α]
    [archimedean α] {abv : β → α} [is_absolute_value abv] {f : ℕ → β} (n : ℕ) (r : α) (hr0 : 0 ≤ r)
    (hr1 : r < 1) (h : ∀ (m : ℕ), n ≤ m → abv (f (Nat.succ m)) ≤ r * abv (f m)) :
    is_cau_seq abv fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => f n :=
  sorry

theorem sum_range_diag_flip {α : Type u_1} [add_comm_monoid α] (n : ℕ) (f : ℕ → ℕ → α) :
    (finset.sum (finset.range n)
          fun (m : ℕ) => finset.sum (finset.range (m + 1)) fun (k : ℕ) => f k (m - k)) =
        finset.sum (finset.range n)
          fun (m : ℕ) => finset.sum (finset.range (n - m)) fun (k : ℕ) => f m k :=
  sorry

theorem sum_range_sub_sum_range {α : Type u_1} [add_comm_group α] {f : ℕ → α} {n : ℕ} {m : ℕ}
    (hnm : n ≤ m) :
    ((finset.sum (finset.range m) fun (k : ℕ) => f k) -
          finset.sum (finset.range n) fun (k : ℕ) => f k) =
        finset.sum (finset.filter (fun (k : ℕ) => n ≤ k) (finset.range m)) fun (k : ℕ) => f k :=
  sorry

theorem abv_sum_le_sum_abv {α : Type u_1} {β : Type u_2} [ring β] [linear_ordered_field α]
    {abv : β → α} [is_absolute_value abv] {γ : Type u_3} (f : γ → β) (s : finset γ) :
    abv (finset.sum s fun (k : γ) => f k) ≤ finset.sum s fun (k : γ) => abv (f k) :=
  sorry

theorem cauchy_product {α : Type u_1} {β : Type u_2} [ring β] [linear_ordered_field α] {abv : β → α}
    [is_absolute_value abv] {a : ℕ → β} {b : ℕ → β}
    (ha : is_cau_seq abs fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => abv (a n))
    (hb : is_cau_seq abv fun (m : ℕ) => finset.sum (finset.range m) fun (n : ℕ) => b n) (ε : α)
    (ε0 : 0 < ε) :
    ∃ (i : ℕ),
        ∀ (j : ℕ),
          j ≥ i →
            abv
                (((finset.sum (finset.range j) fun (k : ℕ) => a k) *
                    finset.sum (finset.range j) fun (n : ℕ) => b n) -
                  finset.sum (finset.range j)
                    fun (n : ℕ) =>
                      finset.sum (finset.range (n + 1)) fun (m : ℕ) => a m * b (n - m)) <
              ε :=
  sorry

namespace complex

theorem is_cau_abs_exp (z : ℂ) :
    is_cau_seq abs
        fun (n : ℕ) =>
          finset.sum (finset.range n) fun (m : ℕ) => abs (z ^ m / ↑(nat.factorial m)) :=
  sorry

theorem is_cau_exp (z : ℂ) :
    is_cau_seq abs
        fun (n : ℕ) => finset.sum (finset.range n) fun (m : ℕ) => z ^ m / ↑(nat.factorial m) :=
  is_cau_series_of_abv_cau (is_cau_abs_exp z)

/-- The Cauchy sequence consisting of partial sums of the Taylor series of
the complex exponential function -/
def exp' (z : ℂ) : cau_seq ℂ abs :=
  { val := fun (n : ℕ) => finset.sum (finset.range n) fun (m : ℕ) => z ^ m / ↑(nat.factorial m),
    property := is_cau_exp z }

/-- The complex exponential function, defined via its Taylor series -/
def exp (z : ℂ) : ℂ := cau_seq.lim (exp' z)

/-- The complex sine function, defined via `exp` -/
def sin (z : ℂ) : ℂ := (exp (-z * I) - exp (z * I)) * I / bit0 1

/-- The complex cosine function, defined via `exp` -/
def cos (z : ℂ) : ℂ := (exp (z * I) + exp (-z * I)) / bit0 1

/-- The complex tangent function, defined as `sin z / cos z` -/
def tan (z : ℂ) : ℂ := sin z / cos z

/-- The complex hyperbolic sine function, defined via `exp` -/
def sinh (z : ℂ) : ℂ := (exp z - exp (-z)) / bit0 1

/-- The complex hyperbolic cosine function, defined via `exp` -/
def cosh (z : ℂ) : ℂ := (exp z + exp (-z)) / bit0 1

/-- The complex hyperbolic tangent function, defined as `sinh z / cosh z` -/
def tanh (z : ℂ) : ℂ := sinh z / cosh z

end complex

namespace real

/-- The real exponential function, defined as the real part of the complex exponential -/
def exp (x : ℝ) : ℝ := complex.re (complex.exp ↑x)

/-- The real sine function, defined as the real part of the complex sine -/
def sin (x : ℝ) : ℝ := complex.re (complex.sin ↑x)

/-- The real cosine function, defined as the real part of the complex cosine -/
def cos (x : ℝ) : ℝ := complex.re (complex.cos ↑x)

/-- The real tangent function, defined as the real part of the complex tangent -/
def tan (x : ℝ) : ℝ := complex.re (complex.tan ↑x)

/-- The real hypebolic sine function, defined as the real part of the complex hyperbolic sine -/
def sinh (x : ℝ) : ℝ := complex.re (complex.sinh ↑x)

/-- The real hypebolic cosine function, defined as the real part of the complex hyperbolic cosine -/
def cosh (x : ℝ) : ℝ := complex.re (complex.cosh ↑x)

/-- The real hypebolic tangent function, defined as the real part of
the complex hyperbolic tangent -/
def tanh (x : ℝ) : ℝ := complex.re (complex.tanh ↑x)

end real

namespace complex

@[simp] theorem exp_zero : exp 0 = 1 := sorry

theorem exp_add (x : ℂ) (y : ℂ) : exp (x + y) = exp x * exp y := sorry

theorem exp_list_sum (l : List ℂ) : exp (list.sum l) = list.prod (list.map exp l) :=
  monoid_hom.map_list_prod (monoid_hom.mk exp exp_zero exp_add) l

theorem exp_multiset_sum (s : multiset ℂ) :
    exp (multiset.sum s) = multiset.prod (multiset.map exp s) :=
  monoid_hom.map_multiset_prod (monoid_hom.mk exp exp_zero exp_add) s

theorem exp_sum {α : Type u_1} (s : finset α) (f : α → ℂ) :
    exp (finset.sum s fun (x : α) => f x) = finset.prod s fun (x : α) => exp (f x) :=
  monoid_hom.map_prod (monoid_hom.mk exp exp_zero exp_add) f s

theorem exp_nat_mul (x : ℂ) (n : ℕ) : exp (↑n * x) = exp x ^ n := sorry

theorem exp_ne_zero (x : ℂ) : exp x ≠ 0 := sorry

theorem exp_neg (x : ℂ) : exp (-x) = (exp x⁻¹) := sorry

theorem exp_sub (x : ℂ) (y : ℂ) : exp (x - y) = exp x / exp y := sorry

@[simp] theorem exp_conj (x : ℂ) : exp (coe_fn conj x) = coe_fn conj (exp x) := sorry

@[simp] theorem of_real_exp_of_real_re (x : ℝ) : ↑(re (exp ↑x)) = exp ↑x :=
  iff.mp eq_conj_iff_re
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn conj (exp ↑x) = exp ↑x)) (Eq.symm (exp_conj ↑x))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (exp (coe_fn conj ↑x) = exp ↑x)) (conj_of_real x)))
        (Eq.refl (exp ↑x))))

@[simp] theorem of_real_exp (x : ℝ) : ↑(real.exp x) = exp ↑x := of_real_exp_of_real_re x

@[simp] theorem exp_of_real_im (x : ℝ) : im (exp ↑x) = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (im (exp ↑x) = 0)) (Eq.symm (of_real_exp_of_real_re x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (im ↑(re (exp ↑x)) = 0)) (of_real_im (re (exp ↑x)))))
      (Eq.refl 0))

theorem exp_of_real_re (x : ℝ) : re (exp ↑x) = real.exp x := rfl

theorem two_sinh (x : ℂ) : bit0 1 * sinh x = exp x - exp (-x) :=
  mul_div_cancel' (exp x - exp (-x)) two_ne_zero'

theorem two_cosh (x : ℂ) : bit0 1 * cosh x = exp x + exp (-x) :=
  mul_div_cancel' (exp x + exp (-x)) two_ne_zero'

@[simp] theorem sinh_zero : sinh 0 = 0 := sorry

@[simp] theorem sinh_neg (x : ℂ) : sinh (-x) = -sinh x := sorry

theorem sinh_add (x : ℂ) (y : ℂ) : sinh (x + y) = sinh x * cosh y + cosh x * sinh y := sorry

@[simp] theorem cosh_zero : cosh 0 = 1 := sorry

@[simp] theorem cosh_neg (x : ℂ) : cosh (-x) = cosh x := sorry

theorem cosh_add (x : ℂ) (y : ℂ) : cosh (x + y) = cosh x * cosh y + sinh x * sinh y := sorry

theorem sinh_sub (x : ℂ) (y : ℂ) : sinh (x - y) = sinh x * cosh y - cosh x * sinh y := sorry

theorem cosh_sub (x : ℂ) (y : ℂ) : cosh (x - y) = cosh x * cosh y - sinh x * sinh y := sorry

theorem sinh_conj (x : ℂ) : sinh (coe_fn conj x) = coe_fn conj (sinh x) := sorry

@[simp] theorem of_real_sinh_of_real_re (x : ℝ) : ↑(re (sinh ↑x)) = sinh ↑x :=
  iff.mp eq_conj_iff_re
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn conj (sinh ↑x) = sinh ↑x)) (Eq.symm (sinh_conj ↑x))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (sinh (coe_fn conj ↑x) = sinh ↑x)) (conj_of_real x)))
        (Eq.refl (sinh ↑x))))

@[simp] theorem of_real_sinh (x : ℝ) : ↑(real.sinh x) = sinh ↑x := of_real_sinh_of_real_re x

@[simp] theorem sinh_of_real_im (x : ℝ) : im (sinh ↑x) = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (im (sinh ↑x) = 0)) (Eq.symm (of_real_sinh_of_real_re x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (im ↑(re (sinh ↑x)) = 0)) (of_real_im (re (sinh ↑x)))))
      (Eq.refl 0))

theorem sinh_of_real_re (x : ℝ) : re (sinh ↑x) = real.sinh x := rfl

theorem cosh_conj (x : ℂ) : cosh (coe_fn conj x) = coe_fn conj (cosh x) := sorry

@[simp] theorem of_real_cosh_of_real_re (x : ℝ) : ↑(re (cosh ↑x)) = cosh ↑x :=
  iff.mp eq_conj_iff_re
    (eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn conj (cosh ↑x) = cosh ↑x)) (Eq.symm (cosh_conj ↑x))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (cosh (coe_fn conj ↑x) = cosh ↑x)) (conj_of_real x)))
        (Eq.refl (cosh ↑x))))

@[simp] theorem of_real_cosh (x : ℝ) : ↑(real.cosh x) = cosh ↑x := of_real_cosh_of_real_re x

@[simp] theorem cosh_of_real_im (x : ℝ) : im (cosh ↑x) = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (im (cosh ↑x) = 0)) (Eq.symm (of_real_cosh_of_real_re x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (im ↑(re (cosh ↑x)) = 0)) (of_real_im (re (cosh ↑x)))))
      (Eq.refl 0))

theorem cosh_of_real_re (x : ℝ) : re (cosh ↑x) = real.cosh x := rfl

theorem tanh_eq_sinh_div_cosh (x : ℂ) : tanh x = sinh x / cosh x := rfl

@[simp] theorem tanh_zero : tanh 0 = 0 := sorry

@[simp] theorem tanh_neg (x : ℂ) : tanh (-x) = -tanh x :=


import Scratch.ExprAppl
import Lean.Meta
open Lean
open Meta
open Lean.Elab.Tactic

syntax (name:= introsFind) "introsFind" (term)? : tactic
@[tactic introsFind] def introsfindImpl : Tactic :=
  fun stx  =>
  match stx with
  | `(tactic|introsFind) =>
    withMainContext do
      let mvar ← getMainGoal
      let ⟨intVars, codmvar⟩ ← Meta.intros mvar
      withMVarContext codmvar do
        let expVars := intVars.toList.map (fun x => mkFVar x)
        let target ←  getMVarType codmvar
        let oneStep ← applyPairsMeta expVars
        let found ← typInList? target oneStep
        match found with
        | some x =>
          do
            assignExprMVar codmvar x
            replaceMainGoal []
            return ()
        | none =>
          throwTacticEx `findInSeq mvar m!"did not find {target} in sequence"
          return ()
  | `(tactic|introsFind $t) =>
    withMainContext do
      let n : Nat <- t.isNatLit?.getD 0
      let mvar ← getMainGoal
      let ⟨intVars, codmvar⟩ ← Meta.intros mvar
      withMVarContext codmvar do
        let expVars := intVars.toList.map (fun x => mkFVar x)
        let target ←  getMVarType codmvar
        let oneStep ← iterApplyPairsMeta n expVars
        let found ← typInList? target oneStep
        match found with
        | some x =>
          do
            assignExprMVar codmvar x
            replaceMainGoal []
            return ()
        | none =>
          throwTacticEx `findInSeq mvar m!"did not find {target} in sequence"
          return ()
  | _ => Elab.throwIllFormedSyntax

def mmodusPonens {α β : Type} : α → (α → β) → β := by
      introsFind

def mmodus_ponens (α β : Prop) : α → (α → β) → β := by
      introsFind

#print mmodusPonens
#print mmodus_ponens

def constantFunc (α β : Type)  : α → β → α  := by
      introsFind

def constant_implica (α β : Prop)  : α → β → α := by
      introsFind

def reflImpll (α : Prop) : α → α  := by
      introsFind

def autoIdd (α : Type) : α → α := by
      introsFind

#print autoIdd

theorem doublleMP{α β γ : Prop} : α → (α → β) →  (β →  γ) → γ  := by
      introsFind 2


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import tactic.interactive

/-!
# `dec_trivial` tactic

The `dec_trivial` tactic tries to use decidability to prove a goal.
It is basically a glorified wrapper around `exact dec_trivial`.

There is an extra option to make it a little bit smarter:
`dec_trivial!` will revert all hypotheses on which the target depends,
before it tries `exact dec_trivial`.
-/
open tactic.interactive

setup_tactic_parser

/-- `dec_trivial` tries to use decidability to prove a goal
(i.e., using `exact dec_trivial`).
The variant `dec_trivial!` will revert all hypotheses on which the target depends,
before it tries `exact dec_trivial`.

Example:
```lean
example (n : ℕ) (h : n < 2) : n = 0 ∨ n = 1 :=
by dec_trivial!
```
-/
meta def tactic.interactive.dec_trivial (revert_deps : parse (tk "!")?) : tactic unit :=
if revert_deps.is_some
then revert_target_deps; tactic.exact_dec_trivial
else tactic.exact_dec_trivial

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


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

Converter monad for building simplifiers.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.tactic
import Mathlib.Lean3Lib.init.meta.simp_tactic
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.meta.congr_lemma
import Mathlib.Lean3Lib.init.meta.match_tactic

namespace Mathlib

/-- `conv α` is a tactic for discharging goals of the form `lhs ~ rhs` for some relation `~` (usually equality) and fixed lhs, rhs.
Known in the literature as a __conversion__ tactic.
So for example, if one had the lemma `p : x = y`, then the conversion for `p` would be one that solves `p`.
-/
end Mathlib


theorem very_easy : true :=
begin
  sorry
end


import topology.category.Profinite.cofiltered_limit
import topology.discrete_quotient

import for_mathlib.order

noncomputable theory

open_locale classical

namespace Profinite

open category_theory
open category_theory.limits

universe u

variables {J : Type u} [semilattice_inf J] (F : J ⥤ Profinite.{u}) (C : cone F)

lemma image_eq (hC : is_limit C) (i : J) :
  set.range (C.π.app i) = ⋂ (j : J) (h : j ≤ i), set.range (F.map (hom_of_le h)) :=
begin
  refine le_antisymm _ _,
  { apply set.subset_Inter,
    intros j,
    apply set.subset_Inter,
    intros hj,
    rw ← C.w (hom_of_le hj),
    apply set.range_comp_subset_range },
  { rintro x hx,
    have cond : ∀ (j : J) (hj : j ≤ i), ∃ y : F.obj j, (F.map (hom_of_le hj)) y = x,
    { intros j hj,
      exact hx _ ⟨j,rfl⟩ _ ⟨hj, rfl⟩ },
    let Js := Σ' (a b : J), a ≤ b,
    let P := Π (j : J), F.obj j,
    let Us : Js → set P := λ e, { p | F.map (hom_of_le e.2.2) (p (e.1)) = p (e.2.1) ∧ p i = x},
    have hP : (_root_.is_compact (set.univ : set P)) := compact_univ,
    have hh := hP.inter_Inter_nonempty Us _ _,
    { rcases hh with ⟨z,hz⟩,
      let IC : (limit_cone F) ≅ C := (limit_cone_is_limit F).unique_up_to_iso hC,
      let ICX : (limit_cone F).X ≅ C.X := (cones.forget _).map_iso IC,
      let z : (limit_cone F).X := ⟨z,_⟩,
      swap,
      { intros a b h,
        convert (hz.2 _ ⟨⟨a, b, le_of_hom h⟩, rfl⟩).1 },
      use ICX.hom z,
      change (hC.lift _ ≫ _) _ = _,
      rw hC.fac,
      exact (hz.2 _ ⟨⟨i,i,le_refl _⟩,rfl⟩).2 },
    { intros i,
      refine is_closed.inter (is_closed_eq _ _) (is_closed_eq _ _);
      continuity },
    { have : ∀ e : J, nonempty (F.obj e),
      { intros e,
        rcases cond (e ⊓ i) inf_le_right with ⟨y,rfl⟩,
        use F.map (hom_of_le inf_le_left) y },
      haveI : ∀ j : J, inhabited (F.obj j) :=
        by {intros j, refine ⟨nonempty.some (this j)⟩},
      intros G,
      let GG := G.image (λ e : Js, e.1),
      haveI : inhabited J := ⟨i⟩,
      have := exists_le_finset (insert i GG),
      obtain ⟨j0,hj0⟩ := this,
      obtain ⟨x0,rfl⟩ := cond j0 (hj0 _ (finset.mem_insert_self _ _)),
      let z : P := λ e, if h : j0 ≤ e then F.map (hom_of_le h) x0 else default,
      use z,
      refine ⟨trivial, _⟩,
      rintros S ⟨e,rfl⟩,
      rintro T ⟨k,rfl⟩,
      dsimp [z],
      refine ⟨_, by erw dif_pos⟩,
      have : j0 ≤ e.fst,
      { apply hj0,
        apply finset.mem_insert_of_mem,
        rw finset.mem_image,
        refine ⟨e,k,rfl⟩ },
      erw [dif_pos this, dif_pos (le_trans this e.2.2)],
      change (F.map _ ≫ F.map _) _ = _,
      rw ← F.map_comp,
      refl } }
end

set_option pp.proofs true

lemma image_stabilizes [inhabited J] [∀ i, fintype (F.obj i)]
  (i : J) : ∃ (j : J) (hj : j ≤ i), ∀ (k : J) (hk : k ≤ j),
  set.range (F.map (hom_of_le $ le_trans hk hj)) =
  set.range (F.map (hom_of_le hj)) :=
begin
  have := eventually_constant i
    (λ e he, set.range (F.map (hom_of_le he))) _,
  swap,
  { intros a b ha hb h,
    dsimp,
    have : hom_of_le ha = (hom_of_le h) ≫ (hom_of_le hb) := rfl,
    rw [this, F.map_comp, Profinite.coe_comp],
    apply set.range_comp_subset_range },
  obtain ⟨j0,hj0,hh⟩ := this,
  use j0, use hj0,
  exact hh,
end

/-- The images of the transition maps stabilize, in which case they agree with
the image of the cone point. -/
theorem exists_image [inhabited J] [∀ i, fintype (F.obj i)]
  (hC : is_limit C) (i : J) : ∃ (j : J) (hj : j ≤ i),
  set.range (C.π.app i) = set.range (F.map $ hom_of_le $ hj) :=
begin
  have := Inter_eq i (λ e he, set.range (F.map (hom_of_le he))) _,
  swap,
  { intros a b ha hb hh,
    dsimp,
    have : hom_of_le ha = hom_of_le hh ≫ hom_of_le hb, refl,
    rw [this, F.map_comp, Profinite.coe_comp],
    apply set.range_comp_subset_range },
  obtain ⟨j0,hj0,hh⟩ := this,
  dsimp at hh,
  use j0, use hj0,
  rw [image_eq _ _ hC, ← hh],
end

end Profinite


import Lean

example : True := by
  apply True.intro
      --^ textDocument/hover

example : True := by
  simp [True.intro]
      --^ textDocument/hover

example (n : Nat) : True := by
  match n with
  | Nat.zero => _
  --^ textDocument/hover
  | n + 1 => _

/-- My tactic -/
macro "mytac" o:"only"? e:term : tactic => `(exact $e)

example : True := by
  mytac only True.intro
--^ textDocument/hover
      --^ textDocument/hover
           --^ textDocument/hover

/-- My way better tactic -/
macro_rules
  | `(tactic| mytac $[only]? $e) => `(apply $e)

example : True := by
  mytac only True.intro
--^ textDocument/hover

/-- My ultimate tactic -/
elab_rules : tactic
  | `(tactic| mytac $[only]? $e) => `(tactic| refine $e) >>= Lean.Elab.Tactic.evalTactic

example : True := by
  mytac only True.intro
--^ textDocument/hover

/-- My notation -/
macro "mynota" e:term : term => e

#check mynota 1
     --^ textDocument/hover

/-- My way better notation -/
macro_rules
  | `(mynota $e) => `(2 * $e)

#check mynota 1
     --^ textDocument/hover

-- macro_rules take precedence over elab_rules for term/command, so use new syntax
syntax "mynota'" term : term

/-- My ultimate notation -/
elab_rules : term
  | `(mynota' $e) => `($e * $e) >>= (Lean.Elab.Term.elabTerm · none)

#check mynota' 1
     --^ textDocument/hover

/-- My command -/
macro "mycmd" e:term : command => `(def hi := $e)

mycmd 1
--^ textDocument/hover

/-- My way better command -/
macro_rules
  | `(mycmd $e) => `(@[inline] def hi := $e)

mycmd 1
--^ textDocument/hover

syntax "mycmd'" term : command
/-- My ultimate command -/
elab_rules : command
  | `(mycmd' $e) => `(/-- hi -/ @[inline] def hi := $e) >>= Lean.Elab.Command.elabCommand

mycmd' 1
--^ textDocument/hover

#check ({ a := })  -- should not show `sorry`
        --^ textDocument/hover

example : True := by
  simp [id True.intro]
      --^ textDocument/hover
        --^ textDocument/hover

example : Id Nat := do
  let mut n := 1
  n := 2
--^ textDocument/hover
  n