/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis

Normalizing casts inside expressions.
-/
import tactic.converter.interactive
import tactic.hint

/-!
# A tactic for normalizing casts inside expressions

This tactic normalizes casts inside expressions.
It can be thought of as a call to the simplifier with a specific set of lemmas to
move casts upwards in the expression.
It has special handling of numerals and a simple heuristic to help moving
casts "past" binary operators.
Contrary to simp, it should be safe to use as a non-terminating tactic.

The algorithm implemented here is described in the paper
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.

## Important definitions
* `tactic.interactive.norm_cast`
* `tactic.interactive.push_cast`
* `tactic.interactive.exact_mod_cast`
* `tactic.interactive.apply_mod_cast`
* `tactic.interactive.rw_mod_cast`
* `tactic.interactive.assumption_mod_cast`
-/

setup_tactic_parser

namespace tactic

/--
Runs `mk_instance` with a time limit.

This is a work around to the fact that in some cases
mk_instance times out instead of failing,
for example: `has_lift_t ℤ ℕ`

`mk_instance_fast` is used when we assume the type class search
should end instantly.
-/
meta def mk_instance_fast (e : expr) (timeout := 1000) : tactic expr :=
try_for timeout (mk_instance e)

end tactic

namespace norm_cast

open tactic expr

declare_trace norm_cast

/--
Output a trace message if `trace.norm_cast` is enabled.
-/
meta def trace_norm_cast {α} [has_to_tactic_format α] (msg : string) (a : α) : tactic unit :=
when_tracing `norm_cast $ do
a ← pp a,
trace ("[norm_cast] " ++ msg ++ a : format)

mk_simp_attribute push_cast "The `push_cast` simp attribute uses `norm_cast` lemmas
to move casts toward the leaf nodes of the expression."

/--
`label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
@[derive [decidable_eq, has_reflect, inhabited]]
inductive label
| elim   : label
| move   : label
| squash : label

namespace label

/-- Convert `label` into `string`. -/
protected def to_string : label → string
| elim   := "elim"
| move   := "move"
| squash := "squash"

instance : has_to_string label := ⟨label.to_string⟩
instance : has_repr label := ⟨label.to_string⟩
meta instance : has_to_format label := ⟨λ l, l.to_string⟩

/-- Convert `string` into `label`. -/
def of_string : string -> option label
| "elim" := some elim
| "move" := some move
| "squash" := some squash
| _ := none

end label

open label

/-- Count how many coercions are at the top of the expression. -/
meta def count_head_coes : expr → ℕ
| `(coe %%e) := count_head_coes e + 1
| `(coe_sort %%e) := count_head_coes e + 1
| `(coe_fn %%e) := count_head_coes e + 1
| _ := 0

/-- Count how many coercions are inside the expression, including the top ones. -/
meta def count_coes : expr → tactic ℕ
| `(coe %%e) := (+1) <$> count_coes e
| `(coe_sort %%e) := (+1) <$> count_coes e
| `(coe_fn %%e) := (+1) <$> count_coes e
| (app `(coe_fn %%e) x) := (+) <$> count_coes x <*> (+1) <$> count_coes e
| (expr.lam n bi t e) := do
  l ← mk_local' n bi t,
  count_coes $ e.instantiate_var l
| e := do
  as ← e.get_simp_args,
  list.sum <$> as.mmap count_coes

/-- Count how many coercions are inside the expression, excluding the top ones. -/
private meta def count_internal_coes (e : expr) : tactic ℕ := do
ncoes ← count_coes e,
pure $ ncoes - count_head_coes e

/--
Classifies a declaration of type `ty` as a `norm_cast` rule.
-/
meta def classify_type (ty : expr) : tactic label := do
(_, ty) ← open_pis ty,
(lhs, rhs) ← match ty with
  | `(%%lhs = %%rhs) := pure (lhs, rhs)
  | `(%%lhs ↔ %%rhs) := pure (lhs, rhs)
  | _ := fail "norm_cast: lemma must be = or ↔"
  end,
lhs_coes ← count_coes lhs,
when (lhs_coes = 0) $ fail "norm_cast: badly shaped lemma, lhs must contain at least one coe",
let lhs_head_coes := count_head_coes lhs,
lhs_internal_coes ← count_internal_coes lhs,
let rhs_head_coes := count_head_coes rhs,
rhs_internal_coes ← count_internal_coes rhs,
if lhs_head_coes = 0 then
  return elim
else if lhs_head_coes = 1 then do
  when (rhs_head_coes ≠ 0) $ fail "norm_cast: badly shaped lemma, rhs can't start with coe",
  if rhs_internal_coes = 0 then
    return squash
  else
    return move
else if rhs_head_coes < lhs_head_coes then do
  return squash
else do
  fail "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs"

/-- The cache for `norm_cast` attribute stores three `simp_lemma` objects. -/
meta structure norm_cast_cache :=
(up : simp_lemmas)
(down : simp_lemmas)
(squash : simp_lemmas)

/-- Empty `norm_cast_cache`. -/
meta def empty_cache : norm_cast_cache :=
{ up     := simp_lemmas.mk,
  down   := simp_lemmas.mk,
  squash := simp_lemmas.mk, }

meta instance : inhabited norm_cast_cache := ⟨empty_cache⟩

/-- `add_elim cache e` adds `e` as an `elim` lemma to `cache`. -/
meta def add_elim (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  new_up ← simp_lemmas.add cache.up e,
  return
  { up     := new_up,
    down   := cache.down,
    squash := cache.squash, }

/-- `add_move cache e` adds `e` as a `move` lemma to `cache`. -/
meta def add_move (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  ty ← infer_type e,
  new_up ← cache.up.add e tt,
  new_down ← simp_lemmas.add cache.down e,
  return {
    up     := new_up,
    down   := new_down,
    squash := cache.squash, }

/-- `add_squash cache e` adds `e` as an `squash` lemma to `cache`. -/
meta def add_squash (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  new_squash ← simp_lemmas.add cache.squash e,
  new_down ← simp_lemmas.add cache.down e,
  return {
    up     := cache.up,
    down   := new_down,
    squash := new_squash, }

/--
The type of the `norm_cast` attribute.
The optional label is used to overwrite the classifier.
-/
meta def norm_cast_attr_ty : Type := user_attribute norm_cast_cache (option label)

/--
Efficient getter for the `@[norm_cast]` attribute parameter that does not call `eval_expr`.

See Note [user attribute parameters].
-/
meta def get_label_param (attr : norm_cast_attr_ty) (decl : name) : tactic (option label) := do
p ← attr.get_param_untyped decl,
match p with
| `(none) := pure none
| `(some label.elim) := pure label.elim
| `(some label.move) := pure label.move
| `(some label.squash) := pure label.squash
| _ := fail p
end

/--
`add_lemma cache decl` infers the proper `norm_cast` attribute for `decl` and adds it to `cache`.
-/
meta def add_lemma (attr : norm_cast_attr_ty) (cache : norm_cast_cache) (decl : name) :
  tactic norm_cast_cache :=
do
  e ← mk_const decl,
  param ← get_label_param attr decl,
  l ← param <|> (infer_type e >>= classify_type),
  match l with
  | elim   := add_elim cache e
  | move   := add_move cache e
  | squash := add_squash cache e
  end

-- special lemmas to handle the ≥, > and ≠ operators
private lemma ge_from_le {α} [has_le α] : ∀ (x y : α), x ≥ y ↔ y ≤ x := λ _ _, iff.rfl
private lemma gt_from_lt {α} [has_lt α] : ∀ (x y : α), x > y ↔ y < x := λ _ _, iff.rfl
private lemma ne_from_not_eq {α} : ∀ (x y : α), x ≠ y ↔ ¬(x = y) := λ _ _, iff.rfl

/--
`mk_cache names` creates a `norm_cast_cache`. It infers the proper `norm_cast` attributes
for names in `names`, and collects the lemmas attributed with specific `norm_cast` attributes.
-/
meta def mk_cache (attr : thunk norm_cast_attr_ty) (names : list name) :
  tactic norm_cast_cache := do
-- names has the declarations in reverse order
cache ← names.mfoldr (λ name cache, add_lemma (attr ()) cache name) empty_cache,

--some special lemmas to handle binary relations
let up := cache.up,
up ← up.add_simp ``ge_from_le,
up ← up.add_simp ``gt_from_lt,
up ← up.add_simp ``ne_from_not_eq,

let down := cache.down,
down ← down.add_simp ``coe_coe,

pure { up := up, down := down, squash := cache.squash }

/--
The `norm_cast` attribute.
-/
@[user_attribute] meta def norm_cast_attr : user_attribute norm_cast_cache (option label) :=
{ name      := `norm_cast,
  descr     := "attribute for norm_cast",
  parser    :=
    (do some l ← (label.of_string ∘ to_string) <$> ident, return l)
      <|> return none,
  after_set := some (λ decl prio persistent, do
    param ← get_label_param norm_cast_attr decl,
    match param with
    | some l :=
      when (l ≠ elim) $ simp_attr.push_cast.set decl () tt
    | none := do
      e ← mk_const decl,
      ty ← infer_type e,
      l ← classify_type ty,
      norm_cast_attr.set decl l persistent prio
    end),
  before_unset := some $ λ _ _, tactic.skip,
  cache_cfg := { mk_cache := mk_cache norm_cast_attr, dependencies := [] } }

/-- Classify a declaration as a `norm_cast` rule. -/
meta def make_guess (decl : name) : tactic label :=
do
  e ← mk_const decl,
  ty ← infer_type e,
  classify_type ty

/--
Gets the `norm_cast` classification label for a declaration. Applies the
override specified on the attribute, if necessary.
-/
meta def get_label (decl : name) : tactic label :=
do
  param ← get_label_param norm_cast_attr decl,
  param <|> make_guess decl

end norm_cast

namespace tactic.interactive
open norm_cast

/--
`push_cast` rewrites the expression to move casts toward the leaf nodes.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
Equivalent to `simp only with push_cast`.
Can also be used at hypotheses.

`push_cast` can also be used at hypotheses and with extra simp rules.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```
-/
meta def push_cast (hs : parse tactic.simp_arg_list) (l : parse location) : tactic unit :=
tactic.interactive.simp none none tt hs [`push_cast] l

end tactic.interactive

namespace norm_cast
open tactic expr

/-- Prove `a = b` using the given simp set. -/
meta def prove_eq_using (s : simp_lemmas) (a b : expr) : tactic expr := do
(a', a_a', _) ← simplify s [] a {fail_if_unchanged := ff},
(b', b_b', _) ← simplify s [] b {fail_if_unchanged := ff},
on_exception (trace_norm_cast "failed: " (to_expr ``(%%a' = %%b') >>= pp)) $
  is_def_eq a' b' reducible,
b'_b ← mk_eq_symm b_b',
mk_eq_trans a_a' b'_b

/-- Prove `a = b` by simplifying using move and squash lemmas. -/
meta def prove_eq_using_down (a b : expr) : tactic expr := do
cache ← norm_cast_attr.get_cache,
trace_norm_cast "proving: " (to_expr ``(%%a = %%b) >>= pp),
prove_eq_using cache.down a b

/--
This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
meta def splitting_procedure : expr → tactic (expr × expr)
| (app (app op x) y) :=
(do
  `(@coe %%α %%δ %%coe1 %%xx) ← return x,
  `(@coe %%β %%γ %%coe2 %%yy) ← return y,
  success_if_fail $ is_def_eq α β,
  is_def_eq δ γ,

  (do
    coe3 ← mk_app `has_lift_t [α, β] >>= mk_instance_fast,
    new_x ← to_expr ``(@coe %%β %%δ %%coe2 (@coe %%α %%β %%coe3 %%xx)),
    let new_e := app (app op new_x) y,
    eq_x ← prove_eq_using_down x new_x,
    pr ← mk_congr_arg op eq_x,
    pr ← mk_congr_fun pr y,
    return (new_e, pr)
  ) <|> (do
    coe3 ← mk_app `has_lift_t [β, α] >>= mk_instance_fast,
    new_y ← to_expr ``(@coe %%α %%δ %%coe1 (@coe %%β %%α %%coe3 %%yy)),
    let new_e := app (app op x) new_y,
    eq_y ← prove_eq_using_down y new_y,
    pr ← mk_congr_arg (app op x) eq_y,
    return (new_e, pr)
  )
) <|> (do
  `(@coe %%α %%β %%coe1 %%xx) ← return x,
  `(@has_one.one %%β %%h1) ← return y,
  h2 ← to_expr ``(has_one %%α) >>= mk_instance_fast,
  new_y ← to_expr ``(@coe %%α %%β %%coe1 (@has_one.one %%α %%h2)),
  eq_y ← prove_eq_using_down y new_y,
  let new_e := app (app op x) new_y,
  pr ← mk_congr_arg (app op x) eq_y,
  return (new_e, pr)
 ) <|> (do
  `(@coe %%α %%β %%coe1 %%xx) ← return x,
  `(@has_zero.zero %%β %%h1) ← return y,
  h2 ← to_expr ``(has_zero %%α) >>= mk_instance_fast,
  new_y ← to_expr ``(@coe %%α %%β %%coe1 (@has_zero.zero %%α %%h2)),
  eq_y ← prove_eq_using_down y new_y,
  let new_e := app (app op x) new_y,
  pr ← mk_congr_arg (app op x) eq_y,
  return (new_e, pr)
) <|> (do
  `(@has_one.one %%β %%h1) ← return x,
  `(@coe %%α %%β %%coe1 %%xx) ← return y,
  h1 ← to_expr ``(has_one %%α) >>= mk_instance_fast,
  new_x ← to_expr ``(@coe %%α %%β %%coe1 (@has_one.one %%α %%h1)),
  eq_x ← prove_eq_using_down x new_x,
  let new_e := app (app op new_x) y,
  pr ← mk_congr_arg (lam `x binder_info.default β (app (app op (var 0)) y)) eq_x,
  return (new_e, pr)
) <|> (do
  `(@has_zero.zero %%β %%h1) ← return x,
  `(@coe %%α %%β %%coe1 %%xx) ← return y,
  h1 ← to_expr ``(has_zero %%α) >>= mk_instance_fast,
  new_x ← to_expr ``(@coe %%α %%β %%coe1 (@has_zero.zero %%α %%h1)),
  eq_x ← prove_eq_using_down x new_x,
  let new_e := app (app op new_x) y,
  pr ← mk_congr_arg (lam `x binder_info.default β (app (app op (var 0)) y)) eq_x,
  return (new_e, pr)
)
| _ := failed

/--
Discharging function used during simplification in the "squash" step.

TODO: norm_cast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
private meta def prove : tactic unit :=
assumption

/--
Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
meta def upward_and_elim (s : simp_lemmas) (e : expr) : tactic (expr × expr) :=
(do
  r ← mcond (is_prop e) (return `iff) (return `eq),
  (new_e, pr) ← s.rewrite e prove r,
  pr ← match r with
  | `iff := mk_app `propext [pr]
  | _    := return pr
  end,
  return (new_e, pr)
) <|> splitting_procedure e

/-!
The following auxiliary functions are used to handle numerals.
-/

/--
If possible, rewrite `(n : α)` to `((n : ℕ) : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
meta def numeral_to_coe (e : expr) : tactic (expr × expr) :=
do
  α ← infer_type e,
  success_if_fail $ is_def_eq α `(ℕ),
  n ← e.to_nat,
  h1 ← mk_app `has_lift_t [`(ℕ), α] >>= mk_instance_fast,
  let new_e : expr := reflect n,
  new_e ← to_expr ``(@coe ℕ %%α %%h1 %%new_e),
  pr ← prove_eq_using_down e new_e,
  return (new_e, pr)

/--
If possible, rewrite `((n : ℕ) : α)` to `(n : α)` where `n` is a numeral.
Returns a pair of the new expression and proof that they are equal.
-/
meta def coe_to_numeral (e : expr) : tactic (expr × expr) :=
do
  `(@coe ℕ %%α %%h1 %%e') ← return e,
  n ← e'.to_nat,
  -- replace e' by normalized numeral
  is_def_eq (reflect n) e' reducible,
  let e := e.app_fn (reflect n),
  new_e ← expr.of_nat α n,
  pr ← prove_eq_using_down e new_e,
  return (new_e, pr)

/-- A local variant on `simplify_top_down`. -/
private meta def simplify_top_down' {α} (a : α) (pre : α → expr → tactic (α × expr × expr))
  (e : expr) (cfg : simp_config := {}) : tactic (α × expr × expr) :=
ext_simplify_core a cfg simp_lemmas.mk (λ _, failed)
  (λ a _ _ _ e, do
    (new_a, new_e, pr) ← pre a e,
    guard (¬ new_e =ₐ e),
    return (new_a, new_e, some pr, ff))
  (λ _ _ _ _ _, failed)
  `eq e

/--
The core simplification routine of `norm_cast`.
-/
meta def derive (e : expr) : tactic (expr × expr) :=
do
  cache ← norm_cast_attr.get_cache,
  e ← instantiate_mvars e,
  let cfg : simp_config := {
    zeta := ff,
    beta := ff,
    eta  := ff,
    proj := ff,
    iota := ff,
    iota_eqn := ff,
    fail_if_unchanged := ff },
  let e0 := e,

  -- step 1: pre-processing of numerals
  ((), e1, pr1) ← simplify_top_down' () (λ _ e, prod.mk () <$> numeral_to_coe e) e0 cfg,
  trace_norm_cast "after numeral_to_coe: " e1,

  -- step 2: casts are moved upwards and eliminated
  ((), e2, pr2) ← simplify_bottom_up () (λ _ e, prod.mk () <$> upward_and_elim cache.up e) e1 cfg,
  trace_norm_cast "after upward_and_elim: " e2,

  -- step 3: casts are squashed
  (e3, pr3, _) ← simplify cache.squash [] e2 cfg,
  trace_norm_cast "after squashing: " e3,

  -- step 4: post-processing of numerals
  ((), e4, pr4) ← simplify_top_down' () (λ _ e, prod.mk () <$> coe_to_numeral e) e3 cfg,
  trace_norm_cast "after coe_to_numeral: " e4,

  let new_e := e4,
  guard (¬ new_e =ₐ e),
  pr ← mk_eq_trans pr1 pr2,
  pr ← mk_eq_trans pr pr3,
  pr ← mk_eq_trans pr pr4,
  return (new_e, pr)

/--
A small variant of `push_cast` suited for non-interactive use.

`derive_push_cast extra_lems e` returns an expression `e'` and a proof that `e = e'`.
-/
meta def derive_push_cast (extra_lems : list simp_arg_type) (e : expr) : tactic (expr × expr) :=
do (s, _) ← mk_simp_set tt [`push_cast] extra_lems,
   (e, prf, _) ← simplify (s.erase [`int.coe_nat_succ]) [] e {fail_if_unchanged := ff},
   return (e, prf)

end norm_cast

namespace tactic
open expr norm_cast

/-- `aux_mod_cast e` runs `norm_cast` on `e` and returns the result. If `include_goal` is true, it
also normalizes the goal. -/
meta def aux_mod_cast (e : expr) (include_goal : bool := tt) : tactic expr :=
match e with
| local_const _ lc _ _ := do
  e ← get_local lc,
  replace_at derive [e] include_goal,
  get_local lc
| e := do
  t ← infer_type e,
  e ← assertv `this t e,
  replace_at derive [e] include_goal,
  get_local `this
end

/-- `exact_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to use `e` to close the
goal. -/
meta def exact_mod_cast (e : expr) : tactic unit :=
decorate_error "exact_mod_cast failed:" $ do
  new_e ← aux_mod_cast e,
  exact new_e

/-- `apply_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to apply `e`. -/
meta def apply_mod_cast (e : expr) : tactic (list (name × expr)) :=
decorate_error "apply_mod_cast failed:" $ do
  new_e ← aux_mod_cast e,
  apply new_e

/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
meta def assumption_mod_cast : tactic unit :=
decorate_error "assumption_mod_cast failed:" $ do
  let cfg : simp_config := {
    fail_if_unchanged := ff,
    canonize_instances := ff,
    canonize_proofs := ff,
    proj := ff
  },
  replace_at derive [] tt,
  ctx ← local_context,
  try_lst $ ctx.map (λ h, aux_mod_cast h ff >>= tactic.exact)

end tactic

namespace tactic.interactive
open tactic norm_cast

/--
Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily closing the goal.
-/
meta def norm_cast (loc : parse location) : tactic unit :=
do
  ns ← loc.get_locals,
  tt ← replace_at derive ns loc.include_goal | fail "norm_cast failed to simplify",
  when loc.include_goal $ try tactic.reflexivity,
  when loc.include_goal $ try tactic.triv,
  when (¬ ns.empty) $ try tactic.contradiction

/--
Rewrite with the given rules and normalize casts between steps.
-/
meta def rw_mod_cast (rs : parse rw_rules) (loc : parse location) : tactic unit :=
decorate_error "rw_mod_cast failed:" $ do
  let cfg_norm : simp_config := {},
  let cfg_rw : rewrite_cfg := {},
  ns ← loc.get_locals,
  monad.mapm' (λ r : rw_rule, do
    save_info r.pos,
    replace_at derive ns loc.include_goal,
    rw ⟨[r], none⟩ loc {}
  ) rs.rules,
  replace_at derive ns loc.include_goal,
  skip

/--
Normalize the goal and the given expression, then close the goal with exact.
-/
meta def exact_mod_cast (e : parse texpr) : tactic unit :=
do
  e ← i_to_expr e <|> do {
    ty ← target,
    e ← i_to_expr_strict ``(%%e : %%ty),
    pty ← pp ty, ptgt ← pp e,
    fail ("exact_mod_cast failed, expression type not directly " ++
    "inferrable. Try:\n\nexact_mod_cast ...\nshow " ++
    to_fmt pty ++ ",\nfrom " ++ ptgt : format)
  },
  tactic.exact_mod_cast e

/--
Normalize the goal and the given expression, then apply the expression to the goal.
-/
meta def apply_mod_cast (e : parse texpr) : tactic unit :=
do
  e ← i_to_expr_for_apply e,
  concat_tags $ tactic.apply_mod_cast e

/--
Normalize the goal and every expression in the local context, then close the goal with assumption.
-/
meta def assumption_mod_cast : tactic unit :=
tactic.assumption_mod_cast

end tactic.interactive

namespace conv.interactive
open conv
open norm_cast (derive)

/-- the converter version of `norm_cast' -/
meta def norm_cast : conv unit := replace_lhs derive

end conv.interactive

-- TODO: move this elsewhere?
@[norm_cast] lemma ite_cast {α β} [has_lift_t α β]
  {c : Prop} [decidable c] {a b : α} :
  ↑(ite c a b) = ite c (↑a : β) (↑b : β) :=
by by_cases h : c; simp [h]

@[norm_cast] lemma dite_cast {α β} [has_lift_t α β]
  {c : Prop} [decidable c] {a : c → α} {b : ¬ c → α} :
  ↑(dite c a b) = dite c (λ h, (↑(a h) : β)) (λ h, (↑(b h) : β)) :=
by by_cases h : c; simp [h]

add_hint_tactic "norm_cast at *"

/--
The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
{ name := "norm_cast",
  category   := doc_category.tactic,
  decl_names := [``tactic.interactive.norm_cast, ``tactic.interactive.rw_mod_cast,
                 ``tactic.interactive.apply_mod_cast, ``tactic.interactive.assumption_mod_cast,
                 ``tactic.interactive.exact_mod_cast, ``tactic.interactive.push_cast],
  tags       := ["coercions", "simplification"] }

/--
The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) :
  ((n - m : ℕ) : α) = n - m

@[norm_cast] theorem coe_nat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n :=
by rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
{ name := "norm_cast attributes",
  category   := doc_category.attr,
  decl_names := [``norm_cast.norm_cast_attr],
  tags       := ["coercions", "simplification"] }

-- Lemmas defined in core.
attribute [norm_cast]
  int.nat_abs_of_nat
  int.coe_nat_sub
  int.coe_nat_mul
  int.coe_nat_zero
  int.coe_nat_one
  int.coe_nat_add

-- Lemmas about nat.succ need to get a low priority, so that they are tried last.
-- This is because `nat.succ _` matches `1`, `3`, `x+1`, etc.
-- Rewriting would then produce really wrong terms.
attribute [norm_cast, priority 500] int.coe_nat_succ


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

! This file was ported from Lean 3 source module tactic.to_additive
! leanprover-community/mathlib commit bfe9e712c5178b227be330f7c10c2e91ab48eaf8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.TransformDecl
import Mathbin.Tactic.Algebra
import Mathbin.Tactic.Lint.Basic
import Mathbin.Tactic.Alias

/-!
# 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 ToAdditive

open Tactic

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

-- see Note [user attribute parameters]
attribute [local semireducible] reflected

/-- Temporarily change the `has_reflect` instance for `name`. -/
@[local instance]
unsafe def hacky_name_reflect : has_reflect Name := fun n => q((id $(expr.const n []) : Name))
#align to_additive.hacky_name_reflect to_additive.hacky_name_reflect

/-- An auxiliary attribute used to store the names of the additive versions of declarations
that have been processed by `to_additive`. -/
@[user_attribute]
unsafe def aux_attr : user_attribute (name_map Name) Name
    where
  Name := `to_additive_aux
  descr := "Auxiliary attribute for `to_additive`. DON'T USE IT"
  parser := failed
  cache_cfg :=
    ⟨fun ns =>
      ns.foldlM
        (fun dict n' => do
          let n :=
            match n' with
            | Name.mk_string s pre => if s = "_to_additive" then pre else n'
            | _ => n'
          let param ← aux_attr.get_param_untyped n'
          pure <| dict n param)
        mk_name_map,
      []⟩
#align to_additive.aux_attr to_additive.aux_attr

end PerformanceHack

section ExtraAttributes

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
/-- 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]
unsafe def ignore_args_attr : user_attribute (name_map <| List ℕ) (List ℕ)
    where
  Name := `to_additive_ignore_args
  descr :=
    "Auxiliary attribute for `to_additive` stating that certain arguments are not additivized."
  cache_cfg :=
    ⟨fun ns =>
      ns.foldlM
        (fun dict n => do
          let param ← ignore_args_attr.get_param_untyped n
          -- see Note [user attribute parameters]
              return <|
              dict n (param expr.to_nat).iget)
        mk_name_map,
      []⟩
  parser := parser.many lean.parser.small_nat
#align to_additive.ignore_args_attr to_additive.ignore_args_attr

/--
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]
unsafe def relevant_arg_attr : user_attribute (name_map ℕ) ℕ
    where
  Name := `to_additive_relevant_arg
  descr :=
    "Auxiliary attribute for `to_additive` stating which arguments are the types with a " ++
      "multiplicative structure."
  cache_cfg :=
    ⟨fun ns =>
      ns.foldlM
        (fun dict n => do
          let 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 n <| param)
        mk_name_map,
      []⟩
  parser := lean.parser.small_nat
#align to_additive.relevant_arg_attr to_additive.relevant_arg_attr

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.many -/
/-- 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]
unsafe def reorder_attr : user_attribute (name_map <| List ℕ) (List ℕ)
    where
  Name := `to_additive_reorder
  descr := "Auxiliary attribute for `to_additive` that stores arguments that need to be reordered."
  cache_cfg :=
    ⟨fun ns =>
      ns.foldlM
        (fun dict n => do
          let param ← reorder_attr.get_param_untyped n
          -- see Note [user attribute parameters]
              return <|
              dict n (param expr.to_nat).iget)
        mk_name_map,
      []⟩
  parser := do
    let l ← parser.many lean.parser.small_nat
    guard (l (· ≠ 0)) <|> exceptional.fail "The reorder positions must be positive"
    return l
#align to_additive.reorder_attr to_additive.reorder_attr

end ExtraAttributes

/-- 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.
-/
unsafe def first_multiplicative_arg (nm : Name) : tactic ℕ := do
  let d ← get_decl nm
  let (es, _) := d.type.pi_binders
  let l ←
    es.mapIdxM fun n bi => do
        let tgt := bi.type.pi_codomain
        let n_bi := bi.type.pi_binders.fst.length
        let tt ← has_attribute' `to_additive tgt.get_app_fn.const_name |
          return none
        let n2 := tgt.get_app_args.headI.get_app_fn.match_var.map fun m => n + n_bi - m
        return <| n2
  let l := l.reduceOption
  return <| if l = [] then 1 else l min l
#align to_additive.first_multiplicative_arg to_additive.first_multiplicative_arg

/-- 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.
-/
unsafe def map_namespace (src tgt : Name) : Tactic := do
  let n := src.mk_string "_to_additive"
  let decl := declaration.thm n [] q(Unit) (pure (reflect ()))
  add_decl decl
  aux_attr n tgt tt
#align to_additive.map_namespace to_additive.map_namespace

/-- `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.
-/
structure ValueType : Type where
  replaceAll : Bool
  trace : Bool
  tgt : Name
  doc : Option String
  allowAutoName : Bool
  deriving has_reflect, Inhabited
#align to_additive.value_type ToAdditive.ValueType

/-- `add_comm_prefix x s` returns `"comm_" ++ s` if `x = tt` and `s` otherwise. -/
unsafe def add_comm_prefix : Bool → String → String
  | tt, s => "comm_" ++ s
  | ff, s => s
#align to_additive.add_comm_prefix to_additive.add_comm_prefix

/-- Dictionary used by `to_additive.guess_name` to autogenerate names. -/
unsafe def tr : Bool → List String → List String
  | is_comm, "one" :: "le" :: s => add_comm_prefix is_comm "nonneg" :: tr false s
  | is_comm, "one" :: "lt" :: s => add_comm_prefix is_comm "pos" :: tr false s
  | is_comm, "le" :: "one" :: s => add_comm_prefix is_comm "nonpos" :: tr false s
  | is_comm, "lt" :: "one" :: s => add_comm_prefix is_comm "neg" :: tr false s
  | is_comm, "mul" :: "single" :: s => add_comm_prefix is_comm "single" :: tr false s
  | is_comm, "mul" :: "support" :: s => add_comm_prefix is_comm "support" :: tr false s
  | is_comm, "mul" :: "tsupport" :: s => add_comm_prefix is_comm "tsupport" :: tr false s
  | is_comm, "mul" :: "indicator" :: s => add_comm_prefix is_comm "indicator" :: tr false s
  | is_comm, "mul" :: s => add_comm_prefix is_comm "add" :: tr false s
  | is_comm, "smul" :: s => add_comm_prefix is_comm "vadd" :: tr false s
  | is_comm, "inv" :: s => add_comm_prefix is_comm "neg" :: tr false s
  | is_comm, "div" :: s => add_comm_prefix is_comm "sub" :: tr false s
  | is_comm, "one" :: s => add_comm_prefix is_comm "zero" :: tr false s
  | is_comm, "prod" :: s => add_comm_prefix is_comm "sum" :: tr false s
  | is_comm, "finprod" :: s => add_comm_prefix is_comm "finsum" :: tr false s
  | is_comm, "pow" :: s => add_comm_prefix is_comm "nsmul" :: tr false s
  | is_comm, "npow" :: s => add_comm_prefix is_comm "nsmul" :: tr false s
  | is_comm, "zpow" :: s => add_comm_prefix is_comm "zsmul" :: tr false s
  | is_comm, "is" :: "square" :: s => add_comm_prefix is_comm "even" :: tr false s
  | is_comm, "is" :: "scalar" :: "tower" :: s =>
    add_comm_prefix is_comm "vadd_assoc_class" :: tr false s
  | is_comm, "is" :: "central" :: "scalar" :: s =>
    add_comm_prefix is_comm "is_central_vadd" :: tr false s
  | is_comm, "is" :: "regular" :: s => add_comm_prefix is_comm "is_add_regular" :: tr false s
  | is_comm, "is" :: "left" :: "regular" :: s =>
    add_comm_prefix is_comm "is_add_left_regular" :: tr false s
  | is_comm, "is" :: "right" :: "regular" :: s =>
    add_comm_prefix is_comm "is_add_right_regular" :: tr false s
  | is_comm, "division" :: "monoid" :: s =>
    "subtraction" :: add_comm_prefix is_comm "monoid" :: tr false s
  | is_comm, "monoid" :: s => ("add_" ++ add_comm_prefix is_comm "monoid") :: tr false s
  | is_comm, "submonoid" :: s => ("add_" ++ add_comm_prefix is_comm "submonoid") :: tr false s
  | is_comm, "group" :: s => ("add_" ++ add_comm_prefix is_comm "group") :: tr false s
  | is_comm, "subgroup" :: s => ("add_" ++ add_comm_prefix is_comm "subgroup") :: tr false s
  | is_comm, "semigroup" :: s => ("add_" ++ add_comm_prefix is_comm "semigroup") :: tr false s
  | is_comm, "magma" :: s => ("add_" ++ add_comm_prefix is_comm "magma") :: tr false s
  | is_comm, "haar" :: s => ("add_" ++ add_comm_prefix is_comm "haar") :: tr false s
  | is_comm, "prehaar" :: s => ("add_" ++ add_comm_prefix is_comm "prehaar") :: tr false s
  | is_comm, "unit" :: s => ("add_" ++ add_comm_prefix is_comm "unit") :: tr false s
  | is_comm, "units" :: s => ("add_" ++ add_comm_prefix is_comm "units") :: tr false s
  | is_comm, "comm" :: s => tr true s
  | is_comm, "root" :: s => add_comm_prefix is_comm "div" :: tr false s
  | is_comm, "rootable" :: s => add_comm_prefix is_comm "divisible" :: tr false s
  | is_comm, "prods" :: s => add_comm_prefix is_comm "sums" :: tr false s
  | is_comm, x :: s => add_comm_prefix is_comm x :: tr false s
  | tt, [] => ["comm"]
  | ff, [] => []
#align to_additive.tr to_additive.tr

/-- Autogenerate target name for `to_additive`. -/
unsafe def guess_name : String → String :=
  String.mapTokens ''' fun s =>
    String.intercalate (String.singleton '_') <| tr false (s.splitOn '_')
#align to_additive.guess_name to_additive.guess_name

/-- Return the provided target name or autogenerate one if one was not provided. -/
unsafe def target_name (src tgt : Name) (dict : name_map Name) (allow_auto_name : Bool) :
    tactic Name :=
  (if tgt.getPrefix ≠ Name.anonymous ∨ allow_auto_name then
      -- `tgt` is a full name
        pure
        tgt
    else
      match src with
      | Name.mk_string s pre => do
        let tgt_auto := guess_name s
        guard (tgt ≠ tgt_auto ∨ tgt = src) <|>
            trace
              ("`to_additive " ++ src ++ "`: 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) (pre dict)
      | _ => fail ("to_additive: can't transport " ++ src.toString)) >>=
    fun res =>
    if res = src ∧ tgt ≠ src then
      fail
        ("to_additive: can't transport " ++ src.toString ++
          " to itself.\nGive the desired additive name explicitly using `@[to_additive additive_name]`. ")
    else pure res
#align to_additive.target_name to_additive.target_name

/- ./././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.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- the parser for the arguments to `to_additive`. -/
unsafe def parser : lean.parser ValueType := do
  let bang ← Option.isSome <$> parser.optional (tk "!")
  let ques ← Option.isSome <$> parser.optional (tk "?")
  let tgt ← parser.optional ident
  let e ← parser.optional texpr
  let doc ←
    match e with
      | some pe => some <$> (to_expr pe >>= eval_expr String : tactic String)
      | none => pure none
  return ⟨bang, ques, tgt Name.anonymous, doc, ff⟩
#align to_additive.parser to_additive.parser

private unsafe def proceed_fields_aux (src tgt : Name) (prio : ℕ)
    (f : Name → tactic (List String)) : Tactic := do
  let src_fields ← f src
  let tgt_fields ← f tgt
  guard (src_fields = tgt_fields) <|> fail ("Failed to map fields of " ++ src)
  (src_fields tgt_fields).mapM' fun names =>
      guard (names = names) <|> aux_attr (src names) (tgt names) tt prio
#align to_additive.proceed_fields_aux to_additive.proceed_fields_aux

/-- 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. -/
unsafe def proceed_fields (env : environment) (src tgt : Name) (prio : ℕ) : Tactic :=
  let aux := proceed_fields_aux src tgt prio
  do
  ((aux fun n => pure <| List.map Name.toString <| (env n).getD []) >>
        aux fun n => (List.map fun x : Name => "to_" ++ x) <$> get_tagged_ancestors n) >>
      aux fun n =>
        (env n).mapM fun cs =>
          match cs with
          | Name.mk_string s pre => (guard (pre = n) <|> fail "Bad constructor name") >> pure s
          | _ => fail "Bad constructor name"
#align to_additive.proceed_fields to_additive.proceed_fields

/-- 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 : ℕ∞)` 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 unsafe def attr : user_attribute Unit ValueType
    where
  Name := `to_additive
  descr := "Transport multiplicative to additive"
  parser := parser
  after_set :=
    some fun src prio persistent => do
      guard persistent <|> fail "`to_additive` can't be used as a local attribute"
      let env ← get_env
      let val ← attr.get_param src
      let dict ← aux_attr.get_cache
      let ignore ← ignore_args_attr.get_cache
      let relevant ← relevant_arg_attr.get_cache
      let reorder ← reorder_attr.get_cache
      let tgt ← target_name src val.tgt dict val.allowAutoName
      aux_attr src tgt tt
      let dict := dict.insert src tgt
      let first_mult_arg ← first_multiplicative_arg src
      when (first_mult_arg ≠ 1) <| relevant_arg_attr src first_mult_arg tt
      if env tgt then proceed_fields env src tgt prio
        else do
          transform_decl_with_prefix_dict dict val val 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]
          whenM (has_attribute' `simps src)
              (trace "Apply the simps attribute after the to_additive attribute")
          whenM (has_attribute' `mono src)
              (trace <|
                "to_additive does not work with mono, apply the mono attribute to both" ++
                  "versions after")
          match val with
            | some doc => add_doc_string tgt doc
            | none => do
              let some alias_target ← tactic.alias.get_alias_target src |
                skip
              let alias_name := alias_target
              let some add_alias_name ← pure (dict alias_name) |
                skip
              add_doc_string tgt alias_target
#align to_additive.attr to_additive.attr

add_tactic_doc
  { Name := "to_additive"
    category := DocCategory.attr
    declNames := [`to_additive.attr]
    tags := ["transport", "environment", "lemma derivation"] }

end ToAdditive

-- map operations
attribute [to_additive] Mul One Inv 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]
unsafe def linter.to_additive_doc : linter
    where
  test d := do
    let mul_name := d.to_name
    let dict ← to_additive.aux_attr.get_cache
    match dict mul_name with
      | some add_name => do
        let mul_doc ← try_core <| doc_string mul_name
        let add_doc ← try_core <| doc_string add_name
        match mul_doc, add_doc with
          | tt, ff =>
            return <|
              some <|
                "declaration has a docstring, but its additive version `" ++ add_name ++
                    "` 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 ++
                  "` does. You might want to add a doc string to the declaration."
          | _, _ => return none
      | none => return none
  auto_decls := false
  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 := false
#align linter.to_additive_doc linter.to_additive_doc

end Linter


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default

universes u l

namespace Mathlib

/--
A difference list is a function that, given a list, returns the original
contents of the difference list prepended to the given list.

This structure supports `O(1)` `append` and `concat` operations on lists, making it
useful for append-heavy uses such as logging and pretty printing.
-/
structure dlist (α : Type u) where
  apply : List α → List α
  invariant : ∀ (l : List α), apply l = apply [] ++ l

namespace dlist

/-- Convert a list to a dlist -/
def of_list {α : Type u} (l : List α) : dlist α := mk (append l) sorry

/-- Convert a lazily-evaluated list to a dlist -/
def lazy_of_list {α : Type u} (l : thunk (List α)) : dlist α :=
  mk (fun (xs : List α) => l Unit.unit ++ xs) sorry

/-- Convert a dlist to a list -/
def to_list {α : Type u} : dlist α → List α := sorry

/--  Create a dlist containing no elements -/
def empty {α : Type u} : dlist α := mk id sorry

/-- Create dlist with a single element -/
def singleton {α : Type u} (x : α) : dlist α := mk (List.cons x) sorry

/-- `O(1)` Prepend a single element to a dlist -/
def cons {α : Type u} (x : α) : dlist α → dlist α := sorry

/-- `O(1)` Append a single element to a dlist -/
def concat {α : Type u} (x : α) : dlist α → dlist α := sorry

/-- `O(1)` Append dlists -/
protected def append {α : Type u} : dlist α → dlist α → dlist α := sorry

protected instance has_append {α : Type u} : Append (dlist α) := { append := dlist.append }

theorem to_list_of_list {α : Type u} (l : List α) : to_list (of_list l) = l := sorry

theorem of_list_to_list {α : Type u} (l : dlist α) : of_list (to_list l) = l := sorry

theorem to_list_empty {α : Type u} : to_list empty = [] := sorry

theorem to_list_singleton {α : Type u} (x : α) : to_list (singleton x) = [x] := sorry

theorem to_list_append {α : Type u} (l₁ : dlist α) (l₂ : dlist α) :
    to_list (l₁ ++ l₂) = to_list l₁ ++ to_list l₂ :=
  sorry

theorem to_list_cons {α : Type u} (x : α) (l : dlist α) : to_list (cons x l) = x :: to_list l :=
  sorry

theorem to_list_concat {α : Type u} (x : α) (l : dlist α) :
    to_list (concat x l) = to_list l ++ [x] :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Johannes Hölzl, Simon Hudon, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.basic
import Mathlib.control.traversable.lemmas
import Mathlib.control.traversable.instances
import Mathlib.PostPort

universes u_1 u u_2

namespace Mathlib

/-!
# Functoriality of `multiset`.
-/

namespace multiset

protected instance functor : Functor multiset :=
  { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β }

@[simp] theorem fmap_def {α' : Type u_1} {β' : Type u_1} {s : multiset α'} (f : α' → β') : f <$> s = map f s :=
  rfl

protected instance is_lawful_functor : is_lawful_functor multiset := sorry

def traverse {F : Type u → Type u} [Applicative F] [is_comm_applicative F] {α' : Type u} {β' : Type u} (f : α' → F β') : multiset α' → F (multiset β') :=
  quotient.lift (Functor.map coe ∘ traverse f) sorry

protected instance monad : Monad multiset :=
  { toApplicative :=
      { toFunctor := { map := Functor.map, mapConst := Functor.mapConst },
        toPure := { pure := fun (α : Type u_1) (x : α) => x ::ₘ 0 },
        toSeq :=
          { seq := fun (α β : Type u_1) (f : multiset (α → β)) (x : multiset α) => bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : multiset α) (b : multiset β) =>
                (fun (α β : Type u_1) (f : multiset (α → β)) (x : multiset α) => bind f fun (_x : α → β) => map _x x) β α
                  (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : multiset α) (b : multiset β) =>
                (fun (α β : Type u_1) (f : multiset (α → β)) (x : multiset α) => bind f fun (_x : α → β) => map _x x) β β
                  (map (function.const α id) a) b } },
    toBind := { bind := bind } }

@[simp] theorem pure_def {α : Type u_1} : pure = fun (x : α) => x ::ₘ 0 :=
  rfl

@[simp] theorem bind_def {α : Type u_1} {β : Type u_1} : bind = bind :=
  rfl

protected instance is_lawful_monad : is_lawful_monad multiset := sorry

@[simp] theorem lift_beta {α : Type u_1} {β : Type u_2} (x : List α) (f : List α → β) (h : ∀ (a b : List α), a ≈ b → f a = f b) : quotient.lift f h ↑x = f x :=
  quotient.lift_beta f h x

@[simp] theorem map_comp_coe {α : Type u_1} {β : Type u_1} (h : α → β) : Functor.map h ∘ coe = coe ∘ Functor.map h := sorry

theorem id_traverse {α : Type u_1} (x : multiset α) : traverse id.mk x = x := sorry

theorem comp_traverse {G : Type u_1 → Type u_1} {H : Type u_1 → Type u_1} [Applicative G] [Applicative H] [is_comm_applicative G] [is_comm_applicative H] {α : Type u_1} {β : Type u_1} {γ : Type u_1} (g : α → G β) (h : β → H γ) (x : multiset α) : traverse (functor.comp.mk ∘ Functor.map h ∘ g) x = functor.comp.mk (traverse h <$> traverse g x) := sorry

theorem map_traverse {G : Type u_1 → Type u_1} [Applicative G] [is_comm_applicative G] {α : Type u_1} {β : Type u_1} {γ : Type u_1} (g : α → G β) (h : β → γ) (x : multiset α) : Functor.map h <$> traverse g x = traverse (Functor.map h ∘ g) x := sorry

theorem traverse_map {G : Type u_1 → Type u_1} [Applicative G] [is_comm_applicative G] {α : Type u_1} {β : Type u_1} {γ : Type u_1} (g : α → β) (h : β → G γ) (x : multiset α) : traverse h (map g x) = traverse (h ∘ g) x := sorry

theorem naturality {G : Type u_1 → Type u_1} {H : Type u_1 → Type u_1} [Applicative G] [Applicative H] [is_comm_applicative G] [is_comm_applicative H] (eta : applicative_transformation G H) {α : Type u_1} {β : Type u_1} (f : α → G β) (x : multiset α) : coe_fn eta (multiset β) (traverse f x) = traverse (coe_fn eta β ∘ f) x := sorry


/-
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.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.transform_decl
import Mathlib.tactic.algebra
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# 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 α)`.

* Rewrite rules for the last part of the name that work in more
  cases. E.g., we can replace `monoid` with `add_monoid` etc.
-/

namespace to_additive

/-- An auxiliary attribute used to store the names of the additive versions of declarations
that have been processed by `to_additive`. -/
/-- 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.
-/
/-- `value_type` is the type of the arguments that can be provided to `to_additive`.
`to_additive.parser` parses the provided arguments into `name` for the target and an
optional doc string. -/
structure value_type where
  tgt : name
  doc : Option string

/-- `add_comm_prefix x s` returns `"comm_" ++ s` if `x = tt` and `s` otherwise. -/
/-- Dictionary used by `to_additive.guess_name` to autogenerate names. -/
/-- Autogenerate target name for `to_additive`. -/
/-- Return the provided target name or autogenerate one if one was not provided. -/
/-- the parser for the arguments to `to_additive` -/
/-- 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. -/
/--
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, and
provide a documentation string:

```
@[to_additive add_foo "add_foo doc string"]
/-- foo doc string -/
end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Binder elimination
-/
import order.complete_lattice

namespace old_conv
open tactic monad

meta instance : monad_fail old_conv :=
{ fail := λ α s, (λr e, tactic.fail (to_fmt s) : old_conv α), ..old_conv.monad }

meta instance : has_monad_lift tactic old_conv :=
⟨λα, lift_tactic⟩

meta instance (α : Type) : has_coe (tactic α) (old_conv α) :=
⟨monad_lift⟩

meta def current_relation : old_conv name := λr lhs, return ⟨r, lhs, none⟩

meta def head_beta : old_conv unit :=
λ r e, do n ← tactic.head_beta e, return ⟨(), n, none⟩

/- congr should forward data! -/
meta def congr_arg : old_conv unit → old_conv unit := congr_core (return ())
meta def congr_fun : old_conv unit → old_conv unit := λc, congr_core c (return ())

meta def congr_rule (congr : expr) (cs : list (list expr → old_conv unit)) :
  old_conv unit :=
λr lhs, do
  meta_rhs ← infer_type lhs >>= mk_meta_var, -- is maybe overly restricted for `heq`
  t ← mk_app r [lhs, meta_rhs],
  ((), meta_pr) ← solve_aux t (do
    apply congr,
    focus $ cs.map $ λc, (do
      xs ← intros,
      conversion (head_beta >> c xs)),
    done),
  rhs ← instantiate_mvars meta_rhs,
  pr ← instantiate_mvars meta_pr,
  return ⟨(), rhs, some pr⟩

meta def congr_binder (congr : name) (cs : expr → old_conv unit) : old_conv unit := do
  e ← mk_const congr,
  congr_rule e [λbs, do [b] ← return bs, cs b]

meta def funext' : (expr → old_conv unit) → old_conv unit := congr_binder ``_root_.funext

meta def propext' {α : Type} (c : old_conv α) : old_conv α := λr lhs, (do
  guard (r = `iff),
  c r lhs)
<|> (do
  guard (r = `eq),
  ⟨res, rhs, pr⟩ ← c `iff lhs,
  match pr with
  | some pr := return ⟨res, rhs, (expr.const `propext [] : expr) lhs rhs pr⟩
  | none := return ⟨res, rhs, none⟩
  end)

meta def apply (pr : expr) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add pr,
  apply_lemmas sl r e

meta def applyc (n : name) : old_conv unit :=
λ r e, do
  sl ← simp_lemmas.mk.add_simp n,
  apply_lemmas sl r e

meta def apply' (n : name) : old_conv unit := do
  e ← mk_const n,
  congr_rule e []

end old_conv

open expr tactic old_conv

/- Binder elimination:

We assume a binder `B : p → Π (α : Sort u), (α → t) → t`, where `t` is a type depending on `p`.
Examples:
  ∃: there is no `p` and `t` is `Prop`.
  ⨅, ⨆: here p is `β` and `[complete_lattice β]`, `p` is `β`

Problem: ∀x, _ should be a binder, but is not a constant!

Provide a mechanism to rewrite:

  B (x : α) ..x.. (h : x = t), p x  =  B ..x/t.., p t

Here ..x.. are binders, maybe also some constants which provide commutativity rules with `B`.

-/

meta structure binder_eq_elim :=
(match_binder  : expr → tactic (expr × expr))    -- returns the bound type and body
(adapt_rel     : old_conv unit → old_conv unit)          -- optionally adapt `eq` to `iff`
(apply_comm    : old_conv unit)                      -- apply commutativity rule
(apply_congr   : (expr → old_conv unit) → old_conv unit) -- apply congruence rule
(apply_elim_eq : old_conv unit)                      -- (B (x : β) (h : x = t), s x) = s t

meta def binder_eq_elim.check_eq (b : binder_eq_elim) (x : expr) : expr → tactic unit
| `(@eq %%β %%l %%r) := guard ((l = x ∧ ¬ x.occurs r) ∨ (r = x ∧ ¬ x.occurs l))
| _ := fail "no match"

meta def binder_eq_elim.pull (b : binder_eq_elim) (x : expr) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  guard (¬ x.occurs β)
  <|> b.check_eq x β
  <|> (do
    b.apply_congr $ λx, binder_eq_elim.pull,
    b.apply_comm)

meta def binder_eq_elim.push (b : binder_eq_elim) : old_conv unit :=
  b.apply_elim_eq
<|> (do
  b.apply_comm,
  b.apply_congr $ λx, binder_eq_elim.push)
<|> (do
  b.apply_congr $ b.pull,
  binder_eq_elim.push)

meta def binder_eq_elim.check (b : binder_eq_elim) (x : expr) : expr → tactic unit
| e := do
  (β, f) ← b.match_binder e,
  b.check_eq x β
  <|> (do
    (lam n bi d bd) ← return f,
    x ← mk_local' n bi d,
    binder_eq_elim.check $ bd.instantiate_var x)

meta def binder_eq_elim.old_conv (b : binder_eq_elim) : old_conv unit := do
  (β, f) ← lhs >>= (lift_tactic ∘ b.match_binder),
  (lam n bi d bd) ← return f,
  x ← mk_local' n bi d,
  b.check x (bd.instantiate_var x),
  b.adapt_rel b.push

theorem {u v} exists_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∃(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

theorem {u v} exists_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∃(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λ⟨a', ⟨h, p_h⟩⟩, match a', h, p_h with ._, rfl, h := h end, λh, ⟨a, rfl, h⟩⟩

meta def exists_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@Exists %%β %%f) ← return e, return (β, f)),
  adapt_rel     := propext',
  apply_comm    := applyc ``exists_comm,
  apply_congr   := congr_binder ``exists_congr,
  apply_elim_eq := apply' ``exists_elim_eq_left <|> apply' ``exists_elim_eq_right }

theorem {u v} forall_comm {α : Sort u} {β : Sort v} (p : α → β → Prop) :
  (∀a b, p a b) ↔ (∀b a, p a b) :=
⟨assume h b a, h a b, assume h b a, h a b⟩

theorem {u v} forall_elim_eq_left {α : Sort u} (a : α) (p : Π(a':α), a' = a → Prop) :
  (∀(a':α)(h : a' = a), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

theorem {u v} forall_elim_eq_right {α : Sort u} (a : α) (p : Π(a':α), a = a' → Prop) :
  (∀(a':α)(h : a = a'), p a' h) ↔ p a rfl :=
⟨λh, h a rfl, λh a' h_eq, match a', h_eq with ._, rfl := h end⟩

meta def forall_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do (expr.pi n bi d bd) ← return e, return (d, expr.lam n bi d bd)),
  adapt_rel     := propext',
  apply_comm    := applyc ``forall_comm,
  apply_congr   := congr_binder ``forall_congr,
  apply_elim_eq := apply' ``forall_elim_eq_left <|> apply' ``forall_elim_eq_right }

meta def supr_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@supr %%α %%cl %%β %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``supr_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``supr_supr_eq_left <|> applyc ``supr_supr_eq_right }

meta def infi_eq_elim : binder_eq_elim :=
{ match_binder  := λe, (do `(@infi %%α %%cl %%β %%f) ← return e, return (β, f)),
  adapt_rel     := λc, (do r ← current_relation, guard (r = `eq), c),
  apply_comm    := applyc ``infi_comm,
  apply_congr   := congr_arg ∘ funext',
  apply_elim_eq := applyc ``infi_infi_eq_left <|> applyc ``infi_infi_eq_right }

universes u v w w₂
variables {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂} {s t : set α} {a : α}

section
variables [complete_lattice α]

example {s : set β} {f : β → α} : Inf (set.image f s) = (⨅ a ∈ s, f a) :=
begin
  simp [Inf_eq_infi, infi_and],
  conversion infi_eq_elim.old_conv,
end

example {s : set β} {f : β → α} : Sup (set.image f s) = (⨆ a ∈ s, f a) :=
begin
  simp [Sup_eq_supr, supr_and],
  conversion supr_eq_elim.old_conv,
end

end


variables {p q : Prop} (hp : p) (hq : q)

include hp hq

example : p ∧ q ∧ p :=
begin
  apply and.intro hp,
  exact and.intro hq hp
end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Data.Option.Basic

universe u v

theorem Option.eq_of_eq_some {α : Type u} : ∀ {x y : Option α}, (∀z, x = some z ↔ y = some z) → x = y
  | none,   none,   _ => rfl
  | none,   some z, h => Option.noConfusion ((h z).2 rfl)
  | some z, none,   h => Option.noConfusion ((h z).1 rfl)
  | some _, some w, h => Option.noConfusion ((h w).2 rfl) (congrArg some)

theorem Option.eq_none_of_isNone {α : Type u} : ∀ {o : Option α}, o.isNone → o = none
  | none, _ => rfl


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.data.sigma.basic
import Mathlib.algebra.group.defs
import Mathlib.PostPort

universes u_1 u_2 l u v u_3 w x u_4

namespace Mathlib

/-!
# Injective functions
-/

namespace function

/-- `α ↪ β` is a bundled injective function. -/
structure embedding (α : Sort u_1) (β : Sort u_2)
where
  to_fun : α → β
  inj' : injective to_fun

infixr:25 " ↪ " => Mathlib.function.embedding

protected instance embedding.has_coe_to_fun {α : Sort u} {β : Sort v} : has_coe_to_fun (α ↪ β) :=
  has_coe_to_fun.mk (fun (x : α ↪ β) => α → β) embedding.to_fun

end function

/-- Convert an `α ≃ β` to `α ↪ β`. -/
@[simp] theorem equiv.to_embedding_apply {α : Sort u} {β : Sort v} (f : α ≃ β) : ∀ (ᾰ : α), coe_fn (equiv.to_embedding f) ᾰ = coe_fn f ᾰ :=
  fun (ᾰ : α) => Eq.refl (coe_fn (equiv.to_embedding f) ᾰ)

namespace function

namespace embedding

theorem ext {α : Sort u_1} {β : Sort u_2} {f : α ↪ β} {g : α ↪ β} (h : ∀ (x : α), coe_fn f x = coe_fn g x) : f = g := sorry

theorem ext_iff {α : Sort u_1} {β : Sort u_2} {f : α ↪ β} {g : α ↪ β} : (∀ (x : α), coe_fn f x = coe_fn g x) ↔ f = g := sorry

@[simp] theorem to_fun_eq_coe {α : Sort u_1} {β : Sort u_2} (f : α ↪ β) : to_fun f = ⇑f :=
  rfl

@[simp] theorem coe_fn_mk {α : Sort u_1} {β : Sort u_2} (f : α → β) (i : injective f) : ⇑(mk f i) = f :=
  rfl

theorem injective {α : Sort u_1} {β : Sort u_2} (f : α ↪ β) : injective ⇑f :=
  inj' f

@[simp] theorem refl_apply (α : Sort u_1) (a : α) : coe_fn (embedding.refl α) a = a :=
  Eq.refl a

@[simp] theorem trans_apply {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} (f : α ↪ β) (g : β ↪ γ) : ∀ (ᾰ : α), coe_fn (embedding.trans f g) ᾰ = coe_fn g (coe_fn f ᾰ) :=
  fun (ᾰ : α) => Eq.refl (coe_fn g (coe_fn f ᾰ))

@[simp] theorem equiv_to_embedding_trans_symm_to_embedding {α : Sort u_1} {β : Sort u_2} (e : α ≃ β) : embedding.trans (equiv.to_embedding e) (equiv.to_embedding (equiv.symm e)) = embedding.refl α := sorry

@[simp] theorem equiv_symm_to_embedding_trans_to_embedding {α : Sort u_1} {β : Sort u_2} (e : α ≃ β) : embedding.trans (equiv.to_embedding (equiv.symm e)) (equiv.to_embedding e) = embedding.refl β := sorry

protected def congr {α : Sort u} {β : Sort v} {γ : Sort w} {δ : Sort x} (e₁ : α ≃ β) (e₂ : γ ≃ δ) (f : α ↪ γ) : β ↪ δ :=
  embedding.trans (equiv.to_embedding (equiv.symm e₁)) (embedding.trans f (equiv.to_embedding e₂))

/-- A right inverse `surj_inv` of a surjective function as an `embedding`. -/
protected def of_surjective {α : Sort u_1} {β : Sort u_2} (f : β → α) (hf : surjective f) : α ↪ β :=
  mk (surj_inv hf) (injective_surj_inv hf)

/-- Convert a surjective `embedding` to an `equiv` -/
protected def equiv_of_surjective {α : Sort u_1} {β : Type u_2} (f : α ↪ β) (hf : surjective ⇑f) : α ≃ β :=
  equiv.of_bijective ⇑f sorry

protected def of_not_nonempty {α : Sort u_1} {β : Sort u_2} (hα : ¬Nonempty α) : α ↪ β :=
  mk (fun (a : α) => false.elim sorry) sorry

/-- Change the value of an embedding `f` at one point. If the prescribed image
is already occupied by some `f a'`, then swap the values at these two points. -/
def set_value {α : Sort u_1} {β : Sort u_2} (f : α ↪ β) (a : α) (b : β) [(a' : α) → Decidable (a' = a)] [(a' : α) → Decidable (coe_fn f a' = b)] : α ↪ β :=
  mk (fun (a' : α) => ite (a' = a) b (ite (coe_fn f a' = b) (coe_fn f a) (coe_fn f a'))) sorry

theorem set_value_eq {α : Sort u_1} {β : Sort u_2} (f : α ↪ β) (a : α) (b : β) [(a' : α) → Decidable (a' = a)] [(a' : α) → Decidable (coe_fn f a' = b)] : coe_fn (set_value f a b) a = b := sorry

/-- Embedding into `option` -/
protected def some {α : Type u_1} : α ↪ Option α :=
  mk some (option.some_injective α)

/-- Embedding of a `subtype`. -/
def subtype {α : Sort u_1} (p : α → Prop) : Subtype p ↪ α :=
  mk coe sorry

@[simp] theorem coe_subtype {α : Sort u_1} (p : α → Prop) : ⇑(subtype p) = coe :=
  rfl

/-- Choosing an element `b : β` gives an embedding of `punit` into `β`. -/
def punit {β : Sort u_1} (b : β) : PUnit ↪ β :=
  mk (fun (_x : PUnit) => b) sorry

/-- Fixing an element `b : β` gives an embedding `α ↪ α × β`. -/
def sectl (α : Type u_1) {β : Type u_2} (b : β) : α ↪ α × β :=
  mk (fun (a : α) => (a, b)) sorry

/-- Fixing an element `a : α` gives an embedding `β ↪ α × β`. -/
def sectr {α : Type u_1} (a : α) (β : Type u_2) : β ↪ α × β :=
  mk (fun (b : β) => (a, b)) sorry

/-- Restrict the codomain of an embedding. -/
def cod_restrict {α : Sort u_1} {β : Type u_2} (p : set β) (f : α ↪ β) (H : ∀ (a : α), coe_fn f a ∈ p) : α ↪ ↥p :=
  mk (fun (a : α) => { val := coe_fn f a, property := H a }) sorry

@[simp] theorem cod_restrict_apply {α : Sort u_1} {β : Type u_2} (p : set β) (f : α ↪ β) (H : ∀ (a : α), coe_fn f a ∈ p) (a : α) : coe_fn (cod_restrict p f H) a = { val := coe_fn f a, property := H a } :=
  rfl

/-- If `e₁` and `e₂` are embeddings, then so is `prod.map e₁ e₂ : (a, b) ↦ (e₁ a, e₂ b)`. -/
def prod_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α × γ ↪ β × δ :=
  mk (prod.map ⇑e₁ ⇑e₂) sorry

@[simp] theorem coe_prod_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : ⇑(prod_map e₁ e₂) = prod.map ⇑e₁ ⇑e₂ :=
  rfl

/-- If `e₁` and `e₂` are embeddings, then so is `sum.map e₁ e₂`. -/
def sum_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : α ⊕ γ ↪ β ⊕ δ :=
  mk (sum.map ⇑e₁ ⇑e₂) sorry

@[simp] theorem coe_sum_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (e₁ : α ↪ β) (e₂ : γ ↪ δ) : ⇑(sum_map e₁ e₂) = sum.map ⇑e₁ ⇑e₂ :=
  rfl

/-- The embedding of `α` into the sum `α ⊕ β`. -/
@[simp] theorem inl_apply {α : Type u_1} {β : Type u_2} (val : α) : coe_fn inl val = sum.inl val :=
  Eq.refl (coe_fn inl val)

/-- The embedding of `β` into the sum `α ⊕ β`. -/
@[simp] theorem inr_apply {α : Type u_1} {β : Type u_2} (val : β) : coe_fn inr val = sum.inr val :=
  Eq.refl (coe_fn inr val)

/-- `sigma.mk` as an `function.embedding`. -/
@[simp] theorem sigma_mk_apply {α : Type u_1} {β : α → Type u_3} (a : α) (snd : β a) : coe_fn (sigma_mk a) snd = sigma.mk a snd :=
  Eq.refl (coe_fn (sigma_mk a) snd)

/-- If `f : α ↪ α'` is an embedding and `g : Π a, β α ↪ β' (f α)` is a family
of embeddings, then `sigma.map f g` is an embedding. -/
@[simp] theorem sigma_map_apply {α : Type u_1} {α' : Type u_2} {β : α → Type u_3} {β' : α' → Type u_4} (f : α ↪ α') (g : (a : α) → β a ↪ β' (coe_fn f a)) (x : sigma fun (a : α) => β a) : coe_fn (sigma_map f g) x = sigma.map (⇑f) (fun (a : α) => ⇑(g a)) x :=
  Eq.refl (coe_fn (sigma_map f g) x)

def Pi_congr_right {α : Sort u_1} {β : α → Sort u_2} {γ : α → Sort u_3} (e : (a : α) → β a ↪ γ a) : ((a : α) → β a) ↪ (a : α) → γ a :=
  mk (fun (f : (a : α) → β a) (a : α) => coe_fn (e a) (f a)) sorry

def arrow_congr_left {α : Sort u} {β : Sort v} {γ : Sort w} (e : α ↪ β) : (γ → α) ↪ γ → β :=
  Pi_congr_right fun (_x : γ) => e

def arrow_congr_right {α : Sort u} {β : Sort v} {γ : Sort w} [Inhabited γ] (e : α ↪ β) : (α → γ) ↪ β → γ :=
  let f' : (α → γ) → β → γ :=
    fun (f : α → γ) (b : β) =>
      dite (∃ (c : α), coe_fn e c = b) (fun (h : ∃ (c : α), coe_fn e c = b) => f (classical.some h))
        fun (h : ¬∃ (c : α), coe_fn e c = b) => Inhabited.default;
  mk f' sorry

protected def subtype_map {α : Sort u_1} {β : Sort u_2} {p : α → Prop} {q : β → Prop} (f : α ↪ β) (h : ∀ {x : α}, p x → q (coe_fn f x)) : (Subtype fun (x : α) => p x) ↪ Subtype fun (y : β) => q y :=
  mk (subtype.map (⇑f) h) sorry

/-- `set.image` as an embedding `set α ↪ set β`. -/
protected def image {α : Type u_1} {β : Type u_2} (f : α ↪ β) : set α ↪ set β :=
  mk (set.image ⇑f) sorry

theorem swap_apply {α : Type u_1} {β : Type u_2} [DecidableEq α] [DecidableEq β] (f : α ↪ β) (x : α) (y : α) (z : α) : coe_fn (equiv.swap (coe_fn f x) (coe_fn f y)) (coe_fn f z) = coe_fn f (coe_fn (equiv.swap x y) z) :=
  injective.swap_apply (injective f) x y z

theorem swap_comp {α : Type u_1} {β : Type u_2} [DecidableEq α] [DecidableEq β] (f : α ↪ β) (x : α) (y : α) : ⇑(equiv.swap (coe_fn f x) (coe_fn f y)) ∘ ⇑f = ⇑f ∘ ⇑(equiv.swap x y) :=
  injective.swap_comp (injective f) x y

end embedding

end function

namespace equiv

@[simp] theorem refl_to_embedding {α : Type u_1} : equiv.to_embedding (equiv.refl α) = function.embedding.refl α :=
  rfl

@[simp] theorem trans_to_embedding {α : Type u_1} {β : Type u_2} {γ : Type u_3} (e : α ≃ β) (f : β ≃ γ) : equiv.to_embedding (equiv.trans e f) = function.embedding.trans (equiv.to_embedding e) (equiv.to_embedding f) :=
  rfl

end equiv

namespace set

/-- The injection map is an embedding between subsets. -/
def embedding_of_subset {α : Type u_1} (s : set α) (t : set α) (h : s ⊆ t) : ↥s ↪ ↥t :=
  function.embedding.mk (fun (x : ↥s) => { val := subtype.val x, property := sorry }) sorry

end set

-- TODO: these two definitions probably belong somewhere else, so that we can remove the

-- `algebra.group.defs` import.

/--
The embedding of a left cancellative semigroup into itself
by left multiplication by a fixed element.
 -/
@[simp] theorem add_left_embedding_apply {G : Type u} [add_left_cancel_semigroup G] (g : G) (h : G) : coe_fn (add_left_embedding g) h = g + h :=
  Eq.refl (coe_fn (add_left_embedding g) h)

/--
The embedding of a right cancellative semigroup into itself
by right multiplication by a fixed element.
 -/
def mul_right_embedding {G : Type u} [right_cancel_semigroup G] (g : G) : G ↪ G :=
  function.embedding.mk (fun (h : G) => h * g) (mul_left_injective g)


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Traversable instance for lazy_lists.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.control.traversable.instances
import Mathlib.Lean3Lib.data.lazy_list
import Mathlib.PostPort

universes u_1 u u_2 u_3

namespace Mathlib

/-!
## Definitions on lazy lists

This file contains various definitions and proofs on lazy lists.

TODO: move the `lazy_list.lean` file from core to mathlib.
-/

namespace thunk

/-- Creates a thunk with a (non-lazy) constant value. -/
def mk {α : Type u_1} (x : α) : thunk α :=
  fun (_x : Unit) => x

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (thunk α) :=
  sorry

end thunk

namespace lazy_list

/-- Isomorphism between strict and lazy lists. -/
def list_equiv_lazy_list (α : Type u_1) : List α ≃ lazy_list α :=
  equiv.mk of_list to_list sorry sorry

protected instance inhabited {α : Type u} : Inhabited (lazy_list α) :=
  { default := nil }

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (lazy_list α) :=
  sorry

/-- Traversal of lazy lists using an applicative effect. -/
protected def traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u} (f : α → m β) : lazy_list α → m (lazy_list β) :=
  sorry

protected instance traversable : traversable lazy_list :=
  traversable.mk lazy_list.traverse

protected instance is_lawful_traversable : is_lawful_traversable lazy_list :=
  equiv.is_lawful_traversable' list_equiv_lazy_list sorry sorry sorry

/-- `init xs`, if `xs` non-empty, drops the last element of the list.
Otherwise, return the empty list. -/
def init {α : Type u_1} : lazy_list α → lazy_list α :=
  sorry

/-- Return the first object contained in the list that satisfies
predicate `p` -/
def find {α : Type u_1} (p : α → Prop) [decidable_pred p] : lazy_list α → Option α :=
  sorry

/-- `interleave xs ys` creates a list where elements of `xs` and `ys` alternate. -/
def interleave {α : Type u_1} : lazy_list α → lazy_list α → lazy_list α :=
  sorry

/-- `interleave_all (xs::ys::zs::xss)` creates a list where elements of `xs`, `ys`
and `zs` and the rest alternate. Every other element of the resulting list is taken from
`xs`, every fourth is taken from `ys`, every eighth is taken from `zs` and so on. -/
def interleave_all {α : Type u_1} : List (lazy_list α) → lazy_list α :=
  sorry

/-- Monadic bind operation for `lazy_list`. -/
protected def bind {α : Type u_1} {β : Type u_2} : lazy_list α → (α → lazy_list β) → lazy_list β :=
  sorry

/-- Reverse the order of a `lazy_list`.
It is done by converting to a `list` first because reversal involves evaluating all
the list and if the list is all evaluated, `list` is a better representation for
it than a series of thunks. -/
def reverse {α : Type u_1} (xs : lazy_list α) : lazy_list α :=
  of_list (list.reverse (to_list xs))

protected instance monad : Monad lazy_list := sorry

theorem append_nil {α : Type u_1} (xs : lazy_list α) : (append xs fun (_ : Unit) => nil) = xs := sorry

theorem append_assoc {α : Type u_1} (xs : lazy_list α) (ys : lazy_list α) (zs : lazy_list α) : (append (append xs fun (_ : Unit) => ys) fun (_ : Unit) => zs) =
  append xs fun (_ : Unit) => append ys fun (_ : Unit) => zs := sorry

theorem append_bind {α : Type u_1} {β : Type u_2} (xs : lazy_list α) (ys : thunk (lazy_list α)) (f : α → lazy_list β) : lazy_list.bind (append xs ys) f = append (lazy_list.bind xs f) fun (_ : Unit) => lazy_list.bind (ys Unit.unit) f := sorry

protected instance is_lawful_monad : is_lawful_monad lazy_list := sorry

/-- Try applying function `f` to every element of a `lazy_list` and
return the result of the first attempt that succeeds. -/
def mfirst {m : Type u_1 → Type u_2} [alternative m] {α : Type u_3} {β : Type u_1} (f : α → m β) : lazy_list α → m β :=
  sorry

/-- Membership in lazy lists -/
protected def mem {α : Type u_1} (x : α) : lazy_list α → Prop :=
  sorry

protected instance has_mem {α : outParam (Type u_1)} : has_mem α (lazy_list α) :=
  has_mem.mk lazy_list.mem

protected instance mem.decidable {α : Type u_1} [DecidableEq α] (x : α) (xs : lazy_list α) : Decidable (x ∈ xs) :=
  sorry

@[simp] theorem mem_nil {α : Type u_1} (x : α) : x ∈ nil ↔ False :=
  iff.rfl

@[simp] theorem mem_cons {α : Type u_1} (x : α) (y : α) (ys : thunk (lazy_list α)) : x ∈ cons y ys ↔ x = y ∨ x ∈ ys Unit.unit :=
  iff.rfl

theorem forall_mem_cons {α : Type u_1} {p : α → Prop} {a : α} {l : thunk (lazy_list α)} : (∀ (x : α), x ∈ cons a l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l Unit.unit → p x := sorry

/-! ### map for partial functions -/

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f l h` is essentially the same as `map f l`
  but is defined only when all members of `l` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β) (l : lazy_list α) : (∀ (a : α), a ∈ l → p a) → lazy_list β :=
  sorry

/-- "Attach" the proof that the elements of `l` are in `l` to produce a new `lazy_list`
  with the same elements but in the type `{x // x ∈ l}`. -/
def attach {α : Type u_1} (l : lazy_list α) : lazy_list (Subtype fun (x : α) => x ∈ l) :=
  pmap Subtype.mk l sorry

protected instance has_repr {α : Type u_1} [has_repr α] : has_repr (lazy_list α) :=
  has_repr.mk fun (xs : lazy_list α) => repr (to_list xs)