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

/-!
# Transport multiplicative to additive

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

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

### Missing features

* Automatically transport structures and other inductive types.

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

namespace to_additive
open tactic
setup_tactic_parser

section performance_hack -- see Note [user attribute parameters]

local attribute [semireducible] reflected

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

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

end performance_hack

section extra_attributes

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

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

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

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

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

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

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

end extra_attributes

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

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

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

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

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

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

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

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

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

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

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

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

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

To use this attribute, just write:

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

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

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

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

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

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

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

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

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

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

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

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

## Implementation notes

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

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

### Heuristics

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

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

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

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

There are some exceptions to this heuristic:

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

### Troubleshooting

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

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

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

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

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

### Handling of hidden definitions

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

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

### Structure fields and constructors

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

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

### Name generation

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

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

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

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

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

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

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

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

end to_additive

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

section linter

open tactic expr

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

end linter


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

! This file was ported from Lean 3 source module tactic.congr
! leanprover-community/mathlib commit 28b66e1a5de3072ff425b43cf9ebb9a03312b435
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Lint.Default
import Mathbin.Tactic.Ext

/-!
# Congruence and related tactics

This file contains the tactic `congr'`, which is an extension of `congr`, and various tactics
using `congr'` internally.

`congr'` has some advantages over `congr`:
* It turns `↔` to equalities, before trying another congr lemma
* You can write `congr' n` to give the maximal depth of recursive applications. This is useful if
  `congr` breaks down the goal to aggressively, and the resulting goals are false.
* You can write `congr' with ...` to do `congr', ext ...` in a single tactic.

Other tactics in this file:
* `rcongr`: repeatedly apply `congr'` and `ext.`
* `convert`: like `exact`, but produces an equality goal if the type doesn't match.
* `convert_to`: changes the goal, if you prove an equality between the old goal and the new goal.
* `ac_change`: like `convert_to`, but uses `ac_refl` to discharge the goals.
-/

open Tactic

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
namespace Tactic

/-- Apply the constant `iff_of_eq` to the goal. -/
unsafe def apply_iff_congr_core : tactic Unit :=
  applyc `` iff_of_eq
#align tactic.apply_iff_congr_core tactic.apply_iff_congr_core

/-- The main part of the body for the loop in `congr'`. This will try to replace a goal `f x = f y`
 with `x = y`. Also has support for `==` and `↔`. -/
unsafe def congr_core' : tactic Unit := do
  let tgt ← target
  apply_eq_congr_core tgt <|>
      apply_heq_congr_core <|> apply_iff_congr_core <|> fail "congr tactic failed"
#align tactic.congr_core' tactic.congr_core'

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      The main function in `convert_to`. Changes the goal to `r` and a proof obligation that the goal
        is equal to `r`. -/
    unsafe
  def
    convert_to_core
    ( r : pexpr ) : tactic Unit
    := do let tgt ← target let h ← to_expr ` `( ( _ : $ ( tgt ) = $ ( r ) ) ) rewrite_target h swap
#align tactic.convert_to_core tactic.convert_to_core

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Attempts to prove the goal by proof irrelevance, but avoids unifying universe metavariables
to do so. -/
unsafe def by_proof_irrel : tactic Unit := do
  let tgt ← target
  let @expr.const tt n [level.zero] ← pure tgt.get_app_fn
  if n = `` Eq then sorry else if n = `` HEq then sorry else failed
#align tactic.by_proof_irrel tactic.by_proof_irrel

/-- Same as the `congr` tactic, but takes an optional argument which gives
the depth of recursive applications.
* This is useful when `congr` is too aggressive in breaking down the goal.
* For example, given `⊢ f (g (x + y)) = f (g (y + x))`, `congr'` produces the goals `⊢ x = y`
  and `⊢ y = x`, while `congr' 2` produces the intended `⊢ x + y = y + x`.
* If, at any point, a subgoal matches a hypothesis then the subgoal will be closed.
-/
unsafe def congr' : Option ℕ → tactic Unit
  | o =>
    focus1 <|
      assumption <|>
        reflexivity Transparency.none <|>
          by_proof_irrel <|>
            (guard (o ≠ some 0) >> congr_core') >> all_goals' (try (congr' (Nat.pred <$> o))) <|>
              reflexivity
#align tactic.congr' tactic.congr'

namespace Interactive

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- Same as the `congr` tactic, but takes an optional argument which gives
the depth of recursive applications.
* This is useful when `congr` is too aggressive in breaking down the goal.
* For example, given `⊢ f (g (x + y)) = f (g (y + x))`, `congr'` produces the goals `⊢ x = y`
  and `⊢ y = x`, while `congr' 2` produces the intended `⊢ x + y = y + x`.
* If, at any point, a subgoal matches a hypothesis then the subgoal will be closed.
* You can use `congr' with p (: n)?` to call `ext p (: n)?` to all subgoals generated by `congr'`.
  For example, if the goal is `⊢ f '' s = g '' s` then `congr' with x` generates the goal
  `x : α ⊢ f x = g x`.
-/
unsafe def congr' (n : parse (parser.optional (with_desc "n" small_nat))) :
    parse
        (parser.optional
          (tk "with" *> Prod.mk <$> parser.many rintro_patt_parse_hi <*>
            parser.optional (tk ":" *> small_nat))) →
      tactic Unit
  | none => tactic.congr' n
  | some ⟨p, m⟩ => focus1 (tactic.congr' n >> all_goals' (tactic.ext p.join m $> ()))
#align tactic.interactive.congr' tactic.interactive.congr'

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
/-- Repeatedly and apply `congr'` and `ext`, using the given patterns as arguments for `ext`.

There are two ways this tactic stops:
* `congr'` fails (makes no progress), after having already applied `ext`.
* `congr'` canceled out the last usage of `ext`. In this case, the state is reverted to before
  the `congr'` was applied.

For example, when the goal is
```lean
⊢ (λ x, f x + 3) '' s = (λ x, g x + 3) '' s
```
then `rcongr x` produces the goal
```lean
x : α ⊢ f x = g x
```
This gives the same result as `congr', ext x, congr'`.

In contrast, `congr'` would produce
```lean
⊢ (λ x, f x + 3) = (λ x, g x + 3)
```
and `congr' with x` (or `congr', ext x`) would produce
```lean
x : α ⊢ f x + 3 = g x + 3
```
-/
unsafe def rcongr : parse (List.join <$> parser.many rintro_patt_parse_hi) → tactic Unit
  | ps => do
    let t ← target
    let qs ← try_core (tactic.ext ps none)
    let some () ←
      try_core
          (tactic.congr' none >>
            (done <|> do
              let s ← target
              guard <| ¬s == t)) |
      skip
    done <|> rcongr (qs ps)
#align tactic.interactive.rcongr tactic.interactive.rcongr

add_tactic_doc
  { Name := "congr'"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.congr', `tactic.interactive.congr, `tactic.interactive.rcongr]
    tags := ["congruence"]
    inheritDescriptionFrom := `tactic.interactive.congr' }

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      The `exact e` and `refine e` tactics require a term `e` whose type is
      definitionally equal to the goal. `convert e` is similar to `refine e`,
      but the type of `e` is not required to exactly match the
      goal. Instead, new goals are created for differences between the type
      of `e` and the goal. For example, in the proof state

      ```lean
      n : ℕ,
      e : prime (2 * n + 1)
      ⊢ prime (n + n + 1)
      ```

      the tactic `convert e` will change the goal to

      ```lean
      ⊢ n + n = 2 * n
      ```

      In this example, the new goal can be solved using `ring`.

      The `convert` tactic applies congruence lemmas eagerly before reducing,
      therefore it can fail in cases where `exact` succeeds:
      ```lean
      def p (n : ℕ) := true
      example (h : p 0) : p 1 := by exact h -- succeeds
      example (h : p 0) : p 1 := by convert h -- fails, with leftover goal `1 = 0`
      ```

      If `x y : t`, and an instance `subsingleton t` is in scope, then any goals of the form
      `x = y` are solved automatically.

      The syntax `convert ← e` will reverse the direction of the new goals
      (producing `⊢ 2 * n = n + n` in this example).

      Internally, `convert e` works by creating a new goal asserting that
      the goal equals the type of `e`, then simplifying it using
      `congr'`. The syntax `convert e using n` can be used to control the
      depth of matching (like `congr' n`). In the example, `convert e using
      1` would produce a new goal `⊢ n + n + 1 = 2 * n + 1`.
      -/
    unsafe
  def
    convert
    ( sym : parse ( with_desc "←" ( parser.optional ( tk "<-" ) ) ) )
        ( r : parse texpr )
        ( n : parse ( parser.optional ( tk "using" *> small_nat ) ) )
      : tactic Unit
    :=
      do
        let tgt ← target
          let u ← infer_type tgt
          let r ← i_to_expr ` `( ( $ ( r ) : ( _ : $ ( u ) ) ) )
          let src ← infer_type r
          let src ← simp_lemmas.mk . dsimplify [ ] src { failIfUnchanged := false }
          let
            v
              ←
              to_expr
                  (
                      if
                        Sym . isSome
                        then
                        ` `( $ ( src ) = $ ( tgt ) )
                        else
                        ` `( $ ( tgt ) = $ ( src ) )
                      )
                    true
                    false
                >>=
                mk_meta_var
          ( if Sym then mk_eq_mp v r else mk_eq_mpr v r ) >>= tactic.exact
          let gs ← get_goals
          set_goals [ v ]
          try ( tactic.congr' n )
          let gs' ← get_goals
          set_goals <| gs' ++ gs
#align tactic.interactive.convert tactic.interactive.convert

add_tactic_doc
  { Name := "convert"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.convert]
    tags := ["congruence"] }

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `convert_to g using n` attempts to change the current goal to `g`, but unlike `change`,
it will generate equality proof obligations using `congr' n` to resolve discrepancies.
`convert_to g` defaults to using `congr' 1`.

`convert_to` is similar to `convert`, but `convert_to` takes a type (the desired subgoal) while
`convert` takes a proof term.
That is, `convert_to g using n` is equivalent to `convert (_ : g) using n`.
-/
unsafe def convert_to (r : parse texpr) (n : parse (parser.optional (tk "using" *> small_nat))) :
    tactic Unit :=
  match n with
  | none => convert_to_core r >> sorry
  | some 0 => convert_to_core r
  | some o => convert_to_core r >> tactic.congr' o
#align tactic.interactive.convert_to tactic.interactive.convert_to

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- `ac_change g using n` is `convert_to g using n` followed by `ac_refl`. It is useful for
rearranging/reassociating e.g. sums:
```lean
example (a b c d e f g N : ℕ) : (a + b) + (c + d) + (e + f) + g ≤ N :=
begin
  ac_change a + d + e + f + c + g + b ≤ _,
-- ⊢ a + d + e + f + c + g + b ≤ N
end
```

##  Related tactic: `move_add`
In the case in which the expression to be changed is a sum of terms, tactic
`tactive.interactive.move_add` can also be useful. -/
unsafe def ac_change (r : parse texpr) (n : parse (parser.optional (tk "using" *> small_nat))) :
    tactic Unit :=
  andthen (convert_to r n) (try ac_refl)
#align tactic.interactive.ac_change tactic.interactive.ac_change

add_tactic_doc
  { Name := "convert_to"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.convert_to, `tactic.interactive.ac_change]
    tags := ["congruence"]
    inheritDescriptionFrom := `tactic.interactive.convert_to }

end Interactive

end Tactic


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Sebastien Gouezel, Scott Morrison
-/
import data.dlist data.dlist.basic data.prod category.basic
  tactic.basic tactic.rcases tactic.generalize_proofs
  tactic.split_ifs logic.basic tactic.ext tactic.tauto tactic.replacer

open lean
open lean.parser

local postfix `?`:9001 := optional
local postfix *:9001 := many

namespace tactic
namespace interactive
open interactive interactive.types expr

/--
The `rcases` tactic is the same as `cases`, but with more flexibility in the
`with` pattern syntax to allow for recursive case splitting. The pattern syntax
uses the following recursive grammar:

```
patt ::= (patt_list "|")* patt_list
patt_list ::= id | "_" | "⟨" (patt ",")* patt "⟩"
```

A pattern like `⟨a, b, c⟩ | ⟨d, e⟩` will do a split over the inductive datatype,
naming the first three parameters of the first constructor as `a,b,c` and the
first two of the second constructor `d,e`. If the list is not as long as the
number of arguments to the constructor or the number of constructors, the
remaining variables will be automatically named. If there are nested brackets
such as `⟨⟨a⟩, b | c⟩ | d` then these will cause more case splits as necessary.
If there are too many arguments, such as `⟨a, b, c⟩` for splitting on
`∃ x, ∃ y, p x`, then it will be treated as `⟨a, ⟨b, c⟩⟩`, splitting the last
parameter as necessary.

`rcases` also has special support for quotient types: quotient induction into Prop works like
matching on the constructor `quot.mk`.

`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
meta def rcases : parse rcases_parse → tactic unit
| (p, sum.inl ids) := tactic.rcases p ids
| (p, sum.inr depth) := do
  patt ← tactic.rcases_hint p depth,
  pe ← pp p,
  trace $ ↑"snippet: rcases " ++ pe ++ " with " ++ to_fmt patt

/--
The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintros (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.

`rintro?` will introduce and case split on variables in the same way as
`rintro`, but will also print the `rintro` invocation that would have the same
result. Like `rcases?`, `rintro? : n` allows for modifying the
depth of splitting; the default is 5.
-/
meta def rintro : parse rintro_parse → tactic unit
| (sum.inl []) := intros []
| (sum.inl l)  := tactic.rintro l
| (sum.inr depth) := do
  ps ← tactic.rintro_hint depth,
  trace $ ↑"snippet: rintro" ++ format.join (ps.map $ λ p,
    format.space ++ format.group (p.format tt))

/-- Alias for `rintro`. -/
meta def rintros := rintro

/--
This is a "finishing" tactic modification of `simp`. The tactic `simpa [rules, ...] using e`
will simplify the hypothesis `e` using `rules`, then simplify the goal using `rules`, and
try to close the goal using `assumption`. If `e` is a term instead of a local constant,
it is first added to the local context using `have`.
-/
meta def simpa (use_iota_eqn : parse $ (tk "!")?) (no_dflt : parse only_flag)
  (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
  (tgt : parse (tk "using" *> texpr)?) (cfg : simp_config_ext := {}) : tactic unit :=
let simp_at (lc) := try (simp use_iota_eqn no_dflt hs attr_names (loc.ns lc) cfg) >> (assumption <|> trivial) in
match tgt with
| none := get_local `this >> simp_at [some `this, none] <|> simp_at [none]
| some e := do
  e ← i_to_expr e <|> do {
    ty ← target,
    e ← i_to_expr_strict ``(%%e : %%ty), -- for positional error messages, don't care about the result
    pty ← pp ty, ptgt ← pp e,
    -- Fail deliberately, to advise regarding `simp; exact` usage
    fail ("simpa failed, 'using' expression type not directly " ++
      "inferrable. Try:\n\nsimpa ... using\nshow " ++
      to_fmt pty ++ ",\nfrom " ++ ptgt : format) },
  match e with
  | local_const _ lc _ _ := simp_at [some lc, none]
  | e := do
    t ← infer_type e,
    assertv `this t e >> simp_at [some `this, none]
  end
end

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

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

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

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

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

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

/-- Move goal `n` to the front. -/
meta def swap (n := 2) : tactic unit :=
do gs ← get_goals,
   match gs.nth (n-1) with
   | (some g) := set_goals (g :: gs.remove_nth (n-1))
   | _        := skip
   end

/-- Generalize proofs in the goal, naming them with the provided list. -/
meta def generalize_proofs : parse ident_* → tactic unit :=
tactic.generalize_proofs

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

/--
Same as the `congr` tactic, but takes an optional argument which gives
the depth of recursive applications. This is useful when `congr`
is too aggressive in breaking down the goal. For example, given
`⊢ f (g (x + y)) = f (g (y + x))`, `congr'` produces the goals `⊢ x = y`
and `⊢ y = x`, while `congr' 2` produces the intended `⊢ x + y = y + x`. -/
meta def congr' : parse (with_desc "n" small_nat)? → tactic unit
| (some 0) := failed
| o        := focus1 (assumption <|> (congr_core >>
  all_goals (reflexivity <|> try (congr' (nat.pred <$> o)))))

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

/--
`apply_assumption` looks for an assumption of the form `... → ∀ _, ... → head`
where `head` matches the current goal.

alternatively, when encountering an assumption of the form `sg₀ → ¬ sg₁`,
after the main approach failed, the goal is dismissed and `sg₀` and `sg₁`
are made into the new goal.

optional arguments:
- asms: list of rules to consider instead of the local constants
- tac:  a tactic to run on each subgoals after applying an assumption; if
        this tactic fails, the corresponding assumption will be rejected and
        the next one will be attempted.
-/
meta def apply_assumption
  (asms : option (list expr) := none)
  (tac : tactic unit := return ()) : tactic unit :=
tactic.apply_assumption asms tac

open nat

/--
`solve_by_elim` calls `apply_assumption` on the main goal to find an assumption whose head matches
and repeated calls `apply_assumption` on the generated subgoals until no subgoals remains
or up to `depth` times.

`solve_by_elim` discharges the current goal or fails

`solve_by_elim` does some back-tracking if `apply_assumption` chooses an unproductive assumption

optional arguments:
- discharger: a subsidiary tactic to try at each step (`cc` is often helpful)
- asms: list of assumptions / rules to consider instead of local constants
- depth: number of attempts at discharging generated sub-goals

The optional arguments can be specified as ``solve_by_elim { discharger := `[cc] }``.
-/
meta def solve_by_elim (opt : by_elim_opt := { }) : tactic unit :=
tactic.solve_by_elim opt

/--
`tautology` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`
-/
meta def tautology := tactic.tautology

/-- Shorter name for the tactic `tautology`. -/
meta def tauto := tautology

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

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

lemma {u} generalize_a_aux {α : Sort u}
  (h : ∀ x : Sort u, (α → x) → x) : α := h α id

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

/--
Similar to `refine` but generates equality proof obligations
for every discrepancy between the goal and the type of the rule.
-/
meta def convert (sym : parse (with_desc "←" (tk "<-")?)) (r : parse texpr) (n : parse (tk "using" *> small_nat)?) : tactic unit :=
do v ← mk_mvar,
   if sym.is_some
     then refine ``(eq.mp %%v %%r)
     else refine ``(eq.mpr %%v %%r),
   gs ← get_goals,
   set_goals [v],
   congr' n,
   gs' ← get_goals,
   set_goals $ gs' ++ gs

meta def clean_ids : list name :=
[``id, ``id_rhs, ``id_delta]

/--
Remove identity functions from a term. These are normally
automatically generated with terms like `show t, from p` or
`(p : t)` which translate to some variant on `@id t p` in
order to retain the type. -/
meta def clean (q : parse texpr) : tactic unit :=
do tgt : expr ← target,
   e ← i_to_expr_strict ``(%%q : %%tgt),
   tactic.exact $ e.replace (λ e n,
     match e with
     | (app (app (const n _) _) e') :=
       if n ∈ clean_ids then some e' else none
     | (app (lam _ _ _ (var 0)) e') := some e'
     | _ := none
     end)

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

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

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

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

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

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

As an example, we can use `refine_struct` to automate the construction semigroup
instances:
```
refine_struct ( { .. } : semigroup α ),
-- case semigroup, mul
-- α : Type u,
-- ⊢ α → α → α

-- case semigroup, mul_assoc
-- α : Type u,
-- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)
```
-/
meta def refine_struct : parse texpr → tactic unit | e :=
do (x,xs) ← collect_struct e,
   refine x,
   gs ← get_goals,
   xs' ← xs.mmap refine_recursively,
   set_goals (xs'.join ++ gs)

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

meta def guard_hyp_nums (n : ℕ) : tactic unit :=
do k ← local_context,
   guard (n = k.length) <|> fail format!"{k.length} hypotheses found"

meta def guard_tags (tags : parse ident*) : tactic unit :=
do (t : list name) ← get_main_tag,
   guard (t = tags)

meta def get_current_field : tactic name :=
do [_,field,str] ← get_main_tag,
   expr.const_name <$> resolve_name (field.update_prefix str)

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

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

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

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

/--`apply_rules hs n`: apply the list of rules `hs` (given as pexpr) and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times.
`n` is 50 by default. `hs` can contain user attributes: in this case all theorems with this
attribute are added to the list of rules.

example, with or without user attribute:
```
@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }

attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

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

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

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

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

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

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

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

`h_generalize Hx : e == x with h` adds hypothesis `α = β` with `e : α, x : β`.

`h_generalize Hx : e == x with _` chooses automatically chooses the name of
assumption `α = β`.

`h_generalize! Hx : e == x` reverts `Hx`.

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

end interactive
end tactic


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

import logic.function.basic
import tactic.lint
import tactic.norm_cast

/-!
# Typeclass for a type `F` with an injective map to `A → B`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This typeclass is primarily for use by homomorphisms like `monoid_hom` and `linear_map`.

## Basic usage of `fun_like`

A typical type of morphisms should be declared as:
```
structure my_hom (A B : Type*) [my_class A] [my_class B] :=
(to_fun : A → B)
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_hom

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "morphism class" design below:
instance : fun_like (my_hom A B) A (λ _, B) :=
{ coe := my_hom.to_fun, coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
instance : has_coe_to_fun (my_hom A B) (λ _, A → B) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : my_hom A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_hom A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_hom A B) (f' : A → B) (h : f' = ⇑f) : my_hom A B :=
{ to_fun := f',
  map_op' := h.symm ▸ f.map_op' }

end my_hom
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Morphism classes extending `fun_like`

The `fun_like` design provides further benefits if you put in a bit more work.
The first step is to extend `fun_like` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
section
set_option old_structure_cmd true

/-- `my_hom_class F A B` states that `F` is a type of `my_class.op`-preserving morphisms.
You should extend this class when you extend `my_hom`. -/
class my_hom_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends fun_like F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (my_class.op x y) = my_class.op (f x) (f y))

end
@[simp] lemma map_op {F A B : Type*} [my_class A] [my_class B] [my_hom_class F A B]
  (f : F) (x y : A) : f (my_class.op x y) = my_class.op (f x) (f y) :=
my_hom_class.map_op

-- You can replace `my_hom.fun_like` with the below instance:
instance : my_hom_class (my_hom A B) A B :=
{ coe := my_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := my_hom.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_hom_class` for all types extending `my_hom`.
Typically, you can just declare a new class analogous to `my_hom_class`:

```
structure cooler_hom (A B : Type*) [cool_class A] [cool_class B]
  extends my_hom A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

section
set_option old_structure_cmd true

class cooler_hom_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_hom_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

end

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_hom_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_hom_class.map_op

-- You can also replace `my_hom.fun_like` with the below instance:
instance : cool_hom_class (cool_hom A B) A B :=
{ coe := cool_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := cool_hom.map_op',
  map_cool := cool_hom.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_hom A B) : sorry := sorry
lemma do_something {F : Type*} [my_hom_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_hom`s will automatically work for `cool_hom_class`es,
and defining `cool_hom_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_hom`-related declaration.

-/

-- This instance should have low priority, to ensure we follow the chain
-- `fun_like → has_coe_to_fun`
attribute [instance, priority 10] coe_fn_trans

/-- The class `fun_like F α β` expresses that terms of type `F` have an
injective coercion to functions from `α` to `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `zero_hom_class`, `mul_hom_class`, `monoid_hom_class`, ....
-/
class fun_like (F : Sort*) (α : out_param Sort*) (β : out_param $ α → Sort*) :=
(coe : F → Π a : α, β a)
(coe_injective' : function.injective coe)

section dependent

/-! ### `fun_like F α β` where `β` depends on `a : α` -/

variables (F α : Sort*) (β : α → Sort*)

namespace fun_like

variables {F α β} [i : fun_like F α β]

include i

@[priority 100, -- Give this a priority between `coe_fn_trans` and the default priority
  nolint dangerous_instance] -- `α` and `β` are out_params, so this instance should not be dangerous
instance : has_coe_to_fun F (λ _, Π a : α, β a) := { coe := fun_like.coe }

@[simp]

theorem coe_injective : function.injective (coe_fn : F → Π a : α, β a) :=
fun_like.coe_injective'

@[simp, norm_cast]
theorem coe_fn_eq {f g : F} : (f : Π a : α, β a) = (g : Π a : α, β a) ↔ f = g :=
⟨λ h, @coe_injective _ _ _ i _ _ h, λ h, by cases h; refl⟩

theorem ext' {f g : F} (h : (f : Π a : α, β a) = (g : Π a : α, β a)) : f = g :=
coe_injective h

theorem ext'_iff {f g : F} : f = g ↔ ((f : Π a : α, β a) = (g : Π a : α, β a)) :=
coe_fn_eq.symm

theorem ext (f g : F) (h : ∀ (x : α), f x = g x) : f = g :=
coe_injective (funext h)

theorem ext_iff {f g : F} : f = g ↔ (∀ x, f x = g x) :=
coe_fn_eq.symm.trans function.funext_iff

protected lemma congr_fun {f g : F} (h₁ : f = g) (x : α) : f x = g x :=
congr_fun (congr_arg _ h₁) x

lemma ne_iff {f g : F} : f ≠ g ↔ ∃ a, f a ≠ g a :=
ext_iff.not.trans not_forall

lemma exists_ne {f g : F} (h : f ≠ g) : ∃ x, f x ≠ g x :=
ne_iff.mp h

/-- This is not an instance to avoid slowing down every single `subsingleton` typeclass search.-/
lemma subsingleton_cod [∀ a, subsingleton (β a)] : subsingleton F :=
⟨λ f g, coe_injective $ subsingleton.elim _ _⟩

end fun_like

end dependent

section non_dependent

/-! ### `fun_like F α (λ _, β)` where `β` does not depend on `a : α` -/

variables {F α β : Sort*} [i : fun_like F α (λ _, β)]

include i

namespace fun_like

protected lemma congr {f g : F} {x y : α} (h₁ : f = g) (h₂ : x = y) : f x = g y :=
congr (congr_arg _ h₁) h₂

protected lemma congr_arg (f : F) {x y : α} (h₂ : x = y) : f x = f y :=
congr_arg _ h₂

end fun_like

end non_dependent


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

import FxyLang.Implementation.ASTUtilities

/- Before we proceed, it's important to notice that a function that executes a
program *has* to be `partial` because programs themselves may loop forever.

This file contains two partial functions capable of running Fxy programs:
* `Program.run!` is fast but uses code that can't be reasoned on
* `Program.run` is ~50% slower, but uses a function that implements small step
semantics and thus can be reasoned on

Another important detail is that the computation of a `Program` yields an
intrinsic `Value`:
* `skip` yields `nil`
* `eval` yields the `Value` of the expression being evaluated
* `seq` yields the `Value` of the second `Program`, unless the first one causes
an error
* `fork` yields the `Value` of the child `Program` executed
* `loop` yields `nil` or an error
-/

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

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

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

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

/-- Takes a list of expressions and matches each element with an element from a
list of strings. For each match, it adds a declaration in the beginning of a
given program, returning such modified program -/
def consume (p : Program) :
    NEList String → NEList Expression →
      Option ((Option (NEList String)) × Program)
  | .cons n ns, .cons e es => consume (.seq (.decl n (.eval e)) p) ns es
  | .cons n ns, .uno  e    => some (some ns, .seq (.decl n (.eval e)) p)
  | .uno  n,    .uno  e    => some (none, .seq (.decl n (.eval e)) p)
  | .uno  _,    .cons ..   => none

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

/- Next we're going to define a pair of mutual functions:
* `reduce` computes over an expression with the goal of extracting a term of
`Result` from it, which signals either a `Value` or an error.
* `Program.run!` is similar to `reduce`, but it processes a `Program` instead

They are mutual because *i*) a program may rely on the resolution of expressions
to move forward (for instance, knowing whether to loop again or not) and *ii*)
an expression can be the application of a function, which may need to trigger
the execution of another term of `Program` (see the `app` case)
-/

mutual

  /-- Since we're already in the `partial` realm, let's allow ourselves to be
  carelessly recursive, always believing that `reduce` will compute *any*
  expression for us! -/
  partial def reduce (c : Context) : Expression → Result
    | .lit  l => .val $ .lit  l
    | .list l => .val $ .list l
    | .lam  l => .val $ .lam  l
    | .var  n => match c[n] with
      | none   => .err .name $ notFound n
      | some v => .val $ v
    | .app e es => match reduce c e with
      | .val $ .lam $ .mk ns h p => match h' : consume p ns es with
        | some (some l, p) => .val $ .lam $ .mk l (noDupOfConsumeNoDup h h') p
        | some (none, p) => (p.run! c).2
        | none => .err .runTime $ wrongNParameters e ns.length es.length
      | .val v                   => .err .type $ notAFunction e v
      | er@(.err ..)             => er
    | .unOp o e => match reduce c e with
      | .val v      => match v.unOp o with
        | .ok    v => .val v
        | .error m => .err .type m
      | er@(.err ..) => er
    | .binOp o eₗ eᵣ => match (reduce c eₗ, reduce c eᵣ) with
      | (.val vₗ, .val vᵣ) => match vₗ.binOp vᵣ o with
        | .ok    v => .val v
        | .error m => .err .type m
      | (er@(.err ..), _)        => er
      | (_, er@(.err ..))        => er

  /-- And here we can allow ourselves to be careless too, trusting on `reduce`
  as well as on `run!`! -/
  partial def Program.run! (c : Context := default) :
      Program → Context × Result
    | skip      => (c, .val .nil)
    | eval e => (c, (reduce c e))
    | seq p₁ p₂ =>
      let res := p₁.run! c
      match res.2 with
      | .err .. => res
      | _       => p₂.run! res.1
    | decl n p => match (p.run! c).2 with
      | er@(.err ..) => (c, er)
      | .val v => (c.insert n v, .val .nil)
    | fork e pT pF => match reduce c e with
      | .val $ .lit $ .bool b => if b then pT.run! c else pF.run! c
      | .val v                => (c, .err .type $ cantEvalAsBool e v)
      | er@(.err ..)          => (c, er)
    | loop e p  => match reduce c e with
      | .val $ .lit $ .bool b =>
        if !b then (c, .val .nil) else
          match p.run! c with
          | er@(_, .err ..) => er
          | (c, _)        => (loop e p).run! c
      | .val v       => (c, .err .type $ cantEvalAsBool e v)
      | er@(.err ..) => (c, er)
    | print e   => match reduce c e with
      | .val v       => dbg_trace v; (c, .val .nil)
      | er@(.err ..) => (c, er)

end

/-- This is the function that will allow us to prove results about the semantics
of Fxy. Let's dive into its details. -/
def State.step : State → State
  /- `skip` just goes straight into returning `nil` -/
  | prog c k .skip => ret c k .nil

  /- `eval` enters the `expr` state for expression evaluation -/
  | prog c k (.eval e) => expr c k e

  /- `seq` runs the first program and stacks the second -/
  | prog c k (.seq p₁ p₂) => prog c (.seq p₂ k) p₁

  /- `decl` calls for the execution of the innermost program and then stores the
  current context with the `block` continuation, which is recovered later on.
  This allows us to have functions running with their own contexts, being able
  to write on them as they need as they will be discarded anyway -/
  | prog c k (.decl n p) => prog c (.block c (.decl n k)) p

  /- `fork`, `loop` and `print` go to the expression evaluation step, keeping
  track of what needs to be done with the returned value later on -/
  | prog c k (.fork e pT pF) => expr c (.fork e pT pF k) e
  | prog c k (.loop e p) => expr c (.loop e p k) e
  | prog c k (.print e) => expr c (.print k) e

  /- If the expression resulted in a literal, a list or a function, just return
  them -/
  | expr c k (.lit l) => ret c k (.lit l)
  | expr c k (.list l) => ret c k (.list l)
  | expr c k (.lam l) => ret c k (.lam l)

  /- If we're supposed to extract the value of a variable, we need to check
  whether it's available in the context or not -/
  | expr c k (.var nm) => match c[nm] with
    | none   => error c k .name $ notFound nm
    | some v => ret c k v

  /- For an application we need to evaluate what we're using to apply. We expect
  it to be a function! -/
  | expr c k (.app e es) => expr c (.app e es k) e

  /- For the unary operator we have to evaluate the (only) expression first -/
  | expr c k (.unOp o e) => expr c (.unOp o k) e

  /- For the binary operator, we need to evaluate the first expression first and
  stack up the evaluation of the second one -/
  | expr c k (.binOp o e₁ e₂) => expr c (.binOp₁ o e₂ k) e₁

  /- The `Continuation.exit` signals that there's nothing else to do -/
  | ret c .exit v => done c .exit v

  /- Here we print the returned value and then return `nil` -/
  | ret c (.print k) v => dbg_trace v; ret c k .nil

  /- When returning from the execution of the first program in a `seq`, we
  ignore the value and go straight to the execution of the second program -/
  | ret c (.seq p k) _ => prog c k p

  /- Here we do what we promised and recover the original context stacked with
  the `Continuation.block` constructor -/
  | ret _ (.block c k) v => ret c k v

  /- When returning from an `app` continuation, we need to inspect the value
  that was returned from the evaluation of the first expression -/
  | ret c (.app e es k) v => match v with

    /- The desired case: it's a function! Let's consume it's parameters -/
    | .lam $ .mk ns h p => match h' : consume p ns es with

      /- When `consume` didn't eat up all the arguments we return an
      yet-to-be-uncurried function -/
      | some (some l, p) =>
        ret c k (.lam $ .mk l (noDupOfConsumeNoDup h h') p)

      /- All arguments were consumed: let's run the lambda program and use
      `block` to save up the context -/
      | some (none, p) => prog c (.block c k) p

      /- This signals that too many arguments were provided -/
      | none => error c k .runTime $ wrongNParameters e ns.length es.length

    /- Anything but a function. Error! -/
    | v                 => error c k .type $ notAFunction e v

  /- Now we need to resolve a `fork` given the value returned from the
  expression. We expext it to be a boolean -/
  | ret c (.fork _ pT _ k) (.lit $ .bool true)  => prog c k pT
  | ret c (.fork _ _ pF k) (.lit $ .bool false) => prog c k pF

  /- Not a boolean. Error! -/
  | ret c (.fork e _ _ k) v  => error c k .type $ cantEvalAsBool e v

  /- Resolving a `loop` is similar to a `fork`. We should expect a boolean, at
  least. The difference is that in case of `true`, we run the program and stack
  up the same loop expression and program. In case of `false`, just break the
  loop and return `nil` -/
  | ret c (.loop e p k) (.lit $ .bool true) => prog c k (.seq p (.loop e p))
  | ret c (.loop _ _ k) (.lit $ .bool false) => ret c k .nil
  | ret c (.loop e _ k) v => error c k .type $ cantEvalAsBool e v

  /- The execution of the `decl` program is returning a value. We can finally
  add it to the context under the name recovered from the `Continuation.decl` -/
  | ret c (.decl nm k) v => ret (c.insert nm v) k .nil

  /- In the unary operator, let's compute it right away -/
  | ret c (.unOp o k) v => match v.unOp o with
    | .error m => error c k .type m
    | .ok    v => ret c k v

  /- The binary operator is a bit more laborious. When returning from the
  evaluation of the first expression, we stack the result and call the
  evaluation of the second expression -/
  | ret c (.binOp₁ o e₂ k) v₁ => expr c (.binOp₂ o v₁ k) e₂

  /- Once the second evaluation is complete, we're good to go -/
  | ret c (.binOp₂ o v₁ k) v₂ => match v₁.binOp v₂ o with
    | .error m => error c k .type m
    | .ok    v => ret c k v

  /- `error` and `done` states just loop into themselves! -/
  | s@(error ..) => s
  | s@(done ..)  => s

/-- And now we can finally define our partial function to run a program using
`step`. It's really simple: call `step` until it yields a value or an error! -/
partial def Program.run (p : Program) : Context × Result :=
  let rec run' (s : State) : Context × Result :=
    match s.step with
    | .error c _ t m => (c, .err t m)
    | .done  c _ v   => (c, .val v)
    | s              => run' s
  run' $ State.prog default default p


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

/-!
# Irreducible definitions

This file defines an `irreducible_def` command,
which works almost like the `def` command
except that the introduced definition
does not reduce to the value.
Instead, the command
adds a `_def` lemma
which can be used for rewriting.

```
irreducible_def frobnicate (a b : Nat) :=
  a + b

example : frobnicate a 0 = a := by
  simp [frobnicate_def]
```

-/

namespace Lean.Elab.Command

open Term Meta

/-- `delta% t` elaborates to a head-delta reduced version of `t`. -/
elab "delta% " t:term : term <= expectedType => do
  let t ← elabTerm t expectedType
  synthesizeSyntheticMVars
  let t ← instantiateMVars t
  let some t ← delta? t | throwError "cannot delta reduce {t}"
  pure t

/- `eta_helper f = (· + 3)` elabs to `∀ x, f x = x + 3` -/
local elab "eta_helper " t:term : term => do
  let t ← elabTerm t none
  let some (_, lhs, rhs) := t.eq? | throwError "not an equation: {t}"
  synthesizeSyntheticMVars
  let rhs ← instantiateMVars rhs
  lambdaLetTelescope rhs fun xs rhs ↦ do
    let lhs := (mkAppN lhs xs).headBeta
    mkForallFVars xs <|← mkEq lhs rhs

/-- `value_proj x` elabs to `@x.value` -/
local elab "value_proj " e:term : term => do
  let e ← elabTerm e none
  mkProjection e `value

/--
Executes the commands,
and stops after the first error.
In short, S-A-F-E.
-/
local syntax "stop_at_first_error" command* : command
open Command in elab_rules : command
  | `(stop_at_first_error $[$cmds]*) => do
    for cmd in cmds do
      elabCommand cmd.raw
      if (← get).messages.hasErrors then break

/--
Introduces an irreducible definition.
`irreducible_def foo := 42` generates
a constant `foo : Nat` as well as
a theorem `foo_def : foo = 42`.
-/
macro mods:declModifiers "irreducible_def" n_id:declId declSig:optDeclSig val:declVal :
    command => do
  let (n, us) ← match n_id with
    | `(Parser.Command.declId| $n:ident $[.{$us,*}]?) => pure (n, us)
    | _ => Macro.throwUnsupported
  let us' := us.getD { elemsAndSeps := #[] }
  let n_def := mkIdent <| (·.review) <|
    let scopes := extractMacroScopes n.getId
    { scopes with name := scopes.name.appendAfter "_def" }
  `(stop_at_first_error
    def definition$[.{$us,*}]? $declSig:optDeclSig $val
    set_option genInjectivity false in -- generates awful simp lemmas
    structure Wrapper$[.{$us,*}]? where
      value : type_of% @definition.{$us',*}
      prop : Eq @value @(delta% @definition)
    opaque wrapped$[.{$us,*}]? : Wrapper.{$us',*} := ⟨_, rfl⟩
    $mods:declModifiers def $n:ident$[.{$us,*}]? := value_proj @wrapped.{$us',*}
    theorem $n_def:ident $[.{$us,*}]? : eta_helper Eq @$n.{$us',*} @(delta% @definition) := by
      intros
      simp only [$n:ident]
      rw [wrapped.prop])


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.list.basic
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.meta.default
import Mathlib.Lean3Lib.init.data.nat.lemmas
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.meta.smt.rsimp

universes u v w w₂ w₁

namespace Mathlib

namespace list

/- append -/

@[simp] theorem nil_append {α : Type u} (s : List α) : [] ++ s = s :=
  rfl

@[simp] theorem cons_append {α : Type u} (x : α) (s : List α) (t : List α) : x :: s ++ t = x :: (s ++ t) :=
  rfl

@[simp] theorem append_nil {α : Type u} (t : List α) : t ++ [] = t := sorry

@[simp] theorem append_assoc {α : Type u} (s : List α) (t : List α) (u : List α) : s ++ t ++ u = s ++ (t ++ u) := sorry

/- length -/

theorem length_cons {α : Type u} (a : α) (l : List α) : length (a :: l) = length l + 1 :=
  rfl

@[simp] theorem length_append {α : Type u} (s : List α) (t : List α) : length (s ++ t) = length s + length t := sorry

@[simp] theorem length_repeat {α : Type u} (a : α) (n : ℕ) : length (repeat a n) = n := sorry

@[simp] theorem length_tail {α : Type u} (l : List α) : length (tail l) = length l - 1 :=
  list.cases_on l (Eq.refl (length (tail []))) fun (l_hd : α) (l_tl : List α) => Eq.refl (length (tail (l_hd :: l_tl)))

-- TODO(Leo): cleanup proof after arith dec proc

@[simp] theorem length_drop {α : Type u} (i : ℕ) (l : List α) : length (drop i l) = length l - i := sorry

/- map -/

theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (l : List α) : map f (a :: l) = f a :: map f l :=
  rfl

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (l₁ : List α) (l₂ : List α) : map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ := sorry

theorem map_singleton {α : Type u} {β : Type v} (f : α → β) (a : α) : map f [a] = [f a] :=
  rfl

@[simp] theorem map_id {α : Type u} (l : List α) : map id l = l := sorry

@[simp] theorem map_map {α : Type u} {β : Type v} {γ : Type w} (g : β → γ) (f : α → β) (l : List α) : map g (map f l) = map (g ∘ f) l := sorry

@[simp] theorem length_map {α : Type u} {β : Type v} (f : α → β) (l : List α) : length (map f l) = length l := sorry

/- bind -/

@[simp] theorem nil_bind {α : Type u} {β : Type v} (f : α → List β) : list.bind [] f = [] := sorry

@[simp] theorem cons_bind {α : Type u} {β : Type v} (x : α) (xs : List α) (f : α → List β) : list.bind (x :: xs) f = f x ++ list.bind xs f := sorry

@[simp] theorem append_bind {α : Type u} {β : Type v} (xs : List α) (ys : List α) (f : α → List β) : list.bind (xs ++ ys) f = list.bind xs f ++ list.bind ys f := sorry

/- mem -/

@[simp] theorem mem_nil_iff {α : Type u} (a : α) : a ∈ [] ↔ False :=
  iff.rfl

@[simp] theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ [] :=
  iff.mp (mem_nil_iff a)

@[simp] theorem mem_cons_self {α : Type u} (a : α) (l : List α) : a ∈ a :: l :=
  Or.inl rfl

@[simp] theorem mem_cons_iff {α : Type u} (a : α) (y : α) (l : List α) : a ∈ y :: l ↔ a = y ∨ a ∈ l :=
  iff.rfl

theorem mem_cons_eq {α : Type u} (a : α) (y : α) (l : List α) : a ∈ y :: l = (a = y ∨ a ∈ l) :=
  rfl

theorem mem_cons_of_mem {α : Type u} (y : α) {a : α} {l : List α} : a ∈ l → a ∈ y :: l :=
  fun (H : a ∈ l) => Or.inr H

theorem eq_or_mem_of_mem_cons {α : Type u} {a : α} {y : α} {l : List α} : a ∈ y :: l → a = y ∨ a ∈ l :=
  fun (h : a ∈ y :: l) => h

@[simp] theorem mem_append {α : Type u} {a : α} {s : List α} {t : List α} : a ∈ s ++ t ↔ a ∈ s ∨ a ∈ t := sorry

theorem mem_append_eq {α : Type u} (a : α) (s : List α) (t : List α) : a ∈ s ++ t = (a ∈ s ∨ a ∈ t) :=
  propext mem_append

theorem mem_append_left {α : Type u} {a : α} {l₁ : List α} (l₂ : List α) (h : a ∈ l₁) : a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inl h)

theorem mem_append_right {α : Type u} {a : α} (l₁ : List α) {l₂ : List α} (h : a ∈ l₂) : a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inr h)

@[simp] theorem not_bex_nil {α : Type u} (p : α → Prop) : ¬∃ (x : α), ∃ (H : x ∈ []), p x := sorry

@[simp] theorem ball_nil {α : Type u} (p : α → Prop) (x : α) (H : x ∈ []) : p x :=
  false.elim

@[simp] theorem bex_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) : (∃ (x : α), ∃ (H : x ∈ a :: l), p x) ↔ p a ∨ ∃ (x : α), ∃ (H : x ∈ l), p x := sorry

@[simp] theorem ball_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) : (∀ (x : α), x ∈ a :: l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l → p x := sorry

/- list subset -/

protected def subset {α : Type u} (l₁ : List α) (l₂ : List α) :=
  ∀ {a : α}, a ∈ l₁ → a ∈ l₂

protected instance has_subset {α : Type u} : has_subset (List α) :=
  has_subset.mk list.subset

@[simp] theorem nil_subset {α : Type u} (l : List α) : [] ⊆ l :=
  fun (b : α) (i : b ∈ []) => false.elim (iff.mp (mem_nil_iff b) i)

@[simp] theorem subset.refl {α : Type u} (l : List α) : l ⊆ l :=
  fun (b : α) (i : b ∈ l) => i

theorem subset.trans {α : Type u} {l₁ : List α} {l₂ : List α} {l₃ : List α} (h₁ : l₁ ⊆ l₂) (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
  fun (b : α) (i : b ∈ l₁) => h₂ (h₁ i)

@[simp] theorem subset_cons {α : Type u} (a : α) (l : List α) : l ⊆ a :: l :=
  fun (b : α) (i : b ∈ l) => Or.inr i

theorem subset_of_cons_subset {α : Type u} {a : α} {l₁ : List α} {l₂ : List α} : a :: l₁ ⊆ l₂ → l₁ ⊆ l₂ :=
  fun (s : a :: l₁ ⊆ l₂) (b : α) (i : b ∈ l₁) => s (mem_cons_of_mem a i)

theorem cons_subset_cons {α : Type u} {l₁ : List α} {l₂ : List α} (a : α) (s : l₁ ⊆ l₂) : a :: l₁ ⊆ a :: l₂ :=
  fun (b : α) (hin : b ∈ a :: l₁) =>
    or.elim (eq_or_mem_of_mem_cons hin) (fun (e : b = a) => Or.inl e) fun (i : b ∈ l₁) => Or.inr (s i)

@[simp] theorem subset_append_left {α : Type u} (l₁ : List α) (l₂ : List α) : l₁ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_left l₂

@[simp] theorem subset_append_right {α : Type u} (l₁ : List α) (l₂ : List α) : l₂ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_right l₁

theorem subset_cons_of_subset {α : Type u} (a : α) {l₁ : List α} {l₂ : List α} : l₁ ⊆ l₂ → l₁ ⊆ a :: l₂ :=
  fun (s : l₁ ⊆ l₂) (a_1 : α) (i : a_1 ∈ l₁) => Or.inr (s i)

theorem eq_nil_of_length_eq_zero {α : Type u} {l : List α} : length l = 0 → l = [] := sorry

theorem ne_nil_of_length_eq_succ {α : Type u} {l : List α} {n : ℕ} : length l = Nat.succ n → l ≠ [] := sorry

@[simp] theorem length_map₂ {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l₁ : List α) (l₂ : List β) : length (map₂ f l₁ l₂) = min (length l₁) (length l₂) := sorry

@[simp] theorem length_take {α : Type u} (i : ℕ) (l : List α) : length (take i l) = min i (length l) := sorry

theorem length_take_le {α : Type u} (n : ℕ) (l : List α) : length (take n l) ≤ n := sorry

theorem length_remove_nth {α : Type u} (l : List α) (i : ℕ) : i < length l → length (remove_nth l i) = length l - 1 := sorry

@[simp] theorem partition_eq_filter_filter {α : Type u} (p : α → Prop) [decidable_pred p] (l : List α) : partition p l = (filter p l, filter (Not ∘ p) l) := sorry

/- sublists -/

inductive sublist {α : Type u} : List α → List α → Prop
where
| slnil : sublist [] []
| cons : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist l₁ (a :: l₂)
| cons2 : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist (a :: l₁) (a :: l₂)

infixl:50 " <+ " => Mathlib.list.sublist

theorem length_le_of_sublist {α : Type u} {l₁ : List α} {l₂ : List α} : l₁ <+ l₂ → length l₁ ≤ length l₂ := sorry

/- filter -/

@[simp] theorem filter_nil {α : Type u} (p : α → Prop) [h : decidable_pred p] : filter p [] = [] :=
  rfl

@[simp] theorem filter_cons_of_pos {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α} (l : List α) : p a → filter p (a :: l) = a :: filter p l :=
  fun (pa : p a) => if_pos pa

@[simp] theorem filter_cons_of_neg {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α} (l : List α) : ¬p a → filter p (a :: l) = filter p l :=
  fun (pa : ¬p a) => if_neg pa

@[simp] theorem filter_append {α : Type u} {p : α → Prop} [h : decidable_pred p] (l₁ : List α) (l₂ : List α) : filter p (l₁ ++ l₂) = filter p l₁ ++ filter p l₂ := sorry

@[simp] theorem filter_sublist {α : Type u} {p : α → Prop} [h : decidable_pred p] (l : List α) : filter p l <+ l := sorry

/- map_accumr -/

-- This runs a function over a list returning the intermediate results and a

-- a final result.

def map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β) : List α → σ → σ × List β :=
  sorry

@[simp] theorem length_map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β) (x : List α) (s : σ) : length (prod.snd (map_accumr f x s)) = length x := sorry

-- This runs a function over two lists returning the intermediate results and a

-- a final result.

def map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂} (f : α → β → σ → σ × φ) : List α → List β → σ → σ × List φ :=
  sorry

@[simp] theorem length_map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂} (f : α → β → σ → σ × φ) (x : List α) (y : List β) (c : σ) : length (prod.snd (map_accumr₂ f x y c)) = min (length x) (length y) := sorry


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.category.Pointed

/-!
# The category of bipointed types

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

@[simp] lemma coe_of {X : Type*} (to_prod : X × X) : ↥(of to_prod) = X := rfl

alias of ← _root_.prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Swaps the pointed elements of a bipointed type. `prod.swap` as a functor. -/
@[simps] def swap : Bipointed ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.to_prod.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def Pointed_to_Bipointed : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.point, X.point⟩, map := λ X Y f, ⟨f.to_fun, f.map_point, f.map_point⟩ }

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, none⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Bipointed_fst_comp_swap :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp_swap :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- `Bipointed_to_Pointed_fst` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_fst ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- `Bipointed_to_Pointed_snd` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_snd ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.2 f.to_fun, f.map_point, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.1 f.to_fun, rfl, f.map_point⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }