/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.auto_cases
import tactic.chain
import tactic.norm_cast

namespace tactic

namespace tidy
/-- Tag interactive tactics (locally) with `[tidy]` to add them to the list of default tactics
called by `tidy`. -/
meta def tidy_attribute : user_attribute := {
  name := `tidy,
  descr := "A tactic that should be called by `tidy`."
}

add_tactic_doc
{ name                     := "tidy",
  category                 := doc_category.attr,
  decl_names               := [`tactic.tidy.tidy_attribute],
  tags                     := ["search"] }

run_cmd attribute.register ``tidy_attribute

meta def run_tactics : tactic string :=
do names ← attribute.get_instances `tidy,
   first (names.map name_to_tactic) <|> fail "no @[tidy] tactics succeeded"

@[hint_tactic]
meta def ext1_wrapper : tactic string :=
do ng ← num_goals,
   ext1 [] {apply_cfg . new_goals := new_goals.all},
   ng' ← num_goals,
   return $ if ng' > ng then
     "tactic.ext1 [] {new_goals := tactic.new_goals.all}"
   else "ext1"

meta def default_tactics : list (tactic string) :=
[ reflexivity                                 >> pure "refl",
  `[exact dec_trivial]                        >> pure "exact dec_trivial",
  propositional_goal >> assumption            >> pure "assumption",
  intros1                                     >>= λ ns, pure ("intros " ++ (" ".intercalate (ns.map (λ e, e.to_string)))),
  auto_cases,
  `[apply_auto_param]                         >> pure "apply_auto_param",
  `[dsimp at *]                               >> pure "dsimp at *",
  `[simp at *]                                >> pure "simp at *",
  ext1_wrapper,
  fsplit                                      >> pure "fsplit",
  injections_and_clear                        >> pure "injections_and_clear",
  propositional_goal >> (`[solve_by_elim])    >> pure "solve_by_elim",
  `[norm_cast]                                >> pure "norm_cast",
  `[unfold_coes]                              >> pure "unfold_coes",
  `[unfold_aux]                               >> pure "unfold_aux",
  tidy.run_tactics ]

meta structure cfg :=
(trace_result : bool            := ff)
(trace_result_prefix : string   := "Try this: ")
(tactics : list (tactic string) := default_tactics)

declare_trace tidy

meta def core (cfg : cfg := {}) : tactic (list string) :=
do
  results ← chain cfg.tactics,
  when (cfg.trace_result) $
    trace (cfg.trace_result_prefix ++ (", ".intercalate results)),
  return results

end tidy

meta def tidy (cfg : tidy.cfg := {}) := tactic.tidy.core cfg >> skip

namespace interactive
open lean.parser interactive

/-- Use a variety of conservative tactics to solve goals.

`tidy?` reports back the tactic script it found. As an example
```lean
example : ∀ x : unit, x = unit.star :=
begin
  tidy? -- Prints the trace message: "Try this: intros x, exact dec_trivial"
end
```

The default list of tactics is stored in `tactic.tidy.default_tidy_tactics`.
This list can be overridden using `tidy { tactics := ... }`.
(The list must be a `list` of `tactic string`, so that `tidy?`
can report a usable tactic script.)

Tactics can also be added to the list by tagging them (locally) with the
`[tidy]` attribute. -/
meta def tidy (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :=
tactic.tidy { trace_result := trace.is_some, ..cfg }
end interactive

add_tactic_doc
{ name                     := "tidy",
  category                 := doc_category.tactic,
  decl_names               := [`tactic.interactive.tidy],
  tags                     := ["search", "Try this", "finishing"] }

/-- Invoking the hole command `tidy` ("Use `tidy` to complete the goal") runs the tactic of
the same name, replacing the hole with the tactic script `tidy` produces.
-/
@[hole_command] meta def tidy_hole_cmd : hole_command :=
{ name := "tidy",
  descr := "Use `tidy` to complete the goal.",
  action := λ _, do script ← tidy.core,
    return [("begin " ++ (", ".intercalate script) ++ " end", "by tidy")] }

add_tactic_doc
{ name                     := "tidy",
  category                 := doc_category.hole_cmd,
  decl_names               := [`tactic.tidy_hole_cmd],
  tags                     := ["search"] }

end tactic


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.types
import category_theory.limits.shapes.products
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.terminal

/-!
# Special shapes for limits in `Type`.

The general shape (co)limits defined in `category_theory.limits.types`
are intended for use through the limits API,
and the actual implementation should mostly be considered "sealed".

In this file, we provide definitions of the "standard" special shapes of limits in `Type`,
giving the expected definitional implementation:
* the terminal object is `punit`
* the binary product of `X` and `Y` is `X × Y`
* the product of a family `f : J → Type` is `Π j, f j`
* the binary coproduct of `X` and `Y` is the sum type `X ⊕ Y`
* the equalizer of a pair of maps `(g, h)` is the subtype `{x : Y // g x = h x}`
* the pullback of `f : X ⟶ Z` and `g : Y ⟶ Z` is the subtype `{ p : X × Y // f p.1 = g p.2 }`
  of the product

Because these are not intended for use with the `has_limit` API,
we instead construct terms of `limit_data`.

As an example, when setting up the monoidal category structure on `Type`
we use the `types_has_terminal` and `types_has_binary_products` instances.
-/

universes u

open category_theory
open category_theory.limits

namespace category_theory.limits.types

/-- A restatement of `types.lift_π_apply` that uses `pi.π` and `pi.lift`. -/
@[simp]
lemma pi_lift_π_apply
  {β : Type u} (f : β → Type u) {P : Type u} (s : Π b, P ⟶ f b) (b : β) (x : P) :
  (pi.π f b : (∏ f) → f b) (@pi.lift β _ _ f _ P s x) = s b x :=
congr_fun (limit.lift_π (fan.mk P s) b) x

/-- A restatement of `types.map_π_apply` that uses `pi.π` and `pi.map`. -/
@[simp]
lemma pi_map_π_apply {β : Type u} {f g : β → Type u} (α : Π j, f j ⟶ g j) (b : β) (x) :
  (pi.π g b : (∏ g) → g b) (pi.map α x) = α b ((pi.π f b : (∏ f) → f b) x) :=
limit.map_π_apply _ _ _

/-- The category of types has `punit` as a terminal object. -/
def terminal_limit_cone : limits.limit_cone (functor.empty (Type u)) :=
{ cone :=
  { X := punit,
    π := by tidy, },
  is_limit := by tidy, }

/-- The category of types has `pempty` as an initial object. -/
def initial_limit_cone : limits.colimit_cocone (functor.empty (Type u)) :=
{ cocone :=
  { X := pempty,
    ι := by tidy, },
  is_colimit := by tidy, }

open category_theory.limits.walking_pair

/-- The product type `X × Y` forms a cone for the binary product of `X` and `Y`. -/
-- We manually generate the other projection lemmas since the simp-normal form for the legs is
-- otherwise not created correctly.
@[simps X]
def binary_product_cone (X Y : Type u) : binary_fan X Y :=
binary_fan.mk prod.fst prod.snd

@[simp]
lemma binary_product_cone_fst (X Y : Type u) :
  (binary_product_cone X Y).fst = prod.fst :=
rfl
@[simp]
lemma binary_product_cone_snd (X Y : Type u) :
  (binary_product_cone X Y).snd = prod.snd :=
rfl

/-- The product type `X × Y` is a binary product for `X` and `Y`. -/
@[simps]
def binary_product_limit (X Y : Type u) : is_limit (binary_product_cone X Y) :=
{ lift := λ (s : binary_fan X Y) x, (s.fst x, s.snd x),
  fac' := λ s j, walking_pair.cases_on j rfl rfl,
  uniq' := λ s m w, funext $ λ x, prod.ext (congr_fun (w left) x) (congr_fun (w right) x) }

/--
The category of types has `X × Y`, the usual cartesian product,
as the binary product of `X` and `Y`.
-/
@[simps]
def binary_product_limit_cone (X Y : Type u) : limits.limit_cone (pair X Y) :=
⟨_, binary_product_limit X Y⟩

/-- The functor which sends `X, Y` to the product type `X × Y`. -/
-- We add the option `type_md` to tell `@[simps]` to not treat homomorphisms `X ⟶ Y` in `Type*` as
-- a function type
@[simps {type_md := reducible}]
def binary_product_functor : Type u ⥤ Type u ⥤ Type u :=
{ obj := λ X,
  { obj := λ Y, X × Y,
    map := λ Y₁ Y₂ f, (binary_product_limit X Y₂).lift (binary_fan.mk prod.fst (prod.snd ≫ f)) },
  map := λ X₁ X₂ f,
  { app := λ Y, (binary_product_limit X₂ Y).lift (binary_fan.mk (prod.fst ≫ f) prod.snd) } }

/--
The product functor given by the instance `has_binary_products (Type u)` is isomorphic to the
explicit binary product functor given by the product type.
-/
noncomputable def binary_product_iso_prod : binary_product_functor ≅ (prod.functor : Type u ⥤ _) :=
begin
  apply nat_iso.of_components (λ X, _) _,
  { apply nat_iso.of_components (λ Y, _) _,
    { exact ((limit.is_limit _).cone_point_unique_up_to_iso (binary_product_limit X Y)).symm },
    { intros Y₁ Y₂ f,
      ext1;
      simp } },
  { intros X₁ X₂ g,
    ext : 3;
    simp }
end

/-- The sum type `X ⊕ Y` forms a cocone for the binary coproduct of `X` and `Y`. -/
@[simps]
def binary_coproduct_cocone (X Y : Type u) : cocone (pair X Y) :=
binary_cofan.mk sum.inl sum.inr

/-- The sum type `X ⊕ Y` is a binary coproduct for `X` and `Y`. -/
@[simps]
def binary_coproduct_colimit (X Y : Type u) : is_colimit (binary_coproduct_cocone X Y) :=
{ desc := λ (s : binary_cofan X Y), sum.elim s.inl s.inr,
  fac' := λ s j, walking_pair.cases_on j rfl rfl,
  uniq' := λ s m w, funext $ λ x, sum.cases_on x (congr_fun (w left)) (congr_fun (w right)) }

/--
The category of types has `X ⊕ Y`,
as the binary coproduct of `X` and `Y`.
-/
def binary_coproduct_colimit_cocone (X Y : Type u) : limits.colimit_cocone (pair X Y) :=
⟨_, binary_coproduct_colimit X Y⟩

/--
The category of types has `Π j, f j` as the product of a type family `f : J → Type`.
-/
def product_limit_cone {J : Type u} (F : J → Type u) : limits.limit_cone (discrete.functor F) :=
{ cone :=
  { X := Π j, F j,
    π := { app := λ j f, f j }, },
  is_limit :=
  { lift := λ s x j, s.π.app j x,
    uniq' := λ s m w, funext $ λ x, funext $ λ j, (congr_fun (w j) x : _) } }

/--
The category of types has `Σ j, f j` as the coproduct of a type family `f : J → Type`.
-/
def coproduct_colimit_cocone {J : Type u} (F : J → Type u) :
  limits.colimit_cocone (discrete.functor F) :=
{ cocone :=
  { X := Σ j, F j,
    ι :=
    { app := λ j x, ⟨j, x⟩ }, },
  is_colimit :=
  { desc := λ s x, s.ι.app x.1 x.2,
    uniq' := λ s m w,
    begin
      ext ⟨j, x⟩,
      have := congr_fun (w j) x,
      exact this,
    end }, }

section fork
variables {X Y Z : Type u} (f : X ⟶ Y) {g h : Y ⟶ Z} (w : f ≫ g = f ≫ h)

/--
Show the given fork in `Type u` is an equalizer given that any element in the "difference kernel"
comes from `X`.
The converse of `unique_of_type_equalizer`.
-/
noncomputable def type_equalizer_of_unique (t : ∀ (y : Y), g y = h y → ∃! (x : X), f x = y) :
  is_limit (fork.of_ι _ w) :=
fork.is_limit.mk' _ $ λ s,
begin
  refine ⟨λ i, _, _, _⟩,
  { apply classical.some (t (s.ι i) _),
    apply congr_fun s.condition i },
  { ext i,
    apply (classical.some_spec (t (s.ι i) _)).1 },
  { intros m hm,
    ext i,
    apply (classical.some_spec (t (s.ι i) _)).2,
    apply congr_fun hm i },
end

/-- The converse of `type_equalizer_of_unique`. -/
lemma unique_of_type_equalizer (t : is_limit (fork.of_ι _ w)) (y : Y) (hy : g y = h y) :
  ∃! (x : X), f x = y :=
begin
  let y' : punit ⟶ Y := λ _, y,
  have hy' : y' ≫ g = y' ≫ h := funext (λ _, hy),
  refine ⟨(fork.is_limit.lift' t _ hy').1 ⟨⟩, congr_fun (fork.is_limit.lift' t y' _).2 ⟨⟩, _⟩,
  intros x' hx',
  suffices : (λ (_ : punit), x') = (fork.is_limit.lift' t y' hy').1,
    rw ← this,
  apply fork.is_limit.hom_ext t,
  ext ⟨⟩,
  apply hx'.trans (congr_fun (fork.is_limit.lift' t _ hy').2 ⟨⟩).symm,
end

lemma type_equalizer_iff_unique :
  nonempty (is_limit (fork.of_ι _ w)) ↔ (∀ (y : Y), g y = h y → ∃! (x : X), f x = y) :=
⟨λ i, unique_of_type_equalizer _ _ (classical.choice i), λ k, ⟨type_equalizer_of_unique f w k⟩⟩

/-- Show that the subtype `{x : Y // g x = h x}` is an equalizer for the pair `(g,h)`. -/
def equalizer_limit : limits.limit_cone (parallel_pair g h) :=
{ cone := fork.of_ι (subtype.val : {x : Y // g x = h x} → Y) (funext subtype.prop),
  is_limit := fork.is_limit.mk' _ $ λ s,
    ⟨λ i, ⟨s.ι i, by apply congr_fun s.condition i⟩,
     rfl,
     λ m hm, funext $ λ x, subtype.ext (congr_fun hm x)⟩ }

end fork

section pullback
open category_theory.limits.walking_pair
open category_theory.limits.walking_cospan
open category_theory.limits.walking_cospan.hom

variables {W X Y Z : Type u}
variables (f : X ⟶ Z) (g : Y ⟶ Z)

/--
The usual explicit pullback in the category of types, as a subtype of the product.
The full `limit_cone` data is bundled as `pullback_limit_cone f g`.
-/
@[nolint has_inhabited_instance]
abbreviation pullback_obj : Type u := { p : X × Y // f p.1 = g p.2 }

-- `pullback_obj f g` comes with a coercion to the product type `X × Y`.
example (p : pullback_obj f g) : X × Y := p

/--
The explicit pullback cone on `pullback_obj f g`.
This is bundled with the `is_limit` data as `pullback_limit_cone f g`.
-/
abbreviation pullback_cone : limits.pullback_cone f g :=
pullback_cone.mk (λ p : pullback_obj f g, p.1.1) (λ p, p.1.2) (funext (λ p, p.2))

/--
The explicit pullback in the category of types, bundled up as a `limit_cone`
for given `f` and `g`.
-/
@[simps]
def pullback_limit_cone (f : X ⟶ Z) (g : Y ⟶ Z) : limits.limit_cone (cospan f g) :=
{ cone := pullback_cone f g,
  is_limit := pullback_cone.is_limit_aux _
    (λ s x, ⟨⟨s.fst x, s.snd x⟩, congr_fun s.condition x⟩)
    (by tidy)
    (by tidy)
    (λ s m w, funext $ λ x, subtype.ext $
     prod.ext (congr_fun (w walking_cospan.left) x)
              (congr_fun (w walking_cospan.right) x)) }

/--
The pullback cone given by the instance `has_pullbacks (Type u)` is isomorphic to the
explicit pullback cone given by `pullback_limit_cone`.
-/
noncomputable def pullback_cone_iso_pullback : limit.cone (cospan f g) ≅ pullback_cone f g :=
(limit.is_limit _).unique_up_to_iso (pullback_limit_cone f g).is_limit

/--
The pullback given by the instance `has_pullbacks (Type u)` is isomorphic to the
explicit pullback object given by `pullback_limit_obj`.
-/
noncomputable def pullback_iso_pullback : pullback f g ≅ pullback_obj f g :=
(cones.forget _).map_iso $ pullback_cone_iso_pullback f g

@[simp] lemma pullback_iso_pullback_hom_fst (p : pullback f g) :
  ((pullback_iso_pullback f g).hom p : X × Y).fst = (pullback.fst : _ ⟶ X) p :=
congr_fun ((pullback_cone_iso_pullback f g).hom.w left) p

@[simp] lemma pullback_iso_pullback_hom_snd (p : pullback f g) :
  ((pullback_iso_pullback f g).hom p : X × Y).snd = (pullback.snd : _ ⟶ Y) p :=
congr_fun ((pullback_cone_iso_pullback f g).hom.w right) p

@[simp] lemma pullback_iso_pullback_inv_fst :
  (pullback_iso_pullback f g).inv ≫ pullback.fst = (λ p, (p : X × Y).fst) :=
(pullback_cone_iso_pullback f g).inv.w left

@[simp] lemma pullback_iso_pullback_inv_snd :
  (pullback_iso_pullback f g).inv ≫ pullback.snd = (λ p, (p : X × Y).snd) :=
(pullback_cone_iso_pullback f g).inv.w right

end pullback

end category_theory.limits.types


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import tactic.core

/-!
# The `alias` command

This file defines an `alias` command, which can be used to create copies
of a theorem or definition with different names.

Syntax:

```lean
/-- doc string -/
alias my_theorem ← alias1 alias2 ...
```

This produces defs or theorems of the form:

```lean
/-- doc string -/
@[alias] theorem alias1 : <type of my_theorem> := my_theorem

/-- doc string -/
@[alias] theorem alias2 : <type of my_theorem> := my_theorem
```

Iff alias syntax:

```lean
alias A_iff_B ↔ B_of_A A_of_B
alias A_iff_B ↔ ..
```

This gets an existing biconditional theorem `A_iff_B` and produces
the one-way implications `B_of_A` and `A_of_B` (with no change in
implicit arguments). A blank `_` can be used to avoid generating one direction.
The `..` notation attempts to generate the 'of'-names automatically when the
input theorem has the form `A_iff_B` or `A_iff_B_left` etc.
-/

open lean.parser tactic interactive

namespace tactic.alias

/-- An alias can be in one of three forms -/
@[derive has_reflect]
meta inductive target
| plain : name → target
| forward : name → target
| backwards : name → target

/-- The name underlying an alias target -/
meta def target.to_name : target → name
| (target.plain n) := n
| (target.forward n) := n
| (target.backwards n) := n

/-- The docstring for an alias. Used by `alias` _and_ by `to_additive` -/
meta def target.to_string : target → string
| (target.plain n) := sformat!"**Alias** of `{n}`."
| (target.forward n) := sformat!"**Alias** of the forward direction of `{n}`."
| (target.backwards n) := sformat!"**Alias** of the reverse direction of `{n}`."

/-- An auxiliary attribute which is placed on definitions created by the `alias` command. -/
@[user_attribute] meta def alias_attr : user_attribute unit target :=
{ name := `alias, descr := "This definition is an alias of another.", parser := failed }

/-- The core tactic which handles `alias d ← al`. Creates an alias `al` for declaration `d`. -/
meta def alias_direct (doc : option string) (d : declaration) (al : name) : tactic unit :=
do updateex_env $ λ env,
  env.add (match d.to_definition with
  | declaration.defn n ls t _ _ _ :=
    declaration.defn al ls t (expr.const n (level.param <$> ls))
      reducibility_hints.abbrev tt
  | declaration.thm n ls t _ :=
    declaration.thm al ls t $ task.pure $ expr.const n (level.param <$> ls)
  | _ := undefined
  end),
  let target := target.plain d.to_name,
  alias_attr.set al target tt,
  add_doc_string al (doc.get_or_else target.to_string)

/-- Given a proof of `Π x y z, a ↔ b`, produces a proof of `Π x y z, a → b` or `Π x y z, b → a`
(depending on whether `iffmp` is `iff.mp` or `iff.mpr`). The variable `f` supplies the proof,
under the specified number of binders. -/
meta def mk_iff_mp_app (iffmp : name) : expr → (ℕ → expr) → tactic expr
| (expr.pi n bi e t) f := expr.lam n bi e <$> mk_iff_mp_app t (λ n, f (n+1) (expr.var n))
| `(%%a ↔ %%b) f := pure $ @expr.const tt iffmp [] a b (f 0)
| _ f := fail "Target theorem must have the form `Π x y z, a ↔ b`"

/-- The core tactic which handles `alias d ↔ al _` or `alias d ↔ _ al`. `ns` is the current
namespace, and `is_forward` is true if this is the forward implication (the first form). -/
meta def alias_iff (doc : option string)
  (d : declaration) (ns al : name) (is_forward : bool) : tactic unit :=
if al = `_ then skip else
  let al := ns.append_namespace al in
  (get_decl al >> skip) <|> do
    let ls := d.univ_params,
    let t := d.type,
    let target := if is_forward then target.forward d.to_name else target.backwards d.to_name,
    let iffmp := if is_forward then `iff.mp else `iff.mpr,
    v ← mk_iff_mp_app iffmp t (λ_, expr.const d.to_name (level.param <$> ls)),
    t' ← infer_type v,
    updateex_env $ λ env, env.add (declaration.thm al ls t' $ task.pure v),
    alias_attr.set al target tt,
    add_doc_string al (doc.get_or_else target.to_string)

/-- Get the default names for left/right to be used by `alias d ↔ ..`. -/
meta def make_left_right : name → tactic (name × name)
| (name.mk_string s p) := do
  let buf : char_buffer := s.to_char_buffer,
  let parts := s.split_on '_',
  (left, _::right) ← pure $ parts.span (≠ "iff"),
  let pfx (a b : string) := a.to_list.is_prefix_of b.to_list,
  (suffix', right') ← pure $ right.reverse.span (λ s, pfx "left" s ∨ pfx "right" s),
  let right := right'.reverse,
  let suffix := suffix'.reverse,
  pure (p <.> "_".intercalate (right ++ "of" :: left ++ suffix),
        p <.> "_".intercalate (left ++ "of" :: right ++ suffix))
| _ := failed

/--
The `alias` command can be used to create copies
of a theorem or definition with different names.

Syntax:

```lean
/-- doc string -/
alias my_theorem ← alias1 alias2 ...
```

This produces defs or theorems of the form:

```lean
/-- doc string -/
@[alias] theorem alias1 : <type of my_theorem> := my_theorem

/-- doc string -/
@[alias] theorem alias2 : <type of my_theorem> := my_theorem
```

Iff alias syntax:

```lean
alias A_iff_B ↔ B_of_A A_of_B
alias A_iff_B ↔ ..
```

This gets an existing biconditional theorem `A_iff_B` and produces
the one-way implications `B_of_A` and `A_of_B` (with no change in
implicit arguments). A blank `_` can be used to avoid generating one direction.
The `..` notation attempts to generate the 'of'-names automatically when the
input theorem has the form `A_iff_B` or `A_iff_B_left` etc.
-/
@[user_command] meta def alias_cmd (meta_info : decl_meta_info)
  (_ : parse $ tk "alias") : lean.parser unit :=
do old ← ident,
  d ← (do old ← resolve_constant old, get_decl old) <|>
    fail ("declaration " ++ to_string old ++ " not found"),
  ns ← get_current_namespace,
  let doc := meta_info.doc_string,
  do
  { tk "←" <|> tk "<-",
    aliases ← many ident,
    ↑(aliases.mmap' $ λ al, alias_direct doc d (ns.append_namespace al)) } <|>
  do
  { tk "↔" <|> tk "<->",
    (left, right) ←
      mcond ((tk ".." >> pure tt) <|> pure ff)
        (make_left_right old <|> fail "invalid name for automatic name generation")
        (prod.mk <$> types.ident_ <*> types.ident_),
    alias_iff doc d ns left tt,
    alias_iff doc d ns right ff }

add_tactic_doc
{ name                     := "alias",
  category                 := doc_category.cmd,
  decl_names               := [`tactic.alias.alias_cmd],
  tags                     := ["renaming"] }

/-- Given a definition, look up the definition that it is an alias of.
Returns `none` if this defintion is not an alias. -/
meta def get_alias_target (n : name) : tactic (option target) :=
do tt ← has_attribute' `alias n | pure none,
   v ← alias_attr.get_param n,
   pure $ some v

end tactic.alias


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Sebastian Ullrich
-/
prelude
import Init.Core

universe u v w

@[reducible]
def Functor.mapRev {f : Type u → Type v} [Functor f] {α β : Type u} : f α → (α → β) → f β :=
  fun a f => f <$> a

infixr:100 " <&> " => Functor.mapRev

@[always_inline, inline]
def Functor.discard {f : Type u → Type v} {α : Type u} [Functor f] (x : f α) : f PUnit :=
  Functor.mapConst PUnit.unit x

export Functor (discard)

class Alternative (f : Type u → Type v) extends Applicative f : Type (max (u+1) v) where
  failure : {α : Type u} → f α
  orElse  : {α : Type u} → f α → (Unit → f α) → f α

instance (f : Type u → Type v) (α : Type u) [Alternative f] : OrElse (f α) := ⟨Alternative.orElse⟩

variable {f : Type u → Type v} [Alternative f] {α : Type u}

export Alternative (failure)

@[always_inline, inline] def guard {f : Type → Type v} [Alternative f] (p : Prop) [Decidable p] : f Unit :=
  if p then pure () else failure

@[always_inline, inline] def optional (x : f α) : f (Option α) :=
  some <$> x <|> pure none

class ToBool (α : Type u) where
  toBool : α → Bool

export ToBool (toBool)

instance : ToBool Bool where
  toBool b := b

@[macro_inline] def bool {β : Type u} {α : Type v} [ToBool β] (f t : α) (b : β) : α :=
  match toBool b with
  | true  => t
  | false => f

@[macro_inline] def orM {m : Type u → Type v} {β : Type u} [Monad m] [ToBool β] (x y : m β) : m β := do
  let b ← x
  match toBool b with
  | true  => pure b
  | false => y

infixr:30 " <||> " => orM

@[macro_inline] def andM {m : Type u → Type v} {β : Type u} [Monad m] [ToBool β] (x y : m β) : m β := do
  let b ← x
  match toBool b with
  | true  => y
  | false => pure b

infixr:35 " <&&> " => andM

@[macro_inline] def notM {m : Type → Type v} [Applicative m] (x : m Bool) : m Bool :=
  not <$> x

/-!
# How `MonadControl` works

There is a [tutorial by Alexis King](https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/) that this docstring is based on.

Suppose we have `foo : ∀ α, IO α → IO α` and `bar : StateT σ IO β` (ie, `bar : σ → IO (σ × β)`).
We might want to 'map' `bar` by `foo`. Concretely we would write this as:

```lean
opaque foo : ∀ {α}, IO α → IO α
opaque bar : StateT σ IO β

def mapped_foo : StateT σ IO β := do
  let s ← get
  let (b, s') ← liftM <| foo <| StateT.run bar s
  set s'
  return b
```

This is fine but it's not going to generalise, what if we replace `StateT Nat IO` with a large tower of monad transformers?
We would have to rewrite the above to handle each of the `run` functions for each transformer in the stack.

Is there a way to generalise `run` as a kind of inverse of `lift`?
We have `lift : m α → StateT σ m α` for all `m`, but we also need to 'unlift' the state.
But `unlift : StateT σ IO α → IO α` can't be implemented. So we need something else.

If we look at the definition of `mapped_foo`, we see that `lift <| foo <| StateT.run bar s`
has the type `IO (σ × β)`. The key idea is that `σ × β` contains all of the information needed to reconstruct the state and the new value.

Now lets define some values to generalise `mapped_foo`:
- Write `IO (σ × β)` as `IO (stM β)`
- Write `StateT.run . s` as `mapInBase : StateT σ IO α → IO (stM β)`
- Define `restoreM : IO (stM α) → StateT σ IO α` as below

```lean
def stM (α : Type) := α × σ

def restoreM (x : IO (stM α)) : StateT σ IO α := do
  let (a,s) ← liftM x
  set s
  return a
```

To get:

```lean
def mapped_foo' : StateT σ IO β := do
  let s ← get
  let mapInBase := fun z => StateT.run z s
  restoreM <| foo <| mapInBase bar
```

and finally define

```lean
def control {α : Type}
  (f : ({β : Type} → StateT σ IO β → IO (stM β)) → IO (stM α))
  : StateT σ IO α := do
  let s ← get
  let mapInBase := fun {β} (z : StateT σ IO β) => StateT.run z s
  let r : IO (stM α) := f mapInBase
  restoreM r
```

Now we can write `mapped_foo` as:

```lean
def mapped_foo'' : StateT σ IO β :=
  control (fun mapInBase => foo (mapInBase bar))
```

The core idea of `mapInBase` is that given any `β`, it runs an instance of
`StateT σ IO β` and 'packages' the result and state as  `IO (stM β)` so that it can be piped through `foo`.
Once it's been through `foo` we can then unpack the state again with `restoreM`.
Hence we can apply `foo` to `bar` without losing track of the state.

Here `stM β = σ × β` is the 'packaged result state', but we can generalise:
if we have a tower `StateT σ₁ <| StateT σ₂ <| IO`, then the
composite packaged state is going to be `stM₁₂ β := σ₁ × σ₂ × β` or `stM₁₂ := stM₁ ∘ stM₂`.

`MonadControl m n` means that when programming in the monad `n`,
we can switch to a base monad `m` using `control`, just like with `liftM`.
In contrast to `liftM`, however, we also get a function `runInBase` that
allows us to "lower" actions in `n` into `m`.
This is really useful when we have large towers of monad transformers, as we do in the metaprogramming library.

For example there is a function `withNewMCtxDepthImp : MetaM α → MetaM α` that runs the input monad instance
in a new nested metavariable context. We can lift this to `withNewMctxDepth : n α → n α` using `MonadControlT MetaM n`
(`MonadControlT` is the transitive closure of `MonadControl`).
Which means that we can also run `withNewMctxDepth` in the `Tactic` monad without needing to
faff around with lifts and all the other boilerplate needed in `mapped_foo`.

## Relationship to `MonadFunctor`

A stricter form of `MonadControl` is `MonadFunctor`, which defines
`monadMap {α} : (∀ {β}, m β → m β) → n α → n α`. Using `monadMap` it is also possible to define `mapped_foo` above.
However there are some mappings which can't be derived using `MonadFunctor`. For example:

```lean,ignore
 @[inline] def map1MetaM [MonadControlT MetaM n] [Monad n] (f : forall {α}, (β → MetaM α) → MetaM α) {α} (k : β → n α) : n α :=
   control fun runInBase => f fun b => runInBase <| k b

 @[inline] def map2MetaM [MonadControlT MetaM n] [Monad n] (f : forall {α}, (β → γ → MetaM α) → MetaM α) {α} (k : β → γ → n α) : n α :=
   control fun runInBase => f fun b c => runInBase <| k b c
```

In `monadMap`, we can only 'run in base' a single computation in `n` into the base monad `m`.
Using `control` means that `runInBase` can be used multiple times.

-/

/-- MonadControl is a way of stating that the monad `m` can be 'run inside' the monad `n`.

This is the same as [`MonadBaseControl`](https://hackage.haskell.org/package/monad-control-1.0.3.1/docs/Control-Monad-Trans-Control.html#t:MonadBaseControl) in Haskell.
To learn about `MonadControl`, see the comment above this docstring.

-/
class MonadControl (m : Type u → Type v) (n : Type u → Type w) where
  stM      : Type u → Type u
  liftWith : {α : Type u} → (({β : Type u} → n β → m (stM β)) → m α) → n α
  restoreM : {α : Type u} → m (stM α) → n α

/-- Transitive closure of MonadControl. -/
class MonadControlT (m : Type u → Type v) (n : Type u → Type w) where
  stM      : Type u → Type u
  liftWith : {α : Type u} → (({β : Type u} → n β → m (stM β)) → m α) → n α
  restoreM {α : Type u} : stM α → n α

export MonadControlT (stM liftWith restoreM)

@[always_inline]
instance (m n o) [MonadControl n o] [MonadControlT m n] : MonadControlT m o where
  stM α := stM m n (MonadControl.stM n o α)
  liftWith f := MonadControl.liftWith fun x₂ => liftWith fun x₁ => f (x₁ ∘ x₂)
  restoreM := MonadControl.restoreM ∘ restoreM

instance (m : Type u → Type v) [Pure m] : MonadControlT m m where
  stM α := α
  liftWith f := f fun x => x
  restoreM x := pure x

@[always_inline, inline]
def controlAt (m : Type u → Type v) {n : Type u → Type w} [MonadControlT m n] [Bind n] {α : Type u}
    (f : ({β : Type u} → n β → m (stM m n β)) → m (stM m n α)) : n α :=
  liftWith f >>= restoreM

@[always_inline, inline]
def control {m : Type u → Type v} {n : Type u → Type w} [MonadControlT m n] [Bind n] {α : Type u}
    (f : ({β : Type u} → n β → m (stM m n β)) → m (stM m n α)) : n α :=
  controlAt m f

/--
  Typeclass for the polymorphic `forM` operation described in the "do unchained" paper.
  Remark:
  - `γ` is a "container" type of elements of type `α`.
  - `α` is treated as an output parameter by the typeclass resolution procedure.
    That is, it tries to find an instance using only `m` and `γ`.
-/
class ForM (m : Type u → Type v) (γ : Type w₁) (α : outParam (Type w₂)) where
  forM [Monad m] : γ → (α → m PUnit) → m PUnit

export ForM (forM)

/-- Left-to-right composition of Kleisli arrows. -/
@[always_inline]
def Bind.kleisliRight [Bind m] (f₁ : α → m β) (f₂ : β → m γ) (a : α) : m γ :=
  f₁ a >>= f₂

/-- Right-to-left composition of Kleisli arrows. -/
@[always_inline]
def Bind.kleisliLeft [Bind m] (f₂ : β → m γ) (f₁ : α → m β) (a : α) : m γ :=
  f₁ a >>= f₂

/-- Same as `Bind.bind` but with arguments swapped. -/
@[always_inline]
def Bind.bindLeft [Bind m] (f : α → m β) (ma : m α) : m β :=
  ma >>= f

-- Precedence choice taken to be the same as in haskell:
-- https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Monad.html#v:-61--60--60-
@[inherit_doc] infixr:55 " >=> " => Bind.kleisliRight
@[inherit_doc] infixr:55 " <=< " => Bind.kleisliLeft
@[inherit_doc] infixr:55 " =<< " => Bind.bindLeft


import ProofWidgets.Presentation.Goal

open ProofWidgets Jsx

@[expr_presenter]
def presenter : ExprPresenter where
  userName := "With octopodes"
  layoutKind := .inline
  isApplicable _ := return true
  present e :=
    return Html.ofTHtml
      <span>
        {.text "🐙 "}<InteractiveCode fmt={← Lean.Widget.ppExprTagged e} />{.text " 🐙"}
      </span>

example (h : 2 + 2 = 5) : 2 + 2 = 4 := by
  withSelectionDisplay
  -- Place cursor here and select subexpressions in the goal with shift-click
    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
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.relator
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u

namespace Mathlib

/-!
# Quotient types

This module extends the core library's treatment of quotient types (`init.data.quot`).

## Tags

quotient
-/

namespace setoid

theorem ext {α : Sort u_1} {s : setoid α} {t : setoid α} : (∀ (a b : α), r a b ↔ r a b) → s = t := sorry

end setoid

namespace quot

protected instance inhabited {α : Sort u_1} {ra : α → α → Prop} [Inhabited α] : Inhabited (Quot ra) :=
  { default := Quot.mk ra Inhabited.default }

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ {α : Sort u_1} {β : Sort u_2} {ra : α → α → Prop} {rb : β → β → Prop} {φ : Quot ra → Quot rb → Sort u_3} (qa : Quot ra) (qb : Quot rb) (f : (a : α) → (b : β) → φ (Quot.mk ra a) (Quot.mk rb b)) (ca : ∀ {b : β} {a₁ a₂ : α}, ra a₁ a₂ → f a₁ b == f a₂ b) (cb : ∀ {a : α} {b₁ b₂ : β}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
  quot.hrec_on qa (fun (a : α) => quot.hrec_on qb (f a) sorry) sorry

/-- Map a function `f : α → β` such that `ra x y` implies `rb (f x) (f y)`
to a map `quot ra → quot rb`. -/
protected def map {α : Sort u_1} {β : Sort u_2} {ra : α → α → Prop} {rb : β → β → Prop} (f : α → β) (h : relator.lift_fun ra rb f f) : Quot ra → Quot rb :=
  Quot.lift (fun (x : α) => Quot.mk rb (f x)) sorry

/-- If `ra` is a subrelation of `ra'`, then we have a natural map `quot ra → quot ra'`. -/
protected def map_right {α : Sort u_1} {ra : α → α → Prop} {ra' : α → α → Prop} (h : ∀ (a₁ a₂ : α), ra a₁ a₂ → ra' a₁ a₂) : Quot ra → Quot ra' :=
  quot.map id h

/-- weaken the relation of a quotient -/
def factor {α : Type u_1} (r : α → α → Prop) (s : α → α → Prop) (h : ∀ (x y : α), r x y → s x y) : Quot r → Quot s :=
  Quot.lift (Quot.mk s) sorry

theorem factor_mk_eq {α : Type u_1} (r : α → α → Prop) (s : α → α → Prop) (h : ∀ (x y : α), r x y → s x y) : factor r s h ∘ Quot.mk r = Quot.mk s :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β`. -/
protected def lift₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) (q₁ : Quot r) (q₂ : Quot s) : γ :=
  Quot.lift (fun (a : α) => Quot.lift (f a) (hr a)) sorry q₁ q₂

@[simp] theorem lift₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} (a : α) (b : β) (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) : quot.lift₂ f hr hs (Quot.mk r a) (Quot.mk s b) = f a b :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` and applies it. -/
protected def lift_on₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} (p : Quot r) (q : Quot s) (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) : γ :=
  quot.lift₂ f hr hs p q

@[simp] theorem lift_on₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} (a : α) (b : β) (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → f a b₁ = f a b₂) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → f a₁ b = f a₂ b) : quot.lift_on₂ (Quot.mk r a) (Quot.mk s b) f hr hs = f a b :=
  rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` wih values in a quotient of
`γ`. -/
protected def map₂ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → t (f a b₁) (f a b₂)) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → t (f a₁ b) (f a₂ b)) (q₁ : Quot r) (q₂ : Quot s) : Quot t :=
  quot.lift₂ (fun (a : α) (b : β) => Quot.mk t (f a b)) sorry sorry q₁ q₂

@[simp] theorem map₂_mk {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} (f : α → β → γ) (hr : ∀ (a : α) (b₁ b₂ : β), s b₁ b₂ → t (f a b₁) (f a b₂)) (hs : ∀ (a₁ a₂ : α) (b : β), r a₁ a₂ → t (f a₁ b) (f a₂ b)) (a : α) (b : β) : quot.map₂ f hr hs (Quot.mk r a) (Quot.mk s b) = Quot.mk t (f a b) :=
  rfl

protected theorem induction_on₂ {α : Sort u_1} {β : Sort u_2} {r : α → α → Prop} {s : β → β → Prop} {δ : Quot r → Quot s → Prop} (q₁ : Quot r) (q₂ : Quot s) (h : ∀ (a : α) (b : β), δ (Quot.mk r a) (Quot.mk s b)) : δ q₁ q₂ :=
  Quot.ind (fun (a₁ : α) => Quot.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_1} {β : Sort u_2} {γ : Sort u_4} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop} {δ : Quot r → Quot s → Quot t → Prop} (q₁ : Quot r) (q₂ : Quot s) (q₃ : Quot t) (h : ∀ (a : α) (b : β) (c : γ), δ (Quot.mk r a) (Quot.mk s b) (Quot.mk t c)) : δ q₁ q₂ q₃ :=
  Quot.ind (fun (a₁ : α) => Quot.ind (fun (a₂ : β) => Quot.ind (fun (a₃ : γ) => h a₁ a₂ a₃) q₃) q₂) q₁

end quot

namespace quotient

protected instance inhabited {α : Sort u_1} [sa : setoid α] [Inhabited α] : Inhabited (quotient sa) :=
  { default := quotient.mk Inhabited.default }

/-- Induction on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] {φ : quotient sa → quotient sb → Sort u_3} (qa : quotient sa) (qb : quotient sb) (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b)) (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
  quot.hrec_on₂ qa qb f sorry sorry

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] (f : α → β) (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) : quotient sa → quotient sb :=
  quot.map f h

@[simp] theorem map_mk {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] (f : α → β) (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) (x : α) : quotient.map f h (quotient.mk x) = quotient.mk (f x) :=
  rfl

/-- Map a function `f : α → β → γ` that sends equivalent elements to equivalent elements
to a function `f : quotient sa → quotient sb → quotient sc`.
Useful to define binary operations on quotients. -/
protected def map₂ {α : Sort u_1} {β : Sort u_2} [sa : setoid α] [sb : setoid β] {γ : Sort u_4} [sc : setoid γ] (f : α → β → γ) (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) : quotient sa → quotient sb → quotient sc :=
  quotient.lift₂ (fun (x : α) (y : β) => quotient.mk (f x y)) sorry

end quotient

theorem quot.eq {α : Type u_1} {r : α → α → Prop} {x : α} {y : α} : Quot.mk r x = Quot.mk r y ↔ eqv_gen r x y :=
  { mp := quot.exact r, mpr := quot.eqv_gen_sound }

@[simp] theorem quotient.eq {α : Sort u_1} [r : setoid α] {x : α} {y : α} : quotient.mk x = quotient.mk y ↔ x ≈ y :=
  { mp := quotient.exact, mpr := quotient.sound }

theorem forall_quotient_iff {α : Type u_1} [r : setoid α] {p : quotient r → Prop} : (∀ (a : quotient r), p a) ↔ ∀ (a : α), p (quotient.mk a) :=
  { mp := fun (h : ∀ (a : quotient r), p a) (x : α) => h (quotient.mk x),
    mpr := fun (h : ∀ (a : α), p (quotient.mk a)) (a : quotient r) => quotient.induction_on a h }

@[simp] theorem quotient.lift_beta {α : Sort u_1} {β : Sort u_2} [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α) : quotient.lift f h (quotient.mk x) = f x :=
  rfl

@[simp] theorem quotient.lift_on_beta {α : Sort u_1} {β : Sort u_2} [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α) : quotient.lift_on (quotient.mk x) f h = f x :=
  rfl

@[simp] theorem quotient.lift_on_beta₂ {α : Sort u_1} {β : Sort u_2} [setoid α] (f : α → α → β) (h : ∀ (a₁ a₂ b₁ b₂ : α), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (x : α) (y : α) : quotient.lift_on₂ (quotient.mk x) (quotient.mk y) f h = f x y :=
  rfl

/-- `quot.mk r` is a surjective function. -/
theorem surjective_quot_mk {α : Sort u_1} (r : α → α → Prop) : function.surjective (Quot.mk r) :=
  quot.exists_rep

/-- `quotient.mk` is a surjective function. -/
theorem surjective_quotient_mk (α : Sort u_1) [s : setoid α] : function.surjective quotient.mk :=
  quot.exists_rep

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
def quot.out {α : Sort u_1} {r : α → α → Prop} (q : Quot r) : α :=
  classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
@[simp] theorem quot.out_eq {α : Sort u_1} {r : α → α → Prop} (q : Quot r) : Quot.mk r (quot.out q) = q :=
  classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
def quotient.out {α : Sort u_1} [s : setoid α] : quotient s → α :=
  quot.out

@[simp] theorem quotient.out_eq {α : Sort u_1} [s : setoid α] (q : quotient s) : quotient.mk (quotient.out q) = q :=
  quot.out_eq q

theorem quotient.mk_out {α : Sort u_1} [s : setoid α] (a : α) : quotient.out (quotient.mk a) ≈ a :=
  quotient.exact (quotient.out_eq (quotient.mk a))

protected instance pi_setoid {ι : Sort u_1} {α : ι → Sort u_2} [(i : ι) → setoid (α i)] : setoid ((i : ι) → α i) :=
  setoid.mk (fun (a b : (i : ι) → α i) => ∀ (i : ι), a i ≈ b i) sorry

/-- Given a function `f : Π i, quotient (S i)`, returns the class of functions `Π i, α i` sending
each `i` to an element of the class `f i`. -/
def quotient.choice {ι : Type u_1} {α : ι → Type u_2} [S : (i : ι) → setoid (α i)] (f : (i : ι) → quotient (S i)) : quotient Mathlib.pi_setoid :=
  quotient.mk fun (i : ι) => quotient.out (f i)

theorem quotient.choice_eq {ι : Type u_1} {α : ι → Type u_2} [(i : ι) → setoid (α i)] (f : (i : ι) → α i) : (quotient.choice fun (i : ι) => quotient.mk (f i)) = quotient.mk f :=
  quotient.sound fun (i : ι) => quotient.mk_out (f i)

theorem nonempty_quotient_iff {α : Sort u_1} (s : setoid α) : Nonempty (quotient s) ↔ Nonempty α := sorry

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def trunc (α : Sort u) :=
  Quot fun (_x _x : α) => True

theorem true_equivalence {α : Sort u_1} : equivalence fun (_x _x : α) => True :=
  { left := fun (_x : α) => trivial,
    right := { left := fun (_x _x : α) (_x : True) => trivial, right := fun (_x _x _x : α) (_x _x : True) => trivial } }

namespace trunc

/-- Constructor for `trunc α` -/
def mk {α : Sort u_1} (a : α) : trunc α :=
  Quot.mk (fun (_x _x : α) => True) a

protected instance inhabited {α : Sort u_1} [Inhabited α] : Inhabited (trunc α) :=
  { default := mk Inhabited.default }

/-- Any constant function lifts to a function out of the truncation -/
def lift {α : Sort u_1} {β : Sort u_2} (f : α → β) (c : ∀ (a b : α), f a = f b) : trunc α → β :=
  Quot.lift f sorry

theorem ind {α : Sort u_1} {β : trunc α → Prop} : (∀ (a : α), β (mk a)) → ∀ (q : trunc α), β q :=
  Quot.ind

protected theorem lift_beta {α : Sort u_1} {β : Sort u_2} (f : α → β) (c : ∀ (a b : α), f a = f b) (a : α) : lift f c (mk a) = f a :=
  rfl

/-- Lift a constant function on `q : trunc α`. -/
protected def lift_on {α : Sort u_1} {β : Sort u_2} (q : trunc α) (f : α → β) (c : ∀ (a b : α), f a = f b) : β :=
  lift f c q

protected theorem induction_on {α : Sort u_1} {β : trunc α → Prop} (q : trunc α) (h : ∀ (a : α), β (mk a)) : β q :=
  ind h q

theorem exists_rep {α : Sort u_1} (q : trunc α) : ∃ (a : α), mk a = q :=
  quot.exists_rep q

protected theorem induction_on₂ {α : Sort u_1} {β : Sort u_2} {C : trunc α → trunc β → Prop} (q₁ : trunc α) (q₂ : trunc β) (h : ∀ (a : α) (b : β), C (mk a) (mk b)) : C q₁ q₂ :=
  trunc.induction_on q₁ fun (a₁ : α) => trunc.induction_on q₂ (h a₁)

protected theorem eq {α : Sort u_1} (a : trunc α) (b : trunc α) : a = b :=
  trunc.induction_on₂ a b fun (x y : α) => quot.sound trivial

protected instance subsingleton {α : Sort u_1} : subsingleton (trunc α) :=
  subsingleton.intro trunc.eq

/-- The `bind` operator for the `trunc` monad. -/
def bind {α : Sort u_1} {β : Sort u_2} (q : trunc α) (f : α → trunc β) : trunc β :=
  trunc.lift_on q f sorry

/-- A function `f : α → β` defines a function `map f : trunc α → trunc β`. -/
def map {α : Sort u_1} {β : Sort u_2} (f : α → β) (q : trunc α) : trunc β :=
  bind q (mk ∘ f)

protected instance monad : Monad trunc := sorry

protected instance is_lawful_monad : is_lawful_monad trunc :=
  is_lawful_monad.mk (fun (α β : Type u_1) (q : α) (f : α → trunc β) => rfl)
    fun (α β γ : Type u_1) (x : trunc α) (f : α → trunc β) (g : β → trunc γ) =>
      trunc.eq (x >>= f >>= g) (x >>= fun (x : α) => f x >>= g)

/-- Recursion/induction principle for `trunc`. -/
protected def rec {α : Sort u_1} {C : trunc α → Sort u_3} (f : (a : α) → C (mk a)) (h : ∀ (a b : α), Eq._oldrec (f a) (rec._proof_1 a b) = f b) (q : trunc α) : C q :=
  quot.rec f sorry q

/-- A version of `trunc.rec` taking `q : trunc α` as the first argument. -/
protected def rec_on {α : Sort u_1} {C : trunc α → Sort u_3} (q : trunc α) (f : (a : α) → C (mk a)) (h : ∀ (a b : α), Eq._oldrec (f a) (rec_on._proof_1 a b) = f b) : C q :=
  trunc.rec f h q

/-- A version of `trunc.rec_on` assuming the codomain is a `subsingleton`. -/
protected def rec_on_subsingleton {α : Sort u_1} {C : trunc α → Sort u_3} [∀ (a : α), subsingleton (C (mk a))] (q : trunc α) (f : (a : α) → C (mk a)) : C q :=
  trunc.rec f sorry q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
def out {α : Sort u_1} : trunc α → α :=
  quot.out

@[simp] theorem out_eq {α : Sort u_1} (q : trunc α) : mk (out q) = q :=
  trunc.eq (mk (out q)) q

end trunc

theorem nonempty_of_trunc {α : Sort u_1} (q : trunc α) : Nonempty α :=
  (fun (_a : ∃ (a : α), trunc.mk a = q) =>
      Exists.dcases_on _a fun (w : α) (h : trunc.mk w = q) => idRhs (Nonempty α) (Nonempty.intro w))
    (trunc.exists_rep q)

namespace quotient

/- Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules -/

/-- A version of `quotient.mk` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def mk' {α : Sort u_1} {s₁ : setoid α} (a : α) : quotient s₁ :=
  Quot.mk setoid.r a

/-- `quotient.mk'` is a surjective function. -/
theorem surjective_quotient_mk' {α : Sort u_1} {s₁ : setoid α} : function.surjective quotient.mk' :=
  quot.exists_rep

/-- A version of `quotient.lift_on` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def lift_on' {α : Sort u_1} {φ : Sort u_4} {s₁ : setoid α} (q : quotient s₁) (f : α → φ) (h : ∀ (a b : α), setoid.r a b → f a = f b) : φ :=
  quotient.lift_on q f h

@[simp] protected theorem lift_on'_beta {α : Sort u_1} {φ : Sort u_4} {s₁ : setoid α} (f : α → φ) (h : ∀ (a b : α), setoid.r a b → f a = f b) (x : α) : quotient.lift_on' (quotient.mk' x) f h = f x :=
  rfl

/-- A version of `quotient.lift_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
protected def lift_on₂' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β} (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ) (h : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), setoid.r a₁ b₁ → setoid.r a₂ b₂ → f a₁ a₂ = f b₁ b₂) : γ :=
  quotient.lift_on₂ q₁ q₂ f h

@[simp] protected theorem lift_on₂'_beta {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β} (f : α → β → γ) (h : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), setoid.r a₁ b₁ → setoid.r a₂ b₂ → f a₁ a₂ = f b₁ b₂) (a : α) (b : β) : quotient.lift_on₂' (quotient.mk' a) (quotient.mk' b) f h = f a b :=
  rfl

/-- A version of `quotient.ind` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected theorem ind' {α : Sort u_1} {s₁ : setoid α} {p : quotient s₁ → Prop} (h : ∀ (a : α), p (quotient.mk' a)) (q : quotient s₁) : p q :=
  quotient.ind h q

/-- A version of `quotient.ind₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
protected theorem ind₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} {p : quotient s₁ → quotient s₂ → Prop} (h : ∀ (a₁ : α) (a₂ : β), p (quotient.mk' a₁) (quotient.mk' a₂)) (q₁ : quotient s₁) (q₂ : quotient s₂) : p q₁ q₂ :=
  quotient.ind₂ h q₁ q₂

/-- A version of `quotient.induction_on` taking `{s : setoid α}` as an implicit argument instead
of an instance argument. -/
protected theorem induction_on' {α : Sort u_1} {s₁ : setoid α} {p : quotient s₁ → Prop} (q : quotient s₁) (h : ∀ (a : α), p (quotient.mk' a)) : p q :=
  quotient.induction_on q h

/-- A version of `quotient.induction_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit
arguments instead of instance arguments. -/
protected theorem induction_on₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (h : ∀ (a₁ : α) (a₂ : β), p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
  quotient.induction_on₂ q₁ q₂ h

/-- A version of `quotient.induction_on₃` taking `{s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}`
as implicit arguments instead of instance arguments. -/
protected theorem induction_on₃' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ} {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) (h : ∀ (a₁ : α) (a₂ : β) (a₃ : γ), p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) : p q₁ q₂ q₃ :=
  quotient.induction_on₃ q₁ q₂ q₃ h

/-- Recursion on a `quotient` argument `a`, result type depends on `⟦a⟧`. -/
protected def hrec_on' {α : Sort u_1} {s₁ : setoid α} {φ : quotient s₁ → Sort u_2} (qa : quotient s₁) (f : (a : α) → φ (quotient.mk' a)) (c : ∀ (a₁ a₂ : α), a₁ ≈ a₂ → f a₁ == f a₂) : φ qa :=
  quot.hrec_on qa f c

@[simp] theorem hrec_on'_mk' {α : Sort u_1} {s₁ : setoid α} {φ : quotient s₁ → Sort u_2} (f : (a : α) → φ (quotient.mk' a)) (c : ∀ (a₁ a₂ : α), a₁ ≈ a₂ → f a₁ == f a₂) (x : α) : quotient.hrec_on' (quotient.mk' x) f c = f x :=
  rfl

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} {φ : quotient s₁ → quotient s₂ → Sort u_3} (qa : quotient s₁) (qb : quotient s₂) (f : (a : α) → (b : β) → φ (quotient.mk' a) (quotient.mk' b)) (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
  quotient.hrec_on₂ qa qb f c

@[simp] theorem hrec_on₂'_mk' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} {φ : quotient s₁ → quotient s₂ → Sort u_3} (f : (a : α) → (b : β) → φ (quotient.mk' a) (quotient.mk' b)) (c : ∀ (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β), a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) (x : α) (qb : quotient s₂) : quotient.hrec_on₂' (quotient.mk' x) qb f c = quotient.hrec_on' qb (f x) fun (b₁ b₂ : β) => c x b₁ x b₂ (setoid.refl x) :=
  rfl

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} (f : α → β) (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) : quotient s₁ → quotient s₂ :=
  quot.map f h

@[simp] theorem map'_mk' {α : Sort u_1} {β : Sort u_2} {s₁ : setoid α} {s₂ : setoid β} (f : α → β) (h : relator.lift_fun has_equiv.equiv has_equiv.equiv f f) (x : α) : quotient.map' f h (quotient.mk' x) = quotient.mk' (f x) :=
  rfl

/-- A version of `quotient.map₂` using curly braces and unification. -/
protected def map₂' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ} (f : α → β → γ) (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) : quotient s₁ → quotient s₂ → quotient s₃ :=
  quotient.map₂ f h

@[simp] theorem map₂'_mk' {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ} (f : α → β → γ) (h : relator.lift_fun has_equiv.equiv (has_equiv.equiv ⇒ has_equiv.equiv) f f) (x : α) : quotient.map₂' f h (quotient.mk' x) = quotient.map' (f x) (h (setoid.refl x)) :=
  rfl

theorem exact' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} : quotient.mk' a = quotient.mk' b → setoid.r a b :=
  exact

theorem sound' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} : setoid.r a b → quotient.mk' a = quotient.mk' b :=
  sound

@[simp] protected theorem eq' {α : Sort u_1} {s₁ : setoid α} {a : α} {b : α} : quotient.mk' a = quotient.mk' b ↔ setoid.r a b :=
  eq

/-- A version of `quotient.out` taking `{s₁ : setoid α}` as an implicit argument instead of an
instance argument. -/
def out' {α : Sort u_1} {s₁ : setoid α} (a : quotient s₁) : α :=
  out a

@[simp] theorem out_eq' {α : Sort u_1} {s₁ : setoid α} (q : quotient s₁) : quotient.mk' (out' q) = q :=
  out_eq q

theorem mk_out' {α : Sort u_1} {s₁ : setoid α} (a : α) : setoid.r (out' (quotient.mk' a)) a :=
  exact (out_eq (quotient.mk' a))


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

! This file was ported from Lean 3 source module data.fun_like.embedding
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.FunLike.Basic

/-!
# 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 embeddings such as `rel_embedding`.

## Basic usage of `embedding_like`

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

namespace my_embedding

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

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

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

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

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

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

end my_embedding
```

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

## Embedding classes extending `embedding_like`

The `embedding_like` design provides further benefits if you put in a bit more work.
The first step is to extend `embedding_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_embedding_class F A B` states that `F` is a type of `my_class.op`-preserving embeddings.
You should extend this class when you extend `my_embedding`. -/
class my_embedding_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends embedding_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_embedding_class F A B]
  (f : F) (x y : A) : f (my_class.op x y) = my_class.op (f x) (f y) :=
my_embedding_class.map_op

-- You can replace `my_embedding.embedding_like` with the below instance:
instance : my_embedding_class (my_embedding A B) A B :=
{ coe := my_embedding.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := my_embedding.injective',
  map_op := my_embedding.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_embedding_class` for all types extending
`my_embedding`.
Typically, you can just declare a new class analogous to `my_embedding_class`:

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

section
set_option old_structure_cmd true

class cooler_embedding_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_embedding_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_embedding_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_embedding_class.map_op

-- You can also replace `my_embedding.embedding_like` with the below instance:
instance : cool_embedding_class (cool_embedding A B) A B :=
{ coe := cool_embedding.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := my_embedding.injective',
  map_op := cool_embedding.map_op',
  map_cool := cool_embedding.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_embedding A B) : sorry := sorry
lemma do_something {F : Type*} [my_embedding_class F A B] (f : F) : sorry := sorry
```

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

-/

/- warning: embedding_like -> EmbeddingLike is a dubious translation:
lean 3 declaration is
  Sort.{u1} -> (outParam.{succ u2} Sort.{u2}) -> (outParam.{succ u3} Sort.{u3}) -> Sort.{max 1 (imax u1 u2 u3)}
but is expected to have type
  Sort.{u1} -> (outParam.{succ u2} Sort.{u2}) -> (outParam.{succ u3} Sort.{u3}) -> Sort.{max (max (max 1 u1) u2) u3}
Case conversion may be inaccurate. Consider using '#align embedding_like EmbeddingLikeₓ'. -/
/-- The class `embedding_like F α β` expresses that terms of type `F` have an
injective coercion to injective functions `α ↪ β`.
-/
class EmbeddingLike (F : Sort _) (α β : outParam (Sort _)) extends FunLike F α fun _ => β where
  injective' : ∀ f : F, @Function.Injective α β (coe f)
#align embedding_like EmbeddingLike

namespace EmbeddingLike

variable {F α β γ : Sort _} [i : EmbeddingLike F α β]

include i

/- warning: embedding_like.injective -> EmbeddingLike.injective is a dubious translation:
lean 3 declaration is
  forall {F : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [i : EmbeddingLike.{u1, u2, u3} F α β] (f : F), Function.Injective.{u2, u3} α β (coeFn.{u1, imax u2 u3} F (fun (_x : F) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} F α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} F α β i)) f)
but is expected to have type
  forall {F : Sort.{u1}} {α : Sort.{u3}} {β : Sort.{u2}} [i : EmbeddingLike.{u1, u3, u2} F α β] (f : F), Function.Injective.{u3, u2} α β (FunLike.coe.{u1, u3, u2} F α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u1, u3, u2} F α β i) f)
Case conversion may be inaccurate. Consider using '#align embedding_like.injective EmbeddingLike.injectiveₓ'. -/
protected theorem injective (f : F) : Function.Injective f :=
  injective' f
#align embedding_like.injective EmbeddingLike.injective

/- warning: embedding_like.apply_eq_iff_eq -> EmbeddingLike.apply_eq_iff_eq is a dubious translation:
lean 3 declaration is
  forall {F : Sort.{u1}} {α : Sort.{u2}} {β : Sort.{u3}} [i : EmbeddingLike.{u1, u2, u3} F α β] (f : F) {x : α} {y : α}, Iff (Eq.{u3} β (coeFn.{u1, imax u2 u3} F (fun (_x : F) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} F α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} F α β i)) f x) (coeFn.{u1, imax u2 u3} F (fun (_x : F) => α -> β) (FunLike.hasCoeToFun.{u1, u2, u3} F α (fun (_x : α) => β) (EmbeddingLike.toFunLike.{u1, u2, u3} F α β i)) f y)) (Eq.{u2} α x y)
but is expected to have type
  forall {F : Sort.{u2}} {α : Sort.{u1}} {β : Sort.{u3}} [i : EmbeddingLike.{u2, u1, u3} F α β] (f : F) {x : α} {y : α}, Iff (Eq.{u3} ((fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) x) (FunLike.coe.{u2, u1, u3} F α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u1, u3} F α β i) f x) (FunLike.coe.{u2, u1, u3} F α (fun (_x : α) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : α) => β) _x) (EmbeddingLike.toFunLike.{u2, u1, u3} F α β i) f y)) (Eq.{u1} α x y)
Case conversion may be inaccurate. Consider using '#align embedding_like.apply_eq_iff_eq EmbeddingLike.apply_eq_iff_eqₓ'. -/
@[simp]
theorem apply_eq_iff_eq (f : F) {x y : α} : f x = f y ↔ x = y :=
  (EmbeddingLike.injective f).eq_iff
#align embedding_like.apply_eq_iff_eq EmbeddingLike.apply_eq_iff_eq

omit i

/- warning: embedding_like.comp_injective -> EmbeddingLike.comp_injective is a dubious translation:
lean 3 declaration is
  forall {α : Sort.{u1}} {β : Sort.{u2}} {γ : Sort.{u3}} {F : Sort.{u4}} [_inst_1 : EmbeddingLike.{u4, u2, u3} F β γ] (f : α -> β) (e : F), Iff (Function.Injective.{u1, u3} α γ (Function.comp.{u1, u2, u3} α β γ (coeFn.{u4, imax u2 u3} F (fun (_x : F) => β -> γ) (FunLike.hasCoeToFun.{u4, u2, u3} F β (fun (_x : β) => γ) (EmbeddingLike.toFunLike.{u4, u2, u3} F β γ _inst_1)) e) f)) (Function.Injective.{u1, u2} α β f)
but is expected to have type
  forall {α : Sort.{u1}} {β : Sort.{u3}} {γ : Sort.{u2}} {F : Sort.{u4}} [_inst_1 : EmbeddingLike.{u4, u3, u2} F β γ] (f : α -> β) (e : F), Iff (Function.Injective.{u1, u2} α γ (Function.comp.{u1, u3, u2} α β γ (FunLike.coe.{u4, u3, u2} F β (fun (_x : β) => (fun (x._@.Mathlib.Data.FunLike.Embedding._hyg.19 : β) => γ) _x) (EmbeddingLike.toFunLike.{u4, u3, u2} F β γ _inst_1) e) f)) (Function.Injective.{u1, u3} α β f)
Case conversion may be inaccurate. Consider using '#align embedding_like.comp_injective EmbeddingLike.comp_injectiveₓ'. -/
@[simp]
theorem comp_injective {F : Sort _} [EmbeddingLike F β γ] (f : α → β) (e : F) :
    Function.Injective (e ∘ f) ↔ Function.Injective f :=
  (EmbeddingLike.injective e).of_comp_iff f
#align embedding_like.comp_injective EmbeddingLike.comp_injective

end EmbeddingLike


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau
-/
import data.list.basic

universes u v w z

variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type z}

open nat

namespace list

/- zip & unzip -/

@[simp] theorem zip_with_cons_cons (f : α → β → γ) (a : α) (b : β) (l₁ : list α) (l₂ : list β) :
  zip_with f (a :: l₁) (b :: l₂) = f a b :: zip_with f l₁ l₂ := rfl

@[simp] theorem zip_cons_cons (a : α) (b : β) (l₁ : list α) (l₂ : list β) :
  zip (a :: l₁) (b :: l₂) = (a, b) :: zip l₁ l₂ := rfl

@[simp] theorem zip_with_nil_left (f : α → β → γ) (l) : zip_with f [] l = [] := rfl

@[simp] theorem zip_with_nil_right (f : α → β → γ) (l)  : zip_with f l [] = [] :=
by cases l; refl

@[simp] lemma zip_with_eq_nil_iff {f : α → β → γ} {l l'} :
  zip_with f l l' = [] ↔ l = [] ∨ l' = [] :=
by { cases l; cases l'; simp }

@[simp] theorem zip_nil_left (l : list α) : zip ([] : list β) l = [] := rfl

@[simp] theorem zip_nil_right (l : list α) : zip l ([] : list β) = [] :=
zip_with_nil_right _ l

@[simp] theorem zip_swap : ∀ (l₁ : list α) (l₂ : list β),
  (zip l₁ l₂).map prod.swap = zip l₂ l₁
| []      l₂      := (zip_nil_right _).symm
| l₁      []      := by rw zip_nil_right; refl
| (a::l₁) (b::l₂) := by simp only [zip_cons_cons, map_cons, zip_swap l₁ l₂, prod.swap_prod_mk];
    split; refl

@[simp] theorem length_zip_with (f : α → β → γ) : ∀  (l₁ : list α) (l₂ : list β),
   length (zip_with f l₁ l₂) = min (length l₁) (length l₂)
| []      l₂      := rfl
| l₁      []      := by simp only [length, min_zero, zip_with_nil_right]
| (a::l₁) (b::l₂) := by by simp [length, zip_cons_cons, length_zip_with l₁ l₂, min_add_add_right]

@[simp] theorem length_zip : ∀ (l₁ : list α) (l₂ : list β),
   length (zip l₁ l₂) = min (length l₁) (length l₂) :=
length_zip_with _

lemma lt_length_left_of_zip_with {f : α → β → γ} {i : ℕ} {l : list α} {l' : list β}
  (h : i < (zip_with f l l').length) :
  i < l.length :=
by { rw [length_zip_with, lt_min_iff] at h, exact h.left }

lemma lt_length_right_of_zip_with {f : α → β → γ} {i : ℕ} {l : list α} {l' : list β}
  (h : i < (zip_with f l l').length) :
  i < l'.length :=
by { rw [length_zip_with, lt_min_iff] at h, exact h.right }

lemma lt_length_left_of_zip {i : ℕ} {l : list α} {l' : list β} (h : i < (zip l l').length) :
  i < l.length :=
lt_length_left_of_zip_with h

lemma lt_length_right_of_zip {i : ℕ} {l : list α} {l' : list β} (h : i < (zip l l').length) :
  i < l'.length :=
lt_length_right_of_zip_with h

theorem zip_append : ∀ {l₁ r₁ : list α} {l₂ r₂ : list β} (h : length l₁ = length l₂),
   zip (l₁ ++ r₁) (l₂ ++ r₂) = zip l₁ l₂ ++ zip r₁ r₂
| []      r₁ l₂      r₂ h := by simp only [eq_nil_of_length_eq_zero h.symm]; refl
| l₁      r₁ []      r₂ h := by simp only [eq_nil_of_length_eq_zero h]; refl
| (a::l₁) r₁ (b::l₂) r₂ h := by simp only [cons_append, zip_cons_cons, zip_append (succ.inj h)];
    split; refl

theorem zip_map (f : α → γ) (g : β → δ) : ∀ (l₁ : list α) (l₂ : list β),
   zip (l₁.map f) (l₂.map g) = (zip l₁ l₂).map (prod.map f g)
| []      l₂      := rfl
| l₁      []      := by simp only [map, zip_nil_right]
| (a::l₁) (b::l₂) := by simp only [map, zip_cons_cons, zip_map l₁ l₂, prod.map]; split; refl

theorem zip_map_left (f : α → γ) (l₁ : list α) (l₂ : list β) :
   zip (l₁.map f) l₂ = (zip l₁ l₂).map (prod.map f id) :=
by rw [← zip_map, map_id]

theorem zip_map_right (f : β → γ) (l₁ : list α) (l₂ : list β) :
   zip l₁ (l₂.map f) = (zip l₁ l₂).map (prod.map id f) :=
by rw [← zip_map, map_id]

@[simp] lemma zip_with_map {μ}
  (f : γ → δ → μ) (g : α → γ) (h : β → δ) (as : list α) (bs : list β) :
  zip_with f (as.map g) (bs.map h) =
  zip_with (λ a b, f (g a) (h b)) as bs :=
begin
  induction as generalizing bs,
  { simp },
  { cases bs; simp * }
end

lemma zip_with_map_left
  (f : α → β → γ) (g : δ → α) (l : list δ) (l' : list β) :
  zip_with f (l.map g) l' = zip_with (f ∘ g) l l' :=
by { convert (zip_with_map f g id l l'), exact eq.symm (list.map_id _) }

lemma zip_with_map_right
  (f : α → β → γ) (l : list α) (g : δ → β) (l' : list δ) :
  zip_with f l (l'.map g) = zip_with (λ x, f x ∘ g) l l' :=
by { convert (list.zip_with_map f id g l l'), exact eq.symm (list.map_id _) }

theorem zip_map' (f : α → β) (g : α → γ) : ∀ (l : list α),
   zip (l.map f) (l.map g) = l.map (λ a, (f a, g a))
| []     := rfl
| (a::l) := by simp only [map, zip_cons_cons, zip_map' l]; split; refl

lemma map_zip_with {δ : Type*} (f : α → β) (g : γ → δ → α) (l : list γ) (l' : list δ) :
  map f (zip_with g l l') = zip_with (λ x y, f (g x y)) l l' :=
begin
  induction l with hd tl hl generalizing l',
  { simp },
  { cases l',
    { simp },
    { simp [hl] } }
end

theorem mem_zip {a b} : ∀ {l₁ : list α} {l₂ : list β},
   (a, b) ∈ zip l₁ l₂ → a ∈ l₁ ∧ b ∈ l₂
| (_::l₁) (_::l₂) (or.inl rfl) := ⟨or.inl rfl, or.inl rfl⟩
| (a'::l₁) (b'::l₂) (or.inr h) := by split; simp only [mem_cons_iff, or_true, mem_zip h]

theorem map_fst_zip : ∀ (l₁ : list α) (l₂ : list β),
  l₁.length ≤ l₂.length →
  map prod.fst (zip l₁ l₂) = l₁
| [] bs _ := rfl
| (a :: as) (b :: bs) h := by { simp at h, simp! * }
| (a :: as) [] h := by { simp at h, contradiction }

theorem map_snd_zip : ∀ (l₁ : list α) (l₂ : list β),
  l₂.length ≤ l₁.length →
  map prod.snd (zip l₁ l₂) = l₂
| _ [] _ := by { rw zip_nil_right, refl }
| [] (b :: bs) h := by { simp at h, contradiction }
| (a :: as) (b :: bs) h := by { simp at h, simp! * }

@[simp] theorem unzip_nil : unzip (@nil (α × β)) = ([], []) := rfl

@[simp] theorem unzip_cons (a : α) (b : β) (l : list (α × β)) :
   unzip ((a, b) :: l) = (a :: (unzip l).1, b :: (unzip l).2) :=
by rw unzip; cases unzip l; refl

theorem unzip_eq_map : ∀ (l : list (α × β)), unzip l = (l.map prod.fst, l.map prod.snd)
| []            := rfl
| ((a, b) :: l) := by simp only [unzip_cons, map_cons, unzip_eq_map l]

theorem unzip_left (l : list (α × β)) : (unzip l).1 = l.map prod.fst :=
by simp only [unzip_eq_map]

theorem unzip_right (l : list (α × β)) : (unzip l).2 = l.map prod.snd :=
by simp only [unzip_eq_map]

theorem unzip_swap (l : list (α × β)) : unzip (l.map prod.swap) = (unzip l).swap :=
by simp only [unzip_eq_map, map_map]; split; refl

theorem zip_unzip : ∀ (l : list (α × β)), zip (unzip l).1 (unzip l).2 = l
| []            := rfl
| ((a, b) :: l) := by simp only [unzip_cons, zip_cons_cons, zip_unzip l]; split; refl

theorem unzip_zip_left : ∀ {l₁ : list α} {l₂ : list β}, length l₁ ≤ length l₂ →
  (unzip (zip l₁ l₂)).1 = l₁
| []      l₂      h := rfl
| l₁      []      h := by rw eq_nil_of_length_eq_zero (eq_zero_of_le_zero h); refl
| (a::l₁) (b::l₂) h := by simp only [zip_cons_cons, unzip_cons,
    unzip_zip_left (le_of_succ_le_succ h)]; split; refl

theorem unzip_zip_right {l₁ : list α} {l₂ : list β} (h : length l₂ ≤ length l₁) :
  (unzip (zip l₁ l₂)).2 = l₂ :=
by rw [← zip_swap, unzip_swap]; exact unzip_zip_left h

theorem unzip_zip {l₁ : list α} {l₂ : list β} (h : length l₁ = length l₂) :
  unzip (zip l₁ l₂) = (l₁, l₂) :=
by rw [← @prod.mk.eta _ _ (unzip (zip l₁ l₂)),
  unzip_zip_left (le_of_eq h), unzip_zip_right (ge_of_eq h)]

lemma zip_of_prod {l : list α} {l' : list β} {lp : list (α × β)}
  (hl : lp.map prod.fst = l) (hr : lp.map prod.snd = l') :
  lp = l.zip l' :=
by rw [←hl, ←hr, ←zip_unzip lp, ←unzip_left, ←unzip_right, zip_unzip, zip_unzip]

lemma map_prod_left_eq_zip {l : list α} (f : α → β) : l.map (λ x, (x, f x)) = l.zip (l.map f) :=
by { rw ←zip_map', congr, exact map_id _ }

lemma zip_with_comm (f : α → α → β) (comm : ∀ (x y : α), f x y = f y x)
  (l l' : list α) :
  zip_with f l l' = zip_with f l' l :=
begin
  induction l with hd tl hl generalizing l',
  { simp },
  { cases l',
    { simp },
    { simp [comm, hl] } }
end

instance (f : α → α → β) [is_symm_op α β f] : is_symm_op (list α) (list β) (zip_with f) :=
⟨zip_with_comm f is_symm_op.symm_op⟩

@[simp] theorem length_revzip (l : list α) : length (revzip l) = length l :=
by simp only [revzip, length_zip, length_reverse, min_self]

@[simp] theorem unzip_revzip (l : list α) : (revzip l).unzip = (l, l.reverse) :=
unzip_zip (length_reverse l).symm

@[simp] theorem revzip_map_fst (l : list α) : (revzip l).map prod.fst = l :=
by rw [← unzip_left, unzip_revzip]

@[simp] theorem revzip_map_snd (l : list α) : (revzip l).map prod.snd = l.reverse :=
by rw [← unzip_right, unzip_revzip]

theorem reverse_revzip (l : list α) : reverse l.revzip = revzip l.reverse :=
by rw [← zip_unzip.{u u} (revzip l).reverse, unzip_eq_map]; simp; simp [revzip]

theorem revzip_swap (l : list α) : (revzip l).map prod.swap = revzip l.reverse :=
by simp [revzip]

lemma nth_zip_with (f : α → β → γ) (l₁ : list α) (l₂ : list β) (i : ℕ) :
  (zip_with f l₁ l₂).nth i = ((l₁.nth i).map f).bind (λ g, (l₂.nth i).map g) :=
begin
  induction l₁ generalizing l₂ i,
  { simp [zip_with, (<*>)] },
  { cases l₂; simp only [zip_with, has_seq.seq, functor.map, nth, option.map_none'],
    { cases ((l₁_hd :: l₁_tl).nth i); refl },
    { cases i; simp only [option.map_some', nth, option.some_bind', *] } }
end

lemma nth_zip_with_eq_some {α β γ} (f : α → β → γ) (l₁ : list α) (l₂ : list β) (z : γ) (i : ℕ) :
  (zip_with f l₁ l₂).nth i = some z ↔ ∃ x y, l₁.nth i = some x ∧ l₂.nth i = some y ∧ f x y = z :=
begin
  induction l₁ generalizing l₂ i,
  { simp [zip_with] },
  { cases l₂; simp only [zip_with, nth, exists_false, and_false, false_and],
    cases i; simp *, },
end

lemma nth_zip_eq_some (l₁ : list α) (l₂ : list β) (z : α × β) (i : ℕ) :
  (zip l₁ l₂).nth i = some z ↔ l₁.nth i = some z.1 ∧ l₂.nth i = some z.2 :=
begin
  cases z,
  rw [zip, nth_zip_with_eq_some], split,
  { rintro ⟨x, y, h₀, h₁, h₂⟩, cc },
  { rintro ⟨h₀, h₁⟩, exact ⟨_,_,h₀,h₁,rfl⟩ }
end

@[simp] lemma nth_le_zip_with {f : α → β → γ} {l : list α} {l' : list β} {i : ℕ}
  {h : i < (zip_with f l l').length} :
  (zip_with f l l').nth_le i h =
    f (l.nth_le i (lt_length_left_of_zip_with h)) (l'.nth_le i (lt_length_right_of_zip_with h)) :=
begin
  rw [←option.some_inj, ←nth_le_nth, nth_zip_with_eq_some],
  refine ⟨l.nth_le i (lt_length_left_of_zip_with h), l'.nth_le i (lt_length_right_of_zip_with h),
          nth_le_nth _, _⟩,
  simp only [←nth_le_nth, eq_self_iff_true, and_self]
end

@[simp] lemma nth_le_zip {l : list α} {l' : list β} {i : ℕ} {h : i < (zip l l').length} :
  (zip l l').nth_le i h =
    (l.nth_le i (lt_length_left_of_zip h), l'.nth_le i (lt_length_right_of_zip h)) :=
nth_le_zip_with

lemma mem_zip_inits_tails {l : list α} {init tail : list α} :
  (init, tail) ∈ zip l.inits l.tails ↔ init ++ tail = l :=
begin
  induction l generalizing init tail;
    simp_rw [tails, inits, zip_cons_cons],
  { simp },
  { split; rw [mem_cons_iff, zip_map_left, mem_map, prod.exists],
    { rintros (⟨rfl, rfl⟩ | ⟨_, _, h, rfl, rfl⟩),
      { simp },
      { simp [l_ih.mp h], }, },
    { cases init,
      { simp },
      { intro h,
        right,
        use [init_tl, tail],
        simp * at *, }, }, },
end

lemma map_uncurry_zip_eq_zip_with
  (f : α → β → γ) (l : list α) (l' : list β) :
  map (function.uncurry f) (l.zip l') = zip_with f l l' :=
begin
  induction l with hd tl hl generalizing l',
  { simp },
  { cases l' with hd' tl',
    { simp },
    { simp [hl] } }
end

@[simp] lemma sum_zip_with_distrib_left {γ : Type*} [semiring γ]
  (f : α → β → γ) (n : γ) (l : list α) (l' : list β) :
  (l.zip_with (λ x y, n * f x y) l').sum = n * (l.zip_with f l').sum :=
begin
  induction l with hd tl hl generalizing f n l',
  { simp },
  { cases l' with hd' tl',
    { simp, },
    { simp [hl, mul_add] } }
end

section distrib

/-! ### Operations that can be applied before or after a `zip_with` -/

variables (f : α → β → γ) (l : list α) (l' : list β) (n : ℕ)

lemma zip_with_distrib_take :
  (zip_with f l l').take n = zip_with f (l.take n) (l'.take n) :=
begin
  induction l with hd tl hl generalizing l' n,
  { simp },
  { cases l',
    { simp },
    { cases n,
      { simp },
      { simp [hl] } } }
end

lemma zip_with_distrib_drop :
  (zip_with f l l').drop n = zip_with f (l.drop n) (l'.drop n) :=
begin
  induction l with hd tl hl generalizing l' n,
  { simp },
  { cases l',
    { simp },
    { cases n,
      { simp },
      { simp [hl] } } }
end

lemma zip_with_distrib_tail :
  (zip_with f l l').tail = zip_with f l.tail l'.tail :=
by simp_rw [←drop_one, zip_with_distrib_drop]

lemma zip_with_append (f : α → β → γ) (l la : list α) (l' lb : list β) (h : l.length = l'.length) :
  zip_with f (l ++ la) (l' ++ lb) = zip_with f l l' ++ zip_with f la lb :=
begin
  induction l with hd tl hl generalizing l',
  { have : l' = [] := eq_nil_of_length_eq_zero (by simpa using h.symm),
    simp [this], },
  { cases l',
    { simpa using h },
    { simp only [add_left_inj, length] at h,
      simp [hl _ h] } }
end

lemma zip_with_distrib_reverse (h : l.length = l'.length) :
  (zip_with f l l').reverse = zip_with f l.reverse l'.reverse :=
begin
  induction l with hd tl hl generalizing l',
  { simp },
  { cases l' with hd' tl',
    { simp },
    { simp only [add_left_inj, length] at h,
      have : tl.reverse.length = tl'.reverse.length := by simp [h],
      simp [hl _ h, zip_with_append _ _ _ _ _ this] } }
end

end distrib

end list


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

/-!
# solve_by_elim

A depth-first search backwards reasoner.

`solve_by_elim` takes a list of lemmas, and repeating tries to `apply` these against
the goals, recursively acting on any generated subgoals.

It accepts a variety of configuration options described below, enabling
* backtracking across multiple goals,
* pruning the search tree, and
* invoking other tactics before or after trying to apply lemmas.

At present it has no "premise selection", and simply tries the supplied lemmas in order
at each step of the search.
-/

namespace tactic

namespace solve_by_elim
/--
`mk_assumption_set` builds a collection of lemmas for use in
the backtracking search in `solve_by_elim`.

* By default, it includes all local hypotheses, along with `rfl`, `trivial`, `congr_fun` and
  `congr_arg`.
* The flag `no_dflt` removes these.
* The argument `hs` is a list of `simp_arg_type`s,
  and can be used to add, or remove, lemmas or expressions from the set.
* The argument `attr : list name` adds all lemmas tagged with one of a specified list of attributes.

`mk_assumption_set` returns not a `list expr`, but a `list (tactic expr) × tactic (list expr)`.
There are two separate problems that need to be solved.

### Relevant local hypotheses

`solve_by_elim*` works with multiple goals,
and we need to use separate sets of local hypotheses for each goal.
The second component of the returned value provides these local hypotheses.
(Essentially using `local_context`, along with some filtering to remove hypotheses
that have been explicitly removed via `only` or `[-h]`.)

### Stuck metavariables

Lemmas with implicit arguments would be filled in with metavariables if we created the
`expr` objects immediately, so instead we return thunks that generate the expressions
on demand. This is the first component, with type `list (tactic expr)`.

As an example, we have `def rfl : ∀ {α : Sort u} {a : α}, a = a`, which on elaboration will become
`@rfl ?m_1 ?m_2`.

Because `solve_by_elim` works by repeated application of lemmas against subgoals,
the first time such a lemma is successfully applied,
those metavariables will be unified, and thereafter have fixed values.
This would make it impossible to apply the lemma
a second time with different values of the metavariables.

See https://github.com/leanprover-community/mathlib/issues/2269

As an optimisation, after we build the list of `tactic expr`s, we actually run them, and replace any
that do not in fact produce metavariables with a simple `return` tactic.
-/
meta def mk_assumption_set (no_dflt : bool) (hs : list simp_arg_type) (attr : list name) :
  tactic (list (tactic expr) × tactic (list expr)) :=
-- We lock the tactic state so that any spurious goals generated during
-- elaboration of pre-expressions are discarded
lock_tactic_state $
do
  -- `hs` are expressions specified explicitly,
  -- `hex` are exceptions (specified via `solve_by_elim [-h]`) referring to local hypotheses,
  -- `gex` are the other exceptions
  (hs, gex, hex, all_hyps) ← decode_simp_arg_list hs,
  -- Recall, per the discussion above, we produce `tactic expr` thunks rather than actual `expr`s.
  -- Note that while we evaluate these thunks on two occasions below while preparing the list,
  -- this is a one-time cost during `mk_assumption_set`, rather than a cost proportional to the
  -- length of the search `solve_by_elim` executes.
  let hs := hs.map (λ h, i_to_expr_for_apply h),
  l ← attr.mmap $ λ a, attribute.get_instances a,
  let l := l.join,
  let m := l.map (λ h, mk_const h),
  -- In order to remove the expressions we need to evaluate the thunks.
  hs ← (hs ++ m).mfilter $ λ h, (do h ← h, return $ expr.const_name h ∉ gex),
  let hs := if no_dflt then hs else
    ([`rfl, `trivial, `congr_fun, `congr_arg].map (λ n, (mk_const n))) ++ hs,
  let locals : tactic (list expr) := if ¬ no_dflt ∨ all_hyps then do
    ctx ← local_context,
    -- Remove local exceptions specified in `hex`:
    return $ ctx.filter (λ h : expr, h.local_uniq_name ∉ hex)
  else return [],
  -- Finally, run all of the tactics: any that return an expression without metavariables can safely
  -- be replaced by a `return` tactic.
  hs ← hs.mmap (λ h : tactic expr, do
    e ← h,
    if e.has_meta_var then return h else return (return e)),
  return (hs, locals)

/--
Configuration options for `solve_by_elim`.

* `accept : list expr → tactic unit` determines whether the current branch should be explored.
   At each step, before the lemmas are applied,
   `accept` is passed the proof terms for the original goals,
   as reported by `get_goals` when `solve_by_elim` started.
   These proof terms may be metavariables (if no progress has been made on that goal)
   or may contain metavariables at some leaf nodes
   (if the goal has been partially solved by previous `apply` steps).
   If the `accept` tactic fails `solve_by_elim` aborts searching this branch and backtracks.
   By default `accept := λ _, skip` always succeeds.
   (There is an example usage in `tests/solve_by_elim.lean`.)
* `pre_apply : tactic unit` specifies an additional tactic to run before each round of `apply`.
* `discharger : tactic unit` specifies an additional tactic to apply on subgoals
  for which no lemma applies.
  If that tactic succeeds, `solve_by_elim` will continue applying lemmas on resulting goals.
-/
meta structure basic_opt extends apply_any_opt :=
(accept : list expr → tactic unit := λ _, skip)
(pre_apply : tactic unit := skip)
(discharger : tactic unit := failed)
(max_depth : ℕ := 3)

declare_trace solve_by_elim         -- trace attempted lemmas

/--
A helper function for trace messages, prepending '....' depending on the current search depth.
-/
meta def solve_by_elim_trace (n : ℕ) (f : format) : tactic unit :=
trace_if_enabled `solve_by_elim
  (format!"[solve_by_elim {(list.replicate (n+1) '.').as_string} " ++ f ++ "]")

/-- A helper function to generate trace messages on successful applications. -/
meta def on_success (g : format) (n : ℕ) (e : expr) : tactic unit :=
do
  pp ← pp e,
  solve_by_elim_trace n (format!"✅ `{pp}` solves `⊢ {g}`")

/-- A helper function to generate trace messages on unsuccessful applications. -/
meta def on_failure (g : format) (n : ℕ) : tactic unit :=
solve_by_elim_trace n (format!"❌ failed to solve `⊢ {g}`")

/--
A helper function to generate the tactic that print trace messages.
This function exists to ensure the target is pretty printed only as necessary.
-/
meta def trace_hooks (n : ℕ) : tactic ((expr → tactic unit) × tactic unit) :=
if is_trace_enabled_for `solve_by_elim then
  do
    g ← target >>= pp,
    return (on_success g n, on_failure g n)
else
  return (λ _, skip, skip)

/--
The internal implementation of `solve_by_elim`, with a limiting counter.
-/
meta def solve_by_elim_aux (opt : basic_opt) (original_goals : list expr)
  (lemmas : list (tactic expr)) (ctx : tactic (list expr)) :
  ℕ → tactic unit
| n := do
  -- First, check that progress so far is `accept`able.
  lock_tactic_state (original_goals.mmap instantiate_mvars >>= opt.accept),
  -- Then check if we've finished.
  (done >> solve_by_elim_trace (opt.max_depth - n) "success!") <|> (do
    -- Otherwise, if there's more time left,
    (guard (n > 0) <|>
      solve_by_elim_trace opt.max_depth "🛑 aborting, hit depth limit" >> failed),
    -- run the `pre_apply` tactic, then
    opt.pre_apply,
    -- try either applying a lemma and recursing,
    (on_success, on_failure) ← trace_hooks (opt.max_depth - n),
    ctx_lemmas ← ctx,
    (apply_any_thunk (lemmas ++ (ctx_lemmas.map return)) opt.to_apply_any_opt
      (solve_by_elim_aux (n-1))
      on_success on_failure) <|>
    -- or if that doesn't work, run the discharger and recurse.
     (opt.discharger >> solve_by_elim_aux (n-1)))

/--
Arguments for `solve_by_elim`:
* By default `solve_by_elim` operates only on the first goal,
  but with `backtrack_all_goals := true`, it operates on all goals at once,
  backtracking across goals as needed,
  and only succeeds if it discharges all goals.
* `lemmas` specifies the list of lemmas to use in the backtracking search.
  If `none`, `solve_by_elim` uses the local hypotheses,
  along with `rfl`, `trivial`, `congr_arg`, and `congr_fun`.
* `lemma_thunks` provides the lemmas as a list of `tactic expr`,
  which are used to regenerate the `expr` objects to avoid binding metavariables.
  It should not usually be specified by the user.
  (If both `lemmas` and `lemma_thunks` are specified, only `lemma_thunks` is used.)
* `ctx_thunk` is for internal use only: it returns the local hypotheses which will be used.
* `max_depth` bounds the depth of the search.
-/
meta structure opt extends basic_opt :=
(backtrack_all_goals : bool := ff)
(lemmas : option (list expr) := none)
(lemma_thunks : option (list (tactic expr)) := lemmas.map (λ l, l.map return))
(ctx_thunk : tactic (list expr) := local_context)

/--
If no lemmas have been specified, generate the default set
(local hypotheses, along with `rfl`, `trivial`, `congr_arg`, and `congr_fun`).
-/
meta def opt.get_lemma_thunks (opt : opt) : tactic (list (tactic expr) × tactic (list expr)) :=
match opt.lemma_thunks with
| none := mk_assumption_set ff [] []
| some lemma_thunks := return (lemma_thunks, opt.ctx_thunk)
end

end solve_by_elim

open solve_by_elim

/--
`solve_by_elim` repeatedly tries `apply`ing a lemma
from the list of assumptions (passed via the `opt` argument),
recursively operating on any generated subgoals, backtracking as necessary.

`solve_by_elim` succeeds only if it discharges the goal.
(By default, `solve_by_elim` focuses on the first goal, and only attempts to solve that.
With the option `backtrack_all_goals := tt`,
it attempts to solve all goals, and only succeeds if it does so.
With `backtrack_all_goals := tt`, `solve_by_elim` will backtrack a solution it has found for
one goal if it then can't discharge other goals.)

If passed an empty list of assumptions, `solve_by_elim` builds a default set
as per the interactive tactic, using the `local_context` along with
`rfl`, `trivial`, `congr_arg`, and `congr_fun`.

To pass a particular list of assumptions, use the `lemmas` field
in the configuration argument. This expects an
`option (list expr)`. In certain situations it may be necessary to instead use the
`lemma_thunks` field, which expects a `option (list (tactic expr))`.
This allows for regenerating metavariables
for each application, which might otherwise get stuck.

See also the simpler tactic `apply_rules`, which does not perform backtracking.
-/
meta def solve_by_elim (opt : opt := { }) : tactic unit :=
do
  tactic.fail_if_no_goals,
  (lemmas, ctx_lemmas) ← opt.get_lemma_thunks,
  (if opt.backtrack_all_goals then id else focus1) $ (do
    gs ← get_goals,
    solve_by_elim_aux opt.to_basic_opt gs lemmas ctx_lemmas opt.max_depth <|>
    fail ("`solve_by_elim` failed.\n" ++
      "Try `solve_by_elim { max_depth := N }` for `N > " ++ (to_string opt.max_depth) ++ "`\n" ++
      "or use `set_option trace.solve_by_elim true` to view the search."))

setup_tactic_parser

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

If this fails, `apply_assumption` will call `symmetry` and try again.

If this also fails, `apply_assumption` will call `exfalso` and try again,
so that if there is an assumption of the form `P → ¬ Q`, the new tactic state
will have two goals, `P` and `Q`.

Optional arguments:
- `lemmas`: a list of expressions to apply, instead of the local constants
- `tac`: a tactic to run on each subgoal 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
  (lemmas : parse pexpr_list?)
  (opt : apply_any_opt := {})
  (tac : tactic unit := skip) : tactic unit :=
do
  lemmas ← match lemmas with
  | none := local_context
  | some lemmas := lemmas.mmap to_expr
  end,
  tactic.apply_any lemmas opt tac

add_tactic_doc
{ name        := "apply_assumption",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.apply_assumption],
  tags        := ["context management", "lemma application"] }

/--
`solve_by_elim` calls `apply` on the main goal to find an assumption whose head matches
and then repeatedly calls `apply` on the generated subgoals until no subgoals remain,
performing at most `max_depth` recursive steps.

`solve_by_elim` discharges the current goal or fails.

`solve_by_elim` performs back-tracking if subgoals can not be solved.

By default, the assumptions passed to `apply` are the local context, `rfl`, `trivial`,
`congr_fun` and `congr_arg`.

The assumptions can be modified with similar syntax as for `simp`:
* `solve_by_elim [h₁, h₂, ..., hᵣ]` also applies the named lemmas.
* `solve_by_elim with attr₁ ... attrᵣ` also applies all lemmas tagged with the specified attributes.
* `solve_by_elim only [h₁, h₂, ..., hᵣ]` does not include the local context,
  `rfl`, `trivial`, `congr_fun`, or `congr_arg` unless they are explicitly included.
* `solve_by_elim [-id_1, ... -id_n]` uses the default assumptions, removing the specified ones.

`solve_by_elim*` tries to solve all goals together, using backtracking if a solution for one goal
makes other goals impossible.

optional arguments passed via a configuration argument as `solve_by_elim { ... }`
- max_depth: number of attempts at discharging generated sub-goals
- discharger: a subsidiary tactic to try at each step when no lemmas apply
  (e.g. `cc` may be helpful).
- pre_apply: a subsidiary tactic to run at each step before applying lemmas (e.g. `intros`).
- accept: a subsidiary tactic `list expr → tactic unit` that at each step,
    before any lemmas are applied, is passed the original proof terms
    as reported by `get_goals` when `solve_by_elim` started
    (but which may by now have been partially solved by previous `apply` steps).
    If the `accept` tactic fails,
    `solve_by_elim` will abort searching the current branch and backtrack.
    This may be used to filter results, either at every step of the search,
    or filtering complete results
    (by testing for the absence of metavariables, and then the filtering condition).
-/
meta def solve_by_elim (all_goals : parse $ (tk "*")?) (no_dflt : parse only_flag)
  (hs : parse simp_arg_list) (attr_names : parse with_ident_list) (opt : solve_by_elim.opt := { }) :
  tactic unit :=
do (lemma_thunks, ctx_thunk) ← mk_assumption_set no_dflt hs attr_names,
   tactic.solve_by_elim
   { backtrack_all_goals := all_goals.is_some ∨ opt.backtrack_all_goals,
     lemma_thunks := some lemma_thunks,
     ctx_thunk := ctx_thunk,
     ..opt }

add_tactic_doc
{ name        := "solve_by_elim",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.solve_by_elim],
  tags        := ["search"] }

end interactive

end tactic


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Lean
import Std.Tactic.OpenPrivate
import Std.Data.List.Basic
import Mathlib.Lean.Expr.Basic

/-!

# Backward compatible implementation of lean 3 `cases` tactic

This tactic is similar to the `cases` tactic in lean 4 core, but the syntax for giving
names is different:

```
example (h : p ∨ q) : q ∨ p := by
  cases h with
  | inl hp => exact Or.inr hp
  | inr hq => exact Or.inl hq

example (h : p ∨ q) : q ∨ p := by
  cases' h with hp hq
  · exact Or.inr hp
  · exact Or.inl hq

example (h : p ∨ q) : q ∨ p := by
  rcases h with hp | hq
  · exact Or.inr hp
  · exact Or.inl hq
```

Prefer `cases` or `rcases` when possible, because these tactics promote structured proofs.
-/

namespace Lean.Parser.Tactic
open Meta Elab Elab.Tactic

open private getAltNumFields in evalCases ElimApp.evalAlts.go in
def ElimApp.evalNames (elimInfo : ElimInfo) (alts : Array ElimApp.Alt) (withArg : Syntax)
    (numEqs := 0) (numGeneralized := 0) (toClear : Array FVarId := #[]) :
    TermElabM (Array MVarId) := do
  let mut names : List Syntax := withArg[1].getArgs |>.toList
  let mut subgoals := #[]
  for { name := altName, mvarId := g, .. } in alts do
    let numFields ← getAltNumFields elimInfo altName
    let (altVarNames, names') := names.splitAtD numFields (Unhygienic.run `(_))
    names := names'
    let (fvars, g) ← g.introN numFields <| altVarNames.map (getNameOfIdent' ·[0])
    let some (g, subst) ← Cases.unifyEqs? numEqs g {} | pure ()
    let (_, g) ← g.introNP numGeneralized
    let g ← liftM $ toClear.foldlM (·.tryClear) g
    for fvar in fvars, stx in altVarNames do
      g.withContext <| (subst.apply <| .fvar fvar).addLocalVarInfoForBinderIdent ⟨stx⟩
    subgoals := subgoals.push g
  pure subgoals

open private getElimNameInfo generalizeTargets generalizeVars in evalInduction in
elab (name := induction') "induction' " tgts:(casesTarget,+)
    usingArg:((" using " ident)?)
    withArg:((" with " (colGt binderIdent)+)?)
    genArg:((" generalizing " (colGt ident)+)?) : tactic => do
  let targets ← elabCasesTargets tgts.1.getSepArgs
  let g :: gs ← getUnsolvedGoals | throwNoGoalsToBeSolved
  g.withContext do
    let elimInfo ← getElimNameInfo usingArg targets (induction := true)
    let targets ← addImplicitTargets elimInfo targets
    evalInduction.checkTargets targets
    let targetFVarIds := targets.map (·.fvarId!)
    g.withContext do
      let genArgs ← if genArg.1.isNone then pure #[] else getFVarIds genArg.1[1].getArgs
      let forbidden ← mkGeneralizationForbiddenSet targets
      let mut s ← getFVarSetToGeneralize targets forbidden
      for v in genArgs do
        if forbidden.contains v then
          throwError ("variable cannot be generalized " ++
            "because target depends on it{indentExpr (mkFVar v)}")
        if s.contains v then
          throwError ("unnecessary 'generalizing' argument, " ++
            "variable '{mkFVar v}' is generalized automatically")
        s := s.insert v
      let (fvarIds, g) ← g.revert (← sortFVarIds s.toArray)
      let result ← withRef tgts <| ElimApp.mkElimApp elimInfo targets (← g.getTag)
      let elimArgs := result.elimApp.getAppArgs
      ElimApp.setMotiveArg g elimArgs[elimInfo.motivePos]!.mvarId! targetFVarIds
      g.assign result.elimApp
      let subgoals ← ElimApp.evalNames elimInfo result.alts withArg
        (numGeneralized := fvarIds.size) (toClear := targetFVarIds)
      setGoals <| (subgoals ++ result.others).toList ++ gs

open private getElimNameInfo in evalCases in
elab (name := cases') "cases' " tgts:(casesTarget,+) usingArg:((" using " ident)?)
  withArg:((" with " (colGt binderIdent)+)?) : tactic => do
  let targets ← elabCasesTargets tgts.1.getSepArgs
  let g :: gs ← getUnsolvedGoals | throwNoGoalsToBeSolved
  g.withContext do
    let elimInfo ← getElimNameInfo usingArg targets (induction := false)
    let targets ← addImplicitTargets elimInfo targets
    let result ← withRef tgts <| ElimApp.mkElimApp elimInfo targets (← g.getTag)
    let elimArgs := result.elimApp.getAppArgs
    let targets ← elimInfo.targetsPos.mapM (instantiateMVars elimArgs[·]!)
    let motive := elimArgs[elimInfo.motivePos]!
    let g ← generalizeTargetsEq g (← inferType motive) targets
    let (targetsNew, g) ← g.introN targets.size
    g.withContext do
      ElimApp.setMotiveArg g motive.mvarId! targetsNew
      g.assign result.elimApp
      let subgoals ← ElimApp.evalNames elimInfo result.alts withArg
         (numEqs := targets.size) (toClear := targetsNew)
      setGoals <| subgoals.toList ++ gs