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

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

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

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

## Basic usage of `fun_like`

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

namespace my_hom

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

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

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

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

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

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

end my_hom
```

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

## Morphism classes extending `fun_like`

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

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

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

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

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

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

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

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

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

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

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

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

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

-/

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

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

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

section dependent

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

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

namespace fun_like

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

include i

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

@[simp]

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

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

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

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

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

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

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

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

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

end fun_like

end dependent

section non_dependent

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

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

include i

namespace fun_like

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

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

end fun_like

end non_dependent


import .love05_inductive_predicates_demo

/- # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom monadic tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself.

Abstract syntax trees __reflect__ internal data structures, e.g., for
expressions (terms).

The prover's C++ internals are exposed through Lean interfaces, which we can
use for accessing the current context and goal, unifying expressions, querying
and modifying the environment, and setting attributes (e.g., `@[simp]`).

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Tactics and Tactic Combinators

When programming our own tactics, we often need to repeat some actions on
several goals, or to recover if a tactic fails. Tactic combinators help in such
case.

`repeat` applies its argument repeatedly on all (sub…sub)goals until it cannot
be applied any further. -/

lemma repeat_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat { apply even.add_two },
  repeat { sorry }
end

/- The "orelse" combinator `<|>` tries its first argument and applies its
second argument in case of failure. -/

lemma repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/- `iterate` works repeatedly on the first goal until it fails; then it
stops. -/

lemma iterate_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  iterate {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/- `all_goals` applies its argument exactly once to each goal. It succeeds only
if the argument succeeds on **all** goals. -/

lemma all_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { apply even.add_two },   -- fails
  repeat { sorry }
end

/- `try` transforms its argument into a tactic that never fails. -/

lemma all_goals_try_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { try { apply even.add_two } },
  repeat { sorry }
end

/- `any_goals` applies its argument exactly once to each goal. It succeeds
if the argument succeeds on **any** goal. -/

lemma any_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { apply even.add_two },
  repeat { sorry }
end

/- `solve1` transforms its argument into an all-or-nothing tactic. If the
argument does not prove the goal, `solve1` fails. -/

lemma any_goals_solve1_repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { solve1 { repeat {
    apply even.add_two
    <|> apply even.zero } } },
  repeat { sorry }
end

/- The combinators `repeat`, `iterate`, `all_goals`, and `any_goals` can easily
lead to infinite looping: -/

/-
lemma repeat_not_example :
  ¬ even 1 :=
begin
  repeat { apply not.intro },
  sorry
end
-/

/- Let us start with the actual metaprogramming, by coding a custom tactic. The
tactic embodies the behavior we hardcoded in the `solve1` example above: -/

meta def intro_and_even : tactic unit :=
do
  tactic.repeat (tactic.applyc ``and.intro),
  tactic.any_goals (tactic.solve1 (tactic.repeat
    (tactic.applyc ``even.add_two
     <|> tactic.applyc ``even.zero))),
  pure ()

/- The `meta` keyword makes it possible for the function to call other
metafunctions. The `do` keyword enters a monad, and the `<|>` operator is the
"orelse" operator of alternative monads. At the end, we return `()`, of type
`unit`, to ensure the metaprogram has the desired type.

Any executable Lean definition can be used as a metaprogram. In addition, we can
put `meta` in front of a definition to indicate that is a metadefinition. Such
definitions need not terminate but cannot be used in non-`meta` contexts.

Let us apply our custom tactic: -/

lemma any_goals_solve1_repeat_orelse_example₂ :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  intro_and_even,
  repeat { sorry }
end

/- ## The Metaprogramming Monad

Tactics have access to

* the list of **goals** as metavariables (each metavariables has a type and a
  local context (hypothesis); they can optionally be instantiated);

* the **elaborator** (to elaborate expressions and compute their type);

* the **environment**, containing all declarations and inductive types;

* the **attributes** (e.g., the list of `@[simp]` rules).

The tactic monad is an alternative monad, with `fail` and `<|>`. Tactics can
also produce trace messages. -/

lemma even_14 :
  even 14 :=
by do
  tactic.trace "Proving evenness …",
  intro_and_even

meta def hello_then_intro_and_even : tactic unit :=
do
  tactic.trace "Proving evenness …",
  intro_and_even

lemma even_16 :
  even 16 :=
by hello_then_intro_and_even

run_cmd tactic.trace "Hello, Metaworld!"

meta def trace_goals : tactic unit :=
do
  tactic.trace "local context:",
  ctx ← tactic.local_context,
  tactic.trace ctx,
  tactic.trace "target:",
  P ← tactic.target,
  tactic.trace P,
  tactic.trace "all missing proofs:",
  Hs ← tactic.get_goals,
  tactic.trace Hs,
  τs ← list.mmap tactic.infer_type Hs,
  tactic.trace τs

lemma even_18_and_even_20 (α : Type) (a : α) :
  even 18 ∧ even 20 :=
by do
  tactic.applyc ``and.intro,
  trace_goals,
  intro_and_even

lemma triv_imp (a : Prop) (h : a) :
  a :=
by do
  h ← tactic.get_local `h,
  tactic.trace "h:",
  tactic.trace h,
  tactic.trace "raw h:",
  tactic.trace (expr.to_raw_fmt h),
  tactic.trace "type of h:",
  τ ← tactic.infer_type h,
  tactic.trace τ,
  tactic.trace "type of type of h:",
  υ ← tactic.infer_type τ,
  tactic.trace υ,
  tactic.apply h

meta def exact_list : list expr → tactic unit
| []        := tactic.fail "no matching expression found"
| (h :: hs) :=
  do {
    tactic.trace "trying",
    tactic.trace h,
    tactic.exact h }
  <|> exact_list hs

meta def hypothesis : tactic unit :=
do
  hs ← tactic.local_context,
  exact_list hs

lemma app_of_app {α : Type} {p : α → Prop} {a : α}
    (h : p a) :
  p a :=
by hypothesis

/- ## Names, Expressions, Declarations, and Environments

The metaprogramming framework is articulated around five main types:

* `tactic` manages the proof state, the global context, and more;

* `name` represents a structured name (e.g., `x`, `even.add_two`);

* `expr` represents an expression (a term) as an abstract syntax tree;

* `declaration` represents a constant declaration, a definition, an axiom, or a
  lemma;

* `environment` stores all the declarations and notations that make up the
  global context. -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)
#check expr.sort level.zero  -- Sort 0, i.e., Prop
#check expr.sort (level.succ level.zero)
  -- Sort 1, i.e., Type
#check expr.var 0  -- bound variable with De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default
  `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ)
  (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ)
  (expr.var 0) : expr)
#check expr.elet
#check expr.macro

/- We can create literal expressions conveniently using backticks and
parentheses:

* Expressions with a single backtick must be fully elaborated.

* Expressions with two backticks are __pre-expressions__: They may contain some
  holes to be filled in later, based on some context.

* Expressions with three backticks are pre-expressions without name checking. -/

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  tactic.trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),   -- fails
  tactic.trace e

run_cmd do
  let e₁ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₂ : pexpr := ``(list.map _ [1, 2, 3]),
  tactic.trace e₁,
  tactic.trace e₂

run_cmd do
  let e : pexpr := ```(seattle.washington),
  tactic.trace e

/- We can also create literal names with backticks:

* Names with a single backtick, `n, are not checked for existence.

* Names with two backticks, ``n, are resolved and checked. -/

run_cmd tactic.trace `and.intro
run_cmd tactic.trace `intro_and_even
run_cmd tactic.trace `seattle.washington

run_cmd tactic.trace ``and.intro
run_cmd tactic.trace ``intro_and_even
run_cmd tactic.trace ``seattle.washington   -- fails

/- __Antiquotations__ embed an existing expression in a larger expression. They
are announced by the prefix `%%` followed by a name from the current context.
Antiquotations are available with one, two, and three backticks: -/

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ``(list.map %%x),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ```(a _ %%x),
  tactic.trace e

lemma one_add_two_eq_three :
  1 + 2 = 3 :=
by do
  `(%%a + %%b = %%c) ← tactic.target,
  tactic.trace a,
  tactic.trace b,
  tactic.trace c,
  `(@eq %%α %%l %%r) ← tactic.target,
  tactic.trace α,
  tactic.trace l,
  tactic.trace r,
  tactic.exact `(refl _ : 3 = 3)

#print declaration

/- The `environment` type is presented as an abstract type, equipped with some
operations to query and modify it. The `environment.fold` metafunction iterates
over all declarations making up the environment. -/

run_cmd do
  env ← tactic.get_env,
  tactic.trace (environment.fold env 0 (λdecl n, n + 1))

/- ## First Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/- Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/- Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/- ## Second Example: A Provability Advisor

Next, we implement a `prove_direct` tool that traverses all lemmas in the
database and checks whether one of them can be used to prove the current goal. A
similar tactic is available in `mathlib` under the name `library_search`. -/

meta def is_theorem : declaration → bool
| (declaration.defn _ _ _ _ _ _) := ff
| (declaration.thm _ _ _ _)      := tt
| (declaration.cnst _ _ _ _)     := ff
| (declaration.ax _ _ _)         := tt

meta def get_all_theorems : tactic (list name) :=
do
  env ← tactic.get_env,
  pure (environment.fold env [] (λdecl nams,
    if is_theorem decl then declaration.to_name decl :: nams
    else nams))

meta def prove_with_name (nam : name) : tactic unit :=
do
  tactic.applyc nam
    ({ md := tactic.transparency.reducible, unify := ff }
     : tactic.apply_cfg),
  tactic.all_goals tactic.assumption,
  pure ()

meta def prove_direct : tactic unit :=
do
  nams ← get_all_theorems,
  list.mfirst (λnam,
      do
        prove_with_name nam,
        tactic.trace ("directly proved by " ++ to_string nam))
    nams

lemma nat.eq_symm (x y : ℕ) (h : x = y) :
  y = x :=
by prove_direct

lemma nat.eq_symm₂ (x y : ℕ) (h : x = y) :
  y = x :=
by library_search

lemma list.reverse_twice (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct

lemma list.reverse_twice_symm (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct   -- fails

/- As a small refinement, we propose a version of `prove_direct` that also
looks for equalities stated in symmetric form. -/

meta def prove_direct_symm : tactic unit :=
prove_direct
<|>
do {
  tactic.applyc `eq.symm,
  prove_direct }

lemma list.reverse_twice₂ (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct_symm

lemma list.reverse_twice_symm₂ (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct_symm

/- ## A Look at Two Predefined Tactics

Quite a few of Lean's predefined tactics are implemented as metaprograms and
not in C++. We can find these definitions by clicking the name of a construct
in Visual Studio Code while holding the control or command key. -/

#check tactic.intro
#check tactic.assumption

end LoVe


/-- Convert a character into a `UInt8`, by truncating (reducing modulo 256) if necessary. -/
def Char.toUInt8 (n : Char) : UInt8 := n.1.toUInt8

theorem Char.utf8Size_pos (c : Char) : 0 < c.utf8Size := by
  simp only [utf8Size]
  repeat (split; decide)
  decide

theorem String.csize_pos : (c : Char) → 0 < String.csize c := Char.utf8Size_pos


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

lemma punit_eq (a b : punit) : a = b :=
punit.rec_on a (punit.rec_on b rfl)

lemma punit_eq_star (a : punit) : a = punit.star :=
punit_eq a punit.star

instance : subsingleton punit :=
subsingleton.intro punit_eq

instance : inhabited punit :=
⟨punit.star⟩

instance : decidable_eq punit :=
λ a b, is_true (punit_eq a b)


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Lean.Meta.Tactic.Util
import Lean.Util.ForEachExpr
import Lean.Util.OccursCheck
import Lean.Elab.Tactic.Basic

namespace Lean.Elab.Term
open Tactic (TacticM evalTactic getUnsolvedGoals withTacticInfoContext)
open Meta

/-- Auxiliary function used to implement `synthesizeSyntheticMVars`. -/
private def resumeElabTerm (stx : Syntax) (expectedType? : Option Expr) (errToSorry := true) : TermElabM Expr :=
  -- Remark: if `ctx.errToSorry` is already false, then we don't enable it. Recall tactics disable `errToSorry`
  withReader (fun ctx => { ctx with errToSorry := ctx.errToSorry && errToSorry }) do
    elabTerm stx expectedType? false

/--
  Try to elaborate `stx` that was postponed by an elaboration method using `Expection.postpone`.
  It returns `true` if it succeeded, and `false` otherwise.
  It is used to implement `synthesizeSyntheticMVars`. -/
private def resumePostponed (savedContext : SavedContext) (stx : Syntax) (mvarId : MVarId) (postponeOnError : Bool) : TermElabM Bool :=
  withRef stx <| mvarId.withContext do
    let s ← saveState
    try
      withSavedContext savedContext do
        let mvarDecl     ← getMVarDecl mvarId
        let expectedType ← instantiateMVars mvarDecl.type
        withInfoHole mvarId do
          let result ← resumeElabTerm stx expectedType (!postponeOnError)
          /- We must ensure `result` has the expected type because it is the one expected by the method that postponed stx.
            That is, the method does not have an opportunity to check whether `result` has the expected type or not. -/
          let result ← withRef stx <| ensureHasType expectedType result
          /- We must perform `occursCheck` here since `result` may contain `mvarId` when it has synthetic `sorry`s. -/
          if (← occursCheck mvarId result) then
            mvarId.assign result
            return true
          else
            return false
    catch
     | ex@(.internal id _) =>
       if id == postponeExceptionId then
         s.restore (restoreInfo := true)
         return false
       else
         throw ex
     | ex@(.error ..) =>
       if postponeOnError then
         s.restore (restoreInfo := true)
         return false
       else
         logException ex
         return true

/--
  Similar to `synthesizeInstMVarCore`, but makes sure that `instMVar` local context and instances
  are used. It also logs any error message produced. -/
private def synthesizePendingInstMVar (instMVar : MVarId) : TermElabM Bool :=
  instMVar.withContext do
    try
      synthesizeInstMVarCore instMVar
    catch
      | ex@(.error ..) => logException ex; return true
      | _              => unreachable!

/--
  Try to synthesize `mvarId` by starting using a default instance with the give privority.
  This method succeeds only if the metavariable of fully synthesized.

  Remark: In the past, we would return a list of pending TC problems, but this was problematic since
  a default instance may create subproblems that cannot be solved.

  Remark: The new approach also has limitations because other pending metavariables are not taken into account
  while backtraking. That is, we fail to synthesize `mvarId` because we reach subproblems that are stuck,
  but we could "unstuck" them if we tried to solve other pending metavariables. Considering all pending metavariables
  into a single backtracking search seems to be too expensive, and potentially generate incomprehensible error messages.
  This is particularly true if we consider pending metavariables for "postponed" elaboration steps.
  Here is an example that demonstrate this issue. The example considers we are using the old `binrel%` elaborator which was
  disconnected from `binop%`.
  ```
  example (a : Int) (b c : Nat) : a = ↑b - ↑c := sorry
  ```
  We have two pending coercions for the `↑` and `HSub ?m.220 ?m.221 ?m.222`.
  When we did not use a backtracking search here, then the homogenous default instance for `HSub`.
  ```
  instance [Sub α] : HSub α α α where
  ```
  would be applied first, and would propagate the expected type `Int` to the pending coercions which would now be unblocked.

  Instead of performing a backtracking search that considers all pending metavariables, we improved the `binrel%` elaborator.
-/
private partial def synthesizeUsingDefaultPrio (mvarId : MVarId) (prio : Nat) : TermElabM Bool :=
  mvarId.withContext do
    let mvarType ← mvarId.getType
    match (← isClass? mvarType) with
    | none => return false
    | some className =>
      match (← getDefaultInstances className) with
      | [] => return false
      | defaultInstances =>
        for (defaultInstance, instPrio) in defaultInstances do
          if instPrio == prio then
            if (← synthesizeUsingDefaultInstance mvarId defaultInstance) then
              return true
        return false
where
  synthesizeUsingDefault (mvarId : MVarId) : TermElabM Bool := do
    for prio in (← getDefaultInstancesPriorities) do
      if (← synthesizeUsingDefaultPrio mvarId prio) then
        return true
    return false

  synthesizePendingInstMVar' (mvarId : MVarId) : TermElabM Bool :=
    commitWhen <| mvarId.withContext do
      try
        synthesizeInstMVarCore mvarId
      catch _ =>
        return false

  synthesizeUsingInstancesStep (mvarIds : List MVarId) : TermElabM (List MVarId) :=
    mvarIds.filterM fun mvarId => do
      if (← synthesizePendingInstMVar' mvarId) then
        return false
      else
        return true

  synthesizeUsingInstances (mvarIds : List MVarId) : TermElabM (List MVarId) := do
    let mvarIds' ← synthesizeUsingInstancesStep mvarIds
    if mvarIds'.length < mvarIds.length then
      synthesizeUsingInstances mvarIds'
    else
      return mvarIds'

  synthesizeUsingDefaultInstance (mvarId : MVarId) (defaultInstance : Name) : TermElabM Bool :=
    commitWhen do
      let candidate ← mkConstWithFreshMVarLevels defaultInstance
      let (mvars, bis, _) ← forallMetaTelescopeReducing (← inferType candidate)
      let candidate := mkAppN candidate mvars
      trace[Elab.defaultInstance] "{toString (mkMVar mvarId)}, {mkMVar mvarId} : {← inferType (mkMVar mvarId)} =?= {candidate} : {← inferType candidate}"
      /- The `coeAtOutParam` feature may mark output parameters of local instances as `syntheticOpaque`.
         This kind of parameter is not assignable by default. We use `withAssignableSyntheticOpaque` to workaround this behavior
         when processing default instances. TODO: try to avoid `withAssignableSyntheticOpaque`. -/
      if (← withAssignableSyntheticOpaque <| isDefEqGuarded (mkMVar mvarId) candidate) then
        -- Succeeded. Collect new TC problems
        trace[Elab.defaultInstance] "isDefEq worked {mkMVar mvarId} : {← inferType (mkMVar mvarId)} =?= {candidate} : {← inferType candidate}"
        let mut pending := []
        for i in [:bis.size] do
          if bis[i]! == BinderInfo.instImplicit then
            pending := mvars[i]!.mvarId! :: pending
        synthesizePending pending
      else
        return false

  synthesizeSomeUsingDefault? (mvarIds : List MVarId) : TermElabM (Option (List MVarId)) := do
    match mvarIds with
    | [] => return none
    | mvarId :: mvarIds =>
      if (← synthesizeUsingDefault mvarId) then
        return mvarIds
      else if let some mvarIds' ← synthesizeSomeUsingDefault? mvarIds then
        return mvarId :: mvarIds'
      else
        return none

  synthesizePending (mvarIds : List MVarId) : TermElabM Bool := do
    let mvarIds ← synthesizeUsingInstances mvarIds
    if mvarIds.isEmpty then return true
    let some mvarIds ← synthesizeSomeUsingDefault? mvarIds | return false
    synthesizePending mvarIds

/-- Used to implement `synthesizeUsingDefault`. This method only consider default instances with the given priority. -/
private def synthesizeSomeUsingDefaultPrio (prio : Nat) : TermElabM Bool := do
  let rec visit (pendingMVars : List MVarId) (pendingMVarsNew : List MVarId) : TermElabM Bool := do
    match pendingMVars with
    | [] => return false
    | mvarId :: pendingMVars =>
      let some mvarDecl ← getSyntheticMVarDecl? mvarId | visit pendingMVars (mvarId :: pendingMVarsNew)
      match mvarDecl.kind with
      | .typeClass =>
        if (← withRef mvarDecl.stx <| synthesizeUsingDefaultPrio mvarId prio) then
          modify fun s => { s with pendingMVars := pendingMVars.reverse ++ pendingMVarsNew }
          return true
        else
          visit pendingMVars (mvarId :: pendingMVarsNew)
      | _ => visit pendingMVars (mvarId :: pendingMVarsNew)
  /- Recall that s.pendingMVars is essentially a stack. The first metavariable was the last one created.
     We want to apply the default instance in reverse creation order. Otherwise,
     `toString 0` will produce a `OfNat String _` cannot be synthesized error. -/
  visit (← get).pendingMVars.reverse []

/--
  Apply default value to any pending synthetic metavariable of kind `SyntheticMVarKind.withDefault`
  Return true if something was synthesized. -/
private def synthesizeUsingDefault : TermElabM Bool := do
  let prioSet ← getDefaultInstancesPriorities
  /- Recall that `prioSet` is stored in descending order -/
  for prio in prioSet do
    if (← synthesizeSomeUsingDefaultPrio prio) then
      return true
  return false

/--
We use this method to report typeclass (and coercion) resolution problems that are "stuck".
That is, there is nothing else to do, and we don't have enough information to synthesize them using TC resolution.
-/
def reportStuckSyntheticMVar (mvarId : MVarId) (ignoreStuckTC := false) : TermElabM Unit := do
  let some mvarSyntheticDecl ← getSyntheticMVarDecl? mvarId | return ()
  withRef mvarSyntheticDecl.stx do
    match mvarSyntheticDecl.kind with
    | .typeClass =>
      unless ignoreStuckTC do
         mvarId.withContext do
          let mvarDecl ← getMVarDecl mvarId
          unless (← MonadLog.hasErrors) do
            throwError "typeclass instance problem is stuck, it is often due to metavariables{indentExpr mvarDecl.type}"
    | .coe header expectedType e f? =>
      mvarId.withContext do
        throwTypeMismatchError header expectedType (← inferType e) e f?
          m!"failed to create type class instance for{indentExpr (← getMVarDecl mvarId).type}"
    | _ => unreachable! -- TODO handle other cases.

/--
  Report an error for each synthetic metavariable that could not be resolved.
  Remark: we set `ignoreStuckTC := true` when elaborating `simp` arguments.
-/
private def reportStuckSyntheticMVars (ignoreStuckTC := false) : TermElabM Unit := do
  let pendingMVars ← modifyGet fun s => (s.pendingMVars, { s with pendingMVars := [] })
  for mvarId in pendingMVars do
    reportStuckSyntheticMVar mvarId ignoreStuckTC

private def getSomeSynthethicMVarsRef : TermElabM Syntax := do
  for mvarId in (← get).pendingMVars do
    if let some decl ← getSyntheticMVarDecl? mvarId then
      if decl.stx.getPos?.isSome then
        return decl.stx
  return .missing

/--
  Generate an nicer error message for stuck universe constraints.
-/
private def throwStuckAtUniverseCnstr : TermElabM Unit := do
  -- This code assumes `entries` is not empty. Note that `processPostponed` uses `exceptionOnFailure` to guarantee this property
  let entries ← getPostponed
  let mut found : HashSet (Level × Level) := {}
  let mut uniqueEntries := #[]
  for entry in entries do
    let mut lhs := entry.lhs
    let mut rhs := entry.rhs
    if Level.normLt rhs lhs then
      (lhs, rhs) := (rhs, lhs)
    unless found.contains (lhs, rhs) do
      found := found.insert (lhs, rhs)
      uniqueEntries := uniqueEntries.push entry
  for i in [1:uniqueEntries.size] do
    logErrorAt uniqueEntries[i]!.ref (← mkLevelStuckErrorMessage uniqueEntries[i]!)
  throwErrorAt uniqueEntries[0]!.ref (← mkLevelStuckErrorMessage uniqueEntries[0]!)

/--
  Try to solve postponed universe constraints, and throws an exception if there are stuck constraints.

  Remark: in previous versions, each `isDefEq u v` invocation would fail if there
  were pending universe level constraints. With this old approach, we were not able
  to process
  ```
  Functor.map Prod.fst (x s)
  ```
  because after elaborating `Prod.fst` and trying to ensure its type
  match the expected one, we would be stuck at the universe constraint:
  ```
  u =?= max u ?v
  ```
  Another benefit of using `withoutPostponingUniverseConstraints` is better error messages. Instead
  of getting a mysterious type mismatch constraint, we get a list of
  universe contraints the system is stuck at.
-/
private def processPostponedUniverseContraints : TermElabM Unit := do
  unless (← processPostponed (mayPostpone := false) (exceptionOnFailure := true)) do
    throwStuckAtUniverseCnstr

/--
  Remove `mvarId` from the `syntheticMVars` table. We use this method after
  the metavariable has been synthesized.
-/
private def markAsResolved (mvarId : MVarId) : TermElabM Unit :=
  modify fun s => { s with syntheticMVars := s.syntheticMVars.erase mvarId }

mutual

  /--
  Try to synthesize a term `val` using the tactic code `tacticCode`, and then assign `mvarId := val`.
  -/
  partial def runTactic (mvarId : MVarId) (tacticCode : Syntax) : TermElabM Unit := withoutAutoBoundImplicit do
    /- Recall, `tacticCode` is the whole `by ...` expression. -/
    let code := tacticCode[1]
    instantiateMVarDeclMVars mvarId
    /-
    TODO: consider using `runPendingTacticsAt` at `mvarId` local context and target type.
    Issue #1380 demonstrates that the goal may still contain pending metavariables.
    It happens in the following scenario we have a term `foo A (by tac)` where `A` has been postponed
    and contains nested `by ...` terms. The pending metavar list contains two metavariables: ?m1 (for `A`) and
    `?m2` (for `by tac`). When `A` is resumed, it creates a new metavariable `?m3` for the nested `by ...` term in `A`.
    `?m3` is after `?m2` in the to-do list. Then, we execute `by tac` for synthesizing `?m2`, but its type depends on
    `?m3`. We have considered putting `?m3` at `?m2` place in the to-do list, but this is not super robust.
    The ideal solution is to make sure a tactic "resolves" all pending metavariables nested in their local contex and target type
    before starting tactic execution. The procedure would be a generalization of `runPendingTacticsAt`. We can try to combine
    it with `instantiateMVarDeclMVars` to make sure we do not perform two traversals.
    Regarding issue #1380, we addressed the issue by avoiding the elaboration postponement step. However, the same issue can happen
    in more complicated scenarios.
    -/
    try
      let remainingGoals ← withInfoHole mvarId <| Tactic.run mvarId do
        withTacticInfoContext tacticCode do
          -- also put an info node on the `by` keyword specifically -- the token may be `canonical` and thus shown in the info
          -- view even though it is synthetic while a node like `tacticCode` never is (#1990)
          withTacticInfoContext tacticCode[0] do
            evalTactic code
        synthesizeSyntheticMVars (mayPostpone := false)
      unless remainingGoals.isEmpty do
        reportUnsolvedGoals remainingGoals
    catch ex =>
      if (← read).errToSorry then
        for mvarId in (← getMVars (mkMVar mvarId)) do
          mvarId.admit
        logException ex
      else
        throw ex

  /-- Try to synthesize the given pending synthetic metavariable. -/
  private partial def synthesizeSyntheticMVar (mvarId : MVarId) (postponeOnError : Bool) (runTactics : Bool) : TermElabM Bool := do
    let some mvarSyntheticDecl ← getSyntheticMVarDecl? mvarId | return true -- The metavariable has already been synthesized
    withRef mvarSyntheticDecl.stx do
    match mvarSyntheticDecl.kind with
    | .typeClass => synthesizePendingInstMVar mvarId
    | .coe _header? expectedType e _f? => mvarId.withContext do
      if (← withDefault do isDefEq (← inferType e) expectedType) then
        -- Types may be defeq now due to mvar assignments, type class
        -- defaulting, etc.
        if (← occursCheck mvarId e) then
          mvarId.assign e
          return true
      if let .some coerced ← coerce? e expectedType then
        if (← occursCheck mvarId coerced) then
          mvarId.assign coerced
          return true
      return false
    -- NOTE: actual processing at `synthesizeSyntheticMVarsAux`
    | .postponed savedContext => resumePostponed savedContext mvarSyntheticDecl.stx mvarId postponeOnError
    | .tactic tacticCode savedContext =>
      withSavedContext savedContext do
        if runTactics then
          runTactic mvarId tacticCode
          return true
        else
          return false
  /--
    Try to synthesize the current list of pending synthetic metavariables.
    Return `true` if at least one of them was synthesized. -/
  private partial def synthesizeSyntheticMVarsStep (postponeOnError : Bool) (runTactics : Bool) : TermElabM Bool := do
    let ctx ← read
    traceAtCmdPos `Elab.resuming fun _ =>
      m!"resuming synthetic metavariables, mayPostpone: {ctx.mayPostpone}, postponeOnError: {postponeOnError}"
    let pendingMVars    := (← get).pendingMVars
    let numSyntheticMVars := pendingMVars.length
    -- We reset `pendingMVars` because new synthetic metavariables may be created by `synthesizeSyntheticMVar`.
    modify fun s => { s with pendingMVars := [] }
    -- Recall that `pendingMVars` is a list where head is the most recent pending synthetic metavariable.
    -- We use `filterRevM` instead of `filterM` to make sure we process the synthetic metavariables using the order they were created.
    -- It would not be incorrect to use `filterM`.
    let remainingPendingMVars ← pendingMVars.filterRevM fun mvarId => do
       -- We use `traceM` because we want to make sure the metavar local context is used to trace the message
       traceM `Elab.postpone (mvarId.withContext do addMessageContext m!"resuming {mkMVar mvarId}")
       let succeeded ← synthesizeSyntheticMVar mvarId postponeOnError runTactics
       if succeeded then markAsResolved mvarId
       trace[Elab.postpone] if succeeded then format "succeeded" else format "not ready yet"
       pure !succeeded
    -- Merge new synthetic metavariables with `remainingPendingMVars`, i.e., metavariables that still couldn't be synthesized
    modify fun s => { s with pendingMVars := s.pendingMVars ++ remainingPendingMVars }
    return numSyntheticMVars != remainingPendingMVars.length

  /--
    Try to process pending synthetic metavariables. If `mayPostpone == false`,
    then `pendingMVars` is `[]` after executing this method.

    It keeps executing `synthesizeSyntheticMVarsStep` while progress is being made.
    If `mayPostpone == false`, then it applies default instances to `SyntheticMVarKind.typeClass` (if available)
    metavariables that are still unresolved, and then tries to resolve metavariables
    with `mayPostpone == false`. That is, we force them to produce error messages and/or commit to
    a "best option". If, after that, we still haven't made progress, we report "stuck" errors.

    Remark: we set `ignoreStuckTC := true` when elaborating `simp` arguments. Then,
    pending TC problems become implicit parameters for the simp theorem.
  -/
  partial def synthesizeSyntheticMVars (mayPostpone := true) (ignoreStuckTC := false) : TermElabM Unit := do
    let rec loop (_ : Unit) : TermElabM Unit := do
      withRef (← getSomeSynthethicMVarsRef) <| withIncRecDepth do
        unless (← get).pendingMVars.isEmpty do
          if ← synthesizeSyntheticMVarsStep (postponeOnError := false) (runTactics := false) then
            loop ()
          else if !mayPostpone then
            /- Resume pending metavariables with "elaboration postponement" disabled.
               We postpone elaboration errors in this step by setting `postponeOnError := true`.
               Example:
               ```
               #check let x := ⟨1, 2⟩; Prod.fst x
               ```
               The term `⟨1, 2⟩` can't be elaborated because the expected type is not know.
               The `x` at `Prod.fst x` is not elaborated because the type of `x` is not known.
               When we execute the following step with "elaboration postponement" disabled,
               the elaborator fails at `⟨1, 2⟩` and postpones it, and succeeds at `x` and learns
               that its type must be of the form `Prod ?α ?β`.

               Recall that we postponed `x` at `Prod.fst x` because its type it is not known.
               We the type of `x` may learn later its type and it may contain implicit and/or auto arguments.
               By disabling postponement, we are essentially giving up the opportunity of learning `x`s type
               and assume it does not have implict and/or auto arguments. -/
            if ← withoutPostponing <| synthesizeSyntheticMVarsStep (postponeOnError := true) (runTactics := false) then
              loop ()
            else if ← synthesizeUsingDefault then
              loop ()
            else if ← withoutPostponing <| synthesizeSyntheticMVarsStep (postponeOnError := false) (runTactics := false) then
              loop ()
            else if ← synthesizeSyntheticMVarsStep (postponeOnError := false) (runTactics := true) then
              loop ()
            else
              reportStuckSyntheticMVars ignoreStuckTC
    loop ()
    unless mayPostpone do
     processPostponedUniverseContraints
end

def synthesizeSyntheticMVarsNoPostponing (ignoreStuckTC := false) : TermElabM Unit :=
  synthesizeSyntheticMVars (mayPostpone := false) (ignoreStuckTC := ignoreStuckTC)

/-- Keep invoking `synthesizeUsingDefault` until it returns false. -/
private partial def synthesizeUsingDefaultLoop : TermElabM Unit := do
  if (← synthesizeUsingDefault) then
    synthesizeSyntheticMVars (mayPostpone := true)
    synthesizeUsingDefaultLoop

def synthesizeSyntheticMVarsUsingDefault : TermElabM Unit := do
  synthesizeSyntheticMVars (mayPostpone := true)
  synthesizeUsingDefaultLoop

private partial def withSynthesizeImp {α} (k : TermElabM α) (mayPostpone : Bool) (synthesizeDefault : Bool) : TermElabM α := do
  let pendingMVarsSaved := (← get).pendingMVars
  modify fun s => { s with pendingMVars := [] }
  try
    let a ← k
    synthesizeSyntheticMVars mayPostpone
    if mayPostpone && synthesizeDefault then
      synthesizeUsingDefaultLoop
    return a
  finally
    modify fun s => { s with pendingMVars := s.pendingMVars ++ pendingMVarsSaved }

/--
  Execute `k`, and synthesize pending synthetic metavariables created while executing `k` are solved.
  If `mayPostpone == false`, then all of them must be synthesized.
  Remark: even if `mayPostpone == true`, the method still uses `synthesizeUsingDefault` -/
@[inline] def withSynthesize [MonadFunctorT TermElabM m] [Monad m] (k : m α) (mayPostpone := false) : m α :=
  monadMap (m := TermElabM) (withSynthesizeImp · mayPostpone (synthesizeDefault := true)) k

/-- Similar to `withSynthesize`, but sets `mayPostpone` to `true`, and do not use `synthesizeUsingDefault` -/
@[inline] def withSynthesizeLight [MonadFunctorT TermElabM m] [Monad m] (k : m α) : m α :=
  monadMap (m := TermElabM) (withSynthesizeImp · (mayPostpone := true) (synthesizeDefault := false)) k

/-- Elaborate `stx`, and make sure all pending synthetic metavariables created while elaborating `stx` are solved. -/
def elabTermAndSynthesize (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr :=
  withRef stx do
    instantiateMVars (← withSynthesize <| elabTerm stx expectedType?)

/--
Collect unassigned metavariables at `e` that have associated tactic blocks, and then execute them using `runTactic`.
We use this method at the `match .. with` elaborator when it cannot be postponed anymore, but it is still waiting
the result of a tactic block.
-/
def runPendingTacticsAt (e : Expr) : TermElabM Unit := do
  for mvarId in (← getMVars e) do
    let mvarId ← getDelayedMVarRoot mvarId
    if let some { kind := .tactic tacticCode savedContext, .. } ← getSyntheticMVarDecl? mvarId then
      withSavedContext savedContext do
        runTactic mvarId tacticCode
        markAsResolved mvarId

builtin_initialize
  registerTraceClass `Elab.resume

end Lean.Elab.Term


open classical
variables (α : Type) (p q : α → Prop)
variable a : α
variable r : Prop
theorem c4_1 : r→(∃ x:α,r):=
    begin
        rw[exists_],
    end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.applicative
import data.list.forall2
import data.set.functor

/-!
# Traversable instances

This file provides instances of `traversable` for types from the core library: `option`, `list` and
`sum`.
-/

universes u v

section option

open functor

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

lemma option.id_traverse {α} (x : option α) : option.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
lemma option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : option α) :
  option.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (option.traverse f <$> option.traverse g x) :=
by cases x; simp! with functor_norm; refl

lemma option.traverse_eq_map_id {α β} (f : α → β) (x : option α) :
  traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by cases x; refl

variable (η : applicative_transformation F G)

lemma option.naturality {α β} (f : α → F β) (x : option α) :
  η (option.traverse f x) = option.traverse (@η _ ∘ f) x :=
by cases x with x; simp! [*] with functor_norm

end option

instance : is_lawful_traversable option :=
{ id_traverse := @option.id_traverse,
  comp_traverse := @option.comp_traverse,
  traverse_eq_map_id := @option.traverse_eq_map_id,
  naturality := @option.naturality,
  .. option.is_lawful_monad }

namespace list

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

section
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor list

protected

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : list α) :
  list.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (list.traverse f <$> list.traverse g x) :=
by induction x; simp! * with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : list α) :
  list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : list α) :
  η (list.traverse f x) = list.traverse (@η _ ∘ f) x :=
by induction x; simp! * with functor_norm
open nat

instance : is_lawful_traversable.{u} list :=
{ id_traverse := @list.id_traverse,
  comp_traverse := @list.comp_traverse,
  traverse_eq_map_id := @list.traverse_eq_map_id,
  naturality := @list.naturality,
  .. list.is_lawful_monad }
end

section traverse
variables {α' β' : Type u} (f : α' → F β')

@[simp] lemma traverse_nil : traverse f ([] : list α') = (pure [] : F (list β')) := rfl

@[simp] lemma traverse_cons (a : α') (l : list α') :
  traverse f (a :: l) = (::) <$> f a <*> traverse f l := rfl

variables [is_lawful_applicative F]

@[simp] lemma traverse_append :
  ∀ (as bs : list α'), traverse f (as ++ bs) = (++) <$> traverse f as <*> traverse f bs
| [] bs :=
  have has_append.append ([] : list β') = id, by funext; refl,
  by simp [this] with functor_norm
| (a :: as) bs := by simp [traverse_append as bs] with functor_norm; congr

lemma mem_traverse {f : α' → set β'} :
  ∀(l : list α') (n : list β'), n ∈ traverse f l ↔ forall₂ (λb a, b ∈ f a) n l
| []      []      := by simp
| (a::as) []      := by simp
| []      (b::bs) := by simp
| (a::as) (b::bs) := by simp [mem_traverse as bs]

end traverse

end list

namespace sum

section traverse
variables {σ : Type u}
variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons)

protected lemma traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
  sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; refl

variables [is_lawful_applicative F] [is_lawful_applicative G]

protected lemma id_traverse {σ α} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
  sum.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (sum.traverse f <$> sum.traverse g x) :=
by cases x; simp! [sum.traverse,map_id] with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
  sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

protected lemma map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
  (<$>) f <$> sum.traverse g x = sum.traverse ((<$>) f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; congr; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : σ ⊕ α) :
  η (sum.traverse f x) = sum.traverse (@η _ ∘ f) x :=
by cases x; simp! [sum.traverse] with functor_norm

end traverse

instance {σ : Type u} : is_lawful_traversable.{u} (sum σ) :=
{ id_traverse := @sum.id_traverse σ,
  comp_traverse := @sum.comp_traverse σ,
  traverse_eq_map_id := @sum.traverse_eq_map_id σ,
  naturality := @sum.naturality σ,
  .. sum.is_lawful_monad }

end sum


import Lean.CoreM

#eval Lean.addDecl <| .mutualDefnDecl [{
  name := `False_intro
  levelParams := []
  type := .const ``False []
  value := .const `False_intro []
  hints := .opaque
  safety := .partial
}]

theorem False.intro : False := False_intro


import Std.Tactic.SeqFocus

example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by
  constructor
  constructor
  -- error: too many tactics
  fail_if_success map_tacs [trivial, exact ⟨0, rfl⟩, trivial, trivial]
  -- error: not enough tactics
  fail_if_success map_tacs [trivial, exact ⟨0, rfl⟩]
  map_tacs [trivial, exact ⟨0, rfl⟩, trivial]

example : ((True ∧ True) ∧ (∃ x : Nat, x = x)) ∧ (True ∧ (∃ x : Nat, x = x)) := by
  constructor
  constructor
  map_tacs [(constructor; trivial), exact ⟨0, rfl⟩, constructor]
  trivial
  trivial
  exact ⟨0, rfl⟩

example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by
  constructor
  -- error: not enough tactics
  fail_if_success constructor <;> [trivial]
  map_tacs [constructor <;> [trivial, exact ⟨0, rfl⟩], constructor]


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Selsam
-/
import Search.Inspect.Basic
import Search.NTactic.Basic
import Lean

namespace Search
namespace NTactic

def chooseBoolsDoNothing : NTacticM Unit := do
  Lean.Meta.setMCtx {}
  let x ← choice #[false, true]
  if x ∧ ¬ x then deadend else pure ()

example : ∀ (n : Nat), 2 * n + 1 < 3 * n + 2 :=
  sorry
  -- TODO: this will try to execute `inspect` in the interpreter
  -- (right now it only works in compiled code)
  -- by search chooseBoolsDoNothing

end NTactic
end Search


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import algebra.group.defs
import control.functor

/-!
# `applicative` instances

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

This file provides `applicative` instances for concrete functors:
* `id`
* `functor.comp`
* `functor.const`
* `functor.add_const`
-/

universes u v w

section lemmas

open function

variables {F : Type u → Type v}
variables [applicative F] [is_lawful_applicative F]
variables {α β γ σ : Type u}

lemma applicative.map_seq_map (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) :
  (f <$> x) <*> (g <$> y) = (flip (∘) g ∘ f) <$> x <*> y :=
by simp [flip] with functor_norm

lemma applicative.pure_seq_eq_map' (f : α → β) : (<*>) (pure f : F (α → β)) = (<$>) f :=
by ext; simp with functor_norm

theorem applicative.ext {F} : ∀ {A1 : applicative F} {A2 : applicative F}
  [@is_lawful_applicative F A1] [@is_lawful_applicative F A2]
  (H1 : ∀ {α : Type u} (x : α),
    @has_pure.pure _ A1.to_has_pure _ x = @has_pure.pure _ A2.to_has_pure _ x)
  (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α),
    @has_seq.seq _ A1.to_has_seq _ _ f x = @has_seq.seq _ A2.to_has_seq _ _ f x),
  A1 = A2
| {to_functor := F1, seq := s1, pure := p1, seq_left := sl1, seq_right := sr1}
  {to_functor := F2, seq := s2, pure := p2, seq_left := sl2, seq_right := sr2} L1 L2 H1 H2 :=
begin
  obtain rfl : @p1 = @p2, {funext α x, apply H1},
  obtain rfl : @s1 = @s2, {funext α β f x, apply H2},
  cases L1, cases L2,
  obtain rfl : F1 = F2,
  { resetI, apply functor.ext, intros,
    exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _) },
  congr; funext α β x y,
  { exact (L1_seq_left_eq _ _).trans (L2_seq_left_eq _ _).symm },
  { exact (L1_seq_right_eq _ _).trans (L2_seq_right_eq _ _).symm }
end

end lemmas

instance : is_comm_applicative id :=
by refine { .. }; intros; refl

namespace functor
namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

variables [is_lawful_applicative F] [is_lawful_applicative G]
variables {α β γ : Type v}

lemma map_pure (f : α → β) (x : α) : (f <$> pure x : comp F G β) = pure (f x) :=
comp.ext $ by simp

lemma seq_pure (f : comp F G (α → β)) (x : α) :
  f <*> pure x = (λ g : α → β, g x) <$> f :=
comp.ext $ by simp [(∘)] with functor_norm

lemma pure_seq_eq_map (f : α → β) (x : comp F G α) :
  pure f <*> x = f <$> x :=
comp.ext $ by simp [applicative.pure_seq_eq_map'] with functor_norm

instance : is_lawful_applicative (comp F G) :=
{ pure_seq_eq_map := @comp.pure_seq_eq_map F G _ _ _ _,
  map_pure := @comp.map_pure F G _ _ _ _,
  seq_pure := @comp.seq_pure F G _ _ _ _,
  seq_assoc := @comp.seq_assoc F G _ _ _ _ }

theorem applicative_id_comp {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative id F _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative id F _ _ _ _) _
  (λ α x, rfl) (λ α β f x, rfl)

theorem applicative_comp_id {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative F id _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative F id _ _ _ _) _
  (λ α x, rfl) (λ α β f x, show id <$> f <*> x = f <*> x, by rw id_map)

open is_comm_applicative

instance {f : Type u → Type w} {g : Type v → Type u}
  [applicative f] [applicative g]
  [is_comm_applicative f] [is_comm_applicative g] :
  is_comm_applicative (comp f g) :=
by { refine { .. @comp.is_lawful_applicative f g _ _ _ _, .. },
     intros, casesm* comp _ _ _, simp! [map,has_seq.seq] with functor_norm,
     rw [commutative_map],
     simp [comp.mk,flip,(∘)] with functor_norm,
     congr, funext, rw [commutative_map], congr }

end comp
end functor

open functor

@[functor_norm]
lemma comp.seq_mk {α β : Type w}
  {f : Type u → Type v} {g : Type w → Type u}
  [applicative f] [applicative g]
  (h : f (g (α → β))) (x : f (g α)) :
  comp.mk h <*> comp.mk x = comp.mk (has_seq.seq <$> h <*> x) := rfl

instance {α} [has_one α] [has_mul α] : applicative (const α) :=
{ pure := λ β x, (1 : α),
  seq := λ β γ f x, (f * x : α) }

instance {α} [monoid α] : is_lawful_applicative (const α) :=
by refine { .. }; intros; simp [mul_assoc, (<$>), (<*>), pure]

instance {α} [has_zero α] [has_add α] : applicative (add_const α) :=
{ pure := λ β x, (0 : α),
  seq := λ β γ f x, (f + x : α) }

instance {α} [add_monoid α] : is_lawful_applicative (add_const α) :=
by refine { .. }; intros; simp [add_assoc, (<$>), (<*>), pure]


import CodeAction.Interface
import StatementAutoformalisation.Translate
import StatementAutoformalisation.Config.FixedPrompts

namespace Custom

def LLMParams : LLM.Params :=
{
  openAIModel := "gpt-3.5-turbo",
  temperature := 2,
  n := 1,
  maxTokens := 200,
  stopTokens := #[":=", "\n\n/-", "\n/-", "/-"]
  systemMessage :=
  "You are a coding assistant who translates from natural language to Lean Theorem Prover code following examples.
   Follow EXACTLY the examples given."
}

def SentenceSimilarityParams : SentenceSimilarity.Params :=
{
  source := "data/prompts.json",
  sentenceTransformersModel := "all-mpnet-base-v2",
  kind := "theorem",
  field := "doc_string",
  nSim := 10
}

def KeywordExtractionParams : KeywordExtraction.Params :=
{
  nKw := 0
}

def PromptParams : Prompt.Params :=
{
  toLLMParams := LLMParams,
  toSentenceSimilarityParams := #[SentenceSimilarityParams],
  toKeywordExtractionParams := #[KeywordExtractionParams],
  fixedPrompts := leanChatPrompts,
  useNames := #[],
  useModules := #[],
  useMainCtx? := false,
  printMessage := DeclarationWithDocstring.toMessage
  mkSuffix := id,
  processCompletion := fun comment completion => s!"{printAsComment comment}\n{completion}"
}

def InterfaceParams : Interface.Params DeclarationWithDocstring :=
{
  title := "Translate comment to Lean theorem statement (with custom settings).",
  nearestOccurrence? := nearestComment,
  extractText? := extractCommentText?,
  action := fun stmt =>
    Prompt.typecorrectTranslations ⟨PromptParams, stmt⟩ >>= (pure ·[0]!),
  postProcess := fun _ => DeclarationWithDocstring.toString
}

@[codeActionProvider] def Action := performCodeAction InterfaceParams

end Custom


import Lean
syntax (name := test) "test%" ident : command

open Lean.Elab
open Lean.Elab.Command

@[commandElab test] def elabTest : CommandElab := fun stx => do
  let id ← resolveGlobalConstNoOverloadWithInfo stx[1]
  liftTermElabM none do
    IO.println (repr (← Lean.Meta.Match.getEquationsFor id))
  return ()

def f (x : List Nat) : Nat :=
  match x with
  | [] => 1
  | [a] => 2
  | _ => 3

test% f.match_1
#check @f.match_1
#check @f.match_1.splitter

theorem ex (x : List Nat) : f x > 0 := by
  simp [f]
  split <;> decide

test% Std.RBNode.balance1.match_1
#check @Std.RBNode.balance1.match_1.splitter


import tactic.basic tactic

open tactic

#print tactic.local_context
#print expr.is_aux_decl
#print tactic.clear
#print tactic.interactive.clear

namespace tactic.interactive

meta def clear_aux_decl_aux : list expr → tactic unit
| []     := skip
| (e::l) := do cond e.is_aux_decl (tactic.clear e) skip, clear_aux_decl_aux l

meta def clear_aux_decl : tactic unit :=
local_context >>= clear_aux_decl_aux

end tactic.interactive

meta def h : tactic unit :=
do l ← local_context, trace (l.filter (λ e : expr, e.is_aux_decl)).length

example (x y : ℕ) (h₁ : ∃ n : ℕ, n * 1 = 2) (h₂ : 1 + 1 = 2 → x * 1 = y) : x = y :=
let ⟨n, hn⟩ := h₁ in
begin
  clear_aux_decl,
  finish
end


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison

Facts about epimorphisms and monomorphisms.

The definitions of `epi` and `mono` are in `category_theory.category`,
since they are used by some lemmas for `iso`, which is used everywhere.
-/
import category_theory.adjunction.basic
import category_theory.opposites

universes v₁ v₂ u₁ u₂

namespace category_theory

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

section
variables {D : Type u₂} [category.{v₂} D]

lemma left_adjoint_preserves_epi {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
  {X Y : C} {f : X ⟶ Y} (hf : epi f) : epi (F.map f) :=
begin
  constructor,
  intros Z g h H,
  replace H := congr_arg (adj.hom_equiv X Z) H,
  rwa [adj.hom_equiv_naturality_left, adj.hom_equiv_naturality_left,
    cancel_epi, equiv.apply_eq_iff_eq] at H
end

lemma right_adjoint_preserves_mono {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
  {X Y : D} {f : X ⟶ Y} (hf : mono f) : mono (G.map f) :=
begin
  constructor,
  intros Z g h H,
  replace H := congr_arg (adj.hom_equiv Z Y).symm H,
  rwa [adj.hom_equiv_naturality_right_symm, adj.hom_equiv_naturality_right_symm,
    cancel_mono, equiv.apply_eq_iff_eq] at H
end

instance is_equivalence.epi_map {F : C ⥤ D} [is_left_adjoint F] {X Y : C} {f : X ⟶ Y}
  [h : epi f] : epi (F.map f) :=
left_adjoint_preserves_epi (adjunction.of_left_adjoint F) h

instance is_equivalence.mono_map {F : C ⥤ D} [is_right_adjoint F] {X Y : C} {f : X ⟶ Y}
  [h : mono f] : mono (F.map f) :=
right_adjoint_preserves_mono (adjunction.of_right_adjoint F) h

lemma faithful_reflects_epi (F : C ⥤ D) [faithful F] {X Y : C} {f : X ⟶ Y}
  (hf : epi (F.map f)) : epi f :=
⟨λ Z g h H, F.map_injective $
  by rw [←cancel_epi (F.map f), ←F.map_comp, ←F.map_comp, H]⟩

lemma faithful_reflects_mono (F : C ⥤ D) [faithful F] {X Y : C} {f : X ⟶ Y}
  (hf : mono (F.map f)) : mono f :=
⟨λ Z g h H, F.map_injective $
  by rw [←cancel_mono (F.map f), ←F.map_comp, ←F.map_comp, H]⟩
end

/--
A split monomorphism is a morphism `f : X ⟶ Y` admitting a retraction `retraction f : Y ⟶ X`
such that `f ≫ retraction f = 𝟙 X`.

Every split monomorphism is a monomorphism.
-/
class split_mono {X Y : C} (f : X ⟶ Y) :=
(retraction : Y ⟶ X)
(id' : f ≫ retraction = 𝟙 X . obviously)

/--
A split epimorphism is a morphism `f : X ⟶ Y` admitting a section `section_ f : Y ⟶ X`
such that `section_ f ≫ f = 𝟙 Y`.
(Note that `section` is a reserved keyword, so we append an underscore.)

Every split epimorphism is an epimorphism.
-/
class split_epi {X Y : C} (f : X ⟶ Y) :=
(section_ : Y ⟶ X)
(id' : section_ ≫ f = 𝟙 Y . obviously)

/-- The chosen retraction of a split monomorphism. -/
def retraction {X Y : C} (f : X ⟶ Y) [split_mono f] : Y ⟶ X := split_mono.retraction f
@[simp, reassoc]
lemma split_mono.id {X Y : C} (f : X ⟶ Y) [split_mono f] : f ≫ retraction f = 𝟙 X :=
split_mono.id'
/-- The retraction of a split monomorphism is itself a split epimorphism. -/
instance retraction_split_epi {X Y : C} (f : X ⟶ Y) [split_mono f] : split_epi (retraction f) :=
{ section_ := f }

/-- A split mono which is epi is an iso. -/
lemma is_iso_of_epi_of_split_mono {X Y : C} (f : X ⟶ Y) [split_mono f] [epi f] : is_iso f :=
⟨⟨retraction f, ⟨by simp, by simp [← cancel_epi f]⟩⟩⟩

/--
The chosen section of a split epimorphism.
(Note that `section` is a reserved keyword, so we append an underscore.)
-/
def section_ {X Y : C} (f : X ⟶ Y) [split_epi f] : Y ⟶ X := split_epi.section_ f
@[simp, reassoc]
lemma split_epi.id {X Y : C} (f : X ⟶ Y) [split_epi f] : section_ f ≫ f = 𝟙 Y :=
split_epi.id'
/-- The section of a split epimorphism is itself a split monomorphism. -/
instance section_split_mono {X Y : C} (f : X ⟶ Y) [split_epi f] : split_mono (section_ f) :=
{ retraction := f }

/-- A split epi which is mono is an iso. -/
lemma is_iso_of_mono_of_split_epi {X Y : C} (f : X ⟶ Y) [mono f] [split_epi f] : is_iso f :=
⟨⟨section_ f, ⟨by simp [← cancel_mono f], by simp⟩⟩⟩

/-- Every iso is a split mono. -/
@[priority 100]
noncomputable
instance split_mono.of_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : split_mono f :=
{ retraction := inv f }

/-- Every iso is a split epi. -/
@[priority 100]
noncomputable
instance split_epi.of_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : split_epi f :=
{ section_ := inv f }

/-- Every split mono is a mono. -/
@[priority 100]
instance split_mono.mono {X Y : C} (f : X ⟶ Y) [split_mono f] : mono f :=
{ right_cancellation := λ Z g h w, begin replace w := w =≫ retraction f, simpa using w, end }

/-- Every split epi is an epi. -/
@[priority 100]
instance split_epi.epi {X Y : C} (f : X ⟶ Y) [split_epi f] : epi f :=
{ left_cancellation := λ Z g h w, begin replace w := section_ f ≫= w, simpa using w, end }

/-- Every split mono whose retraction is mono is an iso. -/
lemma is_iso.of_mono_retraction {X Y : C} {f : X ⟶ Y} [split_mono f] [mono $ retraction f]
  : is_iso f :=
⟨⟨retraction f, ⟨by simp, (cancel_mono_id $ retraction f).mp (by simp)⟩⟩⟩

/-- Every split epi whose section is epi is an iso. -/
lemma is_iso.of_epi_section {X Y : C} {f : X ⟶ Y} [split_epi f] [epi $ section_ f]
  : is_iso f :=
⟨⟨section_ f, ⟨(cancel_epi_id $ section_ f).mp (by simp), by simp⟩⟩⟩

instance unop_mono_of_epi {A B : Cᵒᵖ} (f : A ⟶ B) [epi f] : mono f.unop :=
⟨λ Z g h eq, quiver.hom.op_inj ((cancel_epi f).1 (quiver.hom.unop_inj eq))⟩

instance unop_epi_of_mono {A B : Cᵒᵖ} (f : A ⟶ B) [mono f] : epi f.unop :=
⟨λ Z g h eq, quiver.hom.op_inj ((cancel_mono f).1 (quiver.hom.unop_inj eq))⟩

instance op_mono_of_epi {A B : C} (f : A ⟶ B) [epi f] : mono f.op :=
⟨λ Z g h eq, quiver.hom.unop_inj ((cancel_epi f).1 (quiver.hom.op_inj eq))⟩

instance op_epi_of_mono {A B : C} (f : A ⟶ B) [mono f] : epi f.op :=
⟨λ Z g h eq, quiver.hom.unop_inj ((cancel_mono f).1 (quiver.hom.op_inj eq))⟩

section
variables {D : Type u₂} [category.{v₂} D]

/-- Split monomorphisms are also absolute monomorphisms. -/
instance {X Y : C} (f : X ⟶ Y) [split_mono f] (F : C ⥤ D) : split_mono (F.map f) :=
{ retraction := F.map (retraction f),
  id' := by { rw [←functor.map_comp, split_mono.id, functor.map_id], } }

/-- Split epimorphisms are also absolute epimorphisms. -/
instance {X Y : C} (f : X ⟶ Y) [split_epi f] (F : C ⥤ D) : split_epi (F.map f) :=
{ section_ := F.map (section_ f),
  id' := by { rw [←functor.map_comp, split_epi.id, functor.map_id], } }
end

end category_theory


structure A where
  x : Nat
  w : Nat

structure B extends A where
  y : Nat

structure C extends B where
  z : Nat

def f1 (c : C) (a : A) : C :=
  { c with toA := a, x := 0 }  -- Error, `toA` and `x` are both updates to field `x`

def f2 (c : C) (a : A) : C :=
  { c with toA := a }

def f3 (c : C) (a : A) : C :=
  { a, c with x := 0 }

theorem ex1 (a : A) (c : C) : (f3 c a).x = 0 :=
  rfl

theorem ex2 (a : A) (c : C) : (f3 c a).w = a.w :=
  rfl

def f4 (c : C) (a : A) : C :=
  { c, a with x := 0 } -- TODO: generate error that `a` was not used?

theorem ex3 (a : A) (c : C) : (f4 c a).w = c.w :=
  rfl

theorem ex4 (a : A) (c : C) : (f4 c a).x = 0 :=
  rfl

def f5 (c : C) (a : A) :=
  { c, a with x := 0 }

#check f5

def f6 (c : C) (a : A) :=
  { a, c with x := 0 }

#check f6


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

Quotient types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.sigma.basic
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.data.setoid

universes u v u_a u_b u_c

namespace Mathlib

/- We import propext here, otherwise we would need a quot.lift for propositions. -/

-- iff can now be used to do substitutions in a calculation

theorem iff_subst {a : Prop} {b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  propext h₁ ▸ h₂

namespace quot

axiom sound {α : Sort u} {r : α → α → Prop} {a : α} {b : α} : r a b → Quot.mk r a = Quot.mk r bprotected theorem lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) (c : ∀ (a b : α), r a b → f a = f b) (a : α) : Quot.lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem ind_beta {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (p : ∀ (a : α), β (Quot.mk r a)) (a : α) : Quot.ind p (Quot.mk r a) = p a :=
  rfl

protected def lift_on {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : ∀ (a b : α), r a b → f a = f b) : β :=
  Quot.lift f c q

protected theorem induction_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (q : Quot r) (h : ∀ (a : α), β (Quot.mk r a)) : β q :=
  Quot.ind h q

theorem exists_rep {α : Sort u} {r : α → α → Prop} (q : Quot r) : ∃ (a : α), Quot.mk r a = q :=
  quot.induction_on q fun (a : α) => Exists.intro a rfl

protected def indep {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (a : α) : psigma β :=
  psigma.mk (Quot.mk r a) (f a)

protected theorem indep_coherent {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (a : α) (b : α) : r a b → quot.indep f a = quot.indep f b :=
  fun (e : r a b) => psigma.eq (sound e) (h a b e)

protected theorem lift_indep_pr1 {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (q : Quot r) : psigma.fst (Quot.lift (quot.indep f) (quot.indep_coherent f h) q) = q :=
  Quot.ind (fun (a : α) => Eq.refl (psigma.fst (quot.indep f a))) q

protected def rec {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (q : Quot r) : β q :=
  eq.rec_on (quot.lift_indep_pr1 f h q) (psigma.snd (Quot.lift (quot.indep f) (quot.indep_coherent f h) q))

protected def rec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r) (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec f h q

protected def rec_on_subsingleton {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} [h : ∀ (a : α), subsingleton (β (Quot.mk r a))] (q : Quot r) (f : (a : α) → β (Quot.mk r a)) : β q :=
  quot.rec f sorry q

protected def hrec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r) (f : (a : α) → β (Quot.mk r a)) (c : ∀ (a b : α), r a b → f a == f b) : β q :=
  quot.rec_on q f sorry

end quot

def quotient {α : Sort u} (s : setoid α) :=
  Quot setoid.r

namespace quotient

protected def mk {α : Sort u} [s : setoid α] (a : α) : quotient s :=
  Quot.mk setoid.r a

def sound {α : Sort u} [s : setoid α] {a : α} {b : α} : a ≈ b → quotient.mk a = quotient.mk b :=
  quot.sound

protected def lift {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) : (∀ (a b : α), a ≈ b → f a = f b) → quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : setoid α] {β : quotient s → Prop} : (∀ (a : α), β (quotient.mk a)) → ∀ (q : quotient s), β q :=
  Quot.ind

protected def lift_on {α : Sort u} {β : Sort v} [s : setoid α] (q : quotient s) (f : α → β) (c : ∀ (a b : α), a ≈ b → f a = f b) : β :=
  quot.lift_on q f c

protected theorem induction_on {α : Sort u} [s : setoid α] {β : quotient s → Prop} (q : quotient s) (h : ∀ (a : α), β (quotient.mk a)) : β q :=
  quot.induction_on q h

theorem exists_rep {α : Sort u} [s : setoid α] (q : quotient s) : ∃ (a : α), quotient.mk a = q :=
  quot.exists_rep q

protected def rec {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (f : (a : α) → β (quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) (q : quotient s) : β q :=
  quot.rec f h q

protected def rec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s) (f : (a : α) → β (quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec_on q f h

protected def rec_on_subsingleton {α : Sort u} [s : setoid α] {β : quotient s → Sort v} [h : ∀ (a : α), subsingleton (β (quotient.mk a))] (q : quotient s) (f : (a : α) → β (quotient.mk a)) : β q :=
  quot.rec_on_subsingleton q f

protected def hrec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s) (f : (a : α) → β (quotient.mk a)) (c : ∀ (a b : α), a ≈ b → f a == f b) : β q :=
  quot.hrec_on q f c

protected def lift₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] (f : α → β → φ) (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (q₁ : quotient s₁) (q₂ : quotient s₂) : φ :=
  quotient.lift (fun (a₁ : α) => quotient.lift (f a₁) sorry q₂) sorry q₁

protected def lift_on₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → φ) (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ :=
  quotient.lift₂ f c q₁ q₂

protected theorem ind₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Prop} (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) (q₁ : quotient s₁) (q₂ : quotient s₂) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] [s₃ : setoid φ] {δ : quotient s₁ → quotient s₂ → quotient s₃ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) (h : ∀ (a : α) (b : β) (c : φ), δ (quotient.mk a) (quotient.mk b) (quotient.mk c)) : δ q₁ q₂ q₃ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => quotient.ind (fun (a₃ : φ) => h a₁ a₂ a₃) q₃) q₂) q₁

theorem exact {α : Sort u} [s : setoid α] {a : α} {b : α} : quotient.mk a = quotient.mk b → a ≈ b :=
  fun (h : quotient.mk a = quotient.mk b) => eq_imp_rel h

protected def rec_on_subsingleton₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Sort u_c} [h : ∀ (a : α) (b : β), subsingleton (φ (quotient.mk a) (quotient.mk b))] (q₁ : quotient s₁) (q₂ : quotient s₂) (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.rec_on_subsingleton q₁ fun (a : α) => quotient.rec_on_subsingleton q₂ fun (b : β) => f a b

end quotient

inductive eqv_gen {α : Type u} (r : α → α → Prop) : α → α → Prop
where
| rel : ∀ (x y : α), r x y → eqv_gen r x y
| refl : ∀ (x : α), eqv_gen r x x
| symm : ∀ (x y : α), eqv_gen r x y → eqv_gen r y x
| trans : ∀ (x y z : α), eqv_gen r x y → eqv_gen r y z → eqv_gen r x z

theorem eqv_gen.is_equivalence {α : Type u} (r : α → α → Prop) : equivalence (eqv_gen r) :=
  mk_equivalence (eqv_gen r) eqv_gen.refl eqv_gen.symm eqv_gen.trans

def eqv_gen.setoid {α : Type u} (r : α → α → Prop) : setoid α :=
  setoid.mk (eqv_gen r) (eqv_gen.is_equivalence r)

theorem quot.exact {α : Type u} (r : α → α → Prop) {a : α} {b : α} (H : Quot.mk r a = Quot.mk r b) : eqv_gen r a b :=
  quotient.exact (congr_arg (Quot.lift quotient.mk fun (x y : α) (h : r x y) => quot.sound (eqv_gen.rel x y h)) H)

theorem quot.eqv_gen_sound {α : Type u} {r : α → α → Prop} {a : α} {b : α} (H : eqv_gen r a b) : Quot.mk r a = Quot.mk r b := sorry

protected instance quotient.decidable_eq {α : Sort u} {s : setoid α} [d : (a b : α) → Decidable (a ≈ b)] : DecidableEq (quotient s) :=
  fun (q₁ q₂ : quotient s) => quotient.rec_on_subsingleton₂ q₁ q₂ fun (a₁ a₂ : α) => sorry


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

open interactive

namespace tactic

/-
This file defines a `chain` tactic, which takes a list of tactics,
and exhaustively tries to apply them to the goals, until no tactic succeeds on any goal.

Along the way, it generates auxiliary declarations, in order to speed up elaboration time
of the resulting (sometimes long!) proofs.

This tactic is used by the `tidy` tactic.
-/

-- α is the return type of our tactics. When `chain` is called by `tidy`, this is string,
-- describing what that tactic did as an interactive tactic.
variable {α : Type}

inductive tactic_script (α : Type) : Type
| base : α → tactic_script
| work (index : ℕ) (first : α) (later : list tactic_script) (closed : bool) : tactic_script

meta def tactic_script.to_string : tactic_script string → string
| (tactic_script.base a) := a
| (tactic_script.work n a l c) :=  "work_on_goal " ++ (to_string n) ++
    " { " ++ (", ".intercalate (a :: l.map tactic_script.to_string)) ++ " }"

meta instance : has_to_string (tactic_script string) :=
{ to_string := λ s, s.to_string }

meta instance tactic_script_unit_has_to_string : has_to_string (tactic_script unit) :=
{ to_string := λ s, "[chain tactic]" }

meta def abstract_if_success (tac : expr → tactic α) (g : expr) : tactic α :=
do
  type ← infer_type g,
  is_lemma ← is_prop type,
  if is_lemma then -- there's no point making the abstraction, and indeed it's slower
    tac g
  else do
    m ← mk_meta_var type,
    a ← tac m,
    do
    { val ← instantiate_mvars m,
      guard (val.list_meta_vars = []),
      c  ← new_aux_decl_name,
      gs ← get_goals,
      set_goals [g],
      add_aux_decl c type val ff >>= unify g,
      set_goals gs }
    <|> unify m g,
    return a

/--
`chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
-/
meta mutual def chain_single, chain_many, chain_iter {α} (tac : tactic α)
with chain_single : expr → tactic (α × list (tactic_script α)) | g :=
do set_goals [g],
  a ← tac,
  l ← get_goals >>= chain_many,
  return (a, l)
with chain_many : list expr → tactic (list (tactic_script α))
| [] := return []
| [g] := do
{ (a, l) ← chain_single g,
  return (tactic_script.base a :: l) } <|> return []
| gs := chain_iter gs []
with chain_iter : list expr → list expr → tactic (list (tactic_script α))
| [] _ := return []
| (g :: later_goals) stuck_goals := do
{ (a, l) ← abstract_if_success chain_single g,
  new_goals ← get_goals,
  let w := tactic_script.work stuck_goals.length a l (new_goals = []),
  let current_goals := stuck_goals.reverse ++ new_goals ++ later_goals,
  set_goals current_goals, -- we keep the goals up to date, so they are correct at the end
  l' ← chain_many current_goals,
  return (w :: l') } <|> chain_iter later_goals (g :: stuck_goals)

meta def chain_core {α : Type} [has_to_string (tactic_script α)] (tactics : list (tactic α)) :
  tactic (list string) :=
do results ← (get_goals >>= chain_many (first tactics)),
   when results.empty (fail "`chain` tactic made no progress"),
   return (results.map to_string)

variables [has_to_string (tactic_script α)] [has_to_format α]

declare_trace chain

meta def trace_output (t : tactic α) : tactic α :=
do tgt ← target,
   r ← t,
   name ← decl_name,
   trace format!"`chain` successfully applied a tactic during elaboration of {name}:",
   tgt ← pp tgt,
   trace format!"previous target: {tgt}",
   trace format!"tactic result: {r}",
   tgt ← try_core target,
   tgt ← match tgt with
          | (some tgt) := pp tgt
          | none       := return "no goals"
          end,
   trace format!"new target: {tgt}",
   pure r

meta def chain (tactics : list (tactic α)) : tactic (list string) :=
chain_core
  (if is_trace_enabled_for `chain then (tactics.map trace_output) else tactics)

end tactic


import data.polya.field

namespace tactic

meta def pexpr_of_pos_num (α h_one h_add : expr) : pos_num → pexpr
| pos_num.one      := ``(@has_one.one %%α %%h_one)
| (pos_num.bit0 n) := ``(@bit0 %%α %%h_add (%%(pexpr_of_pos_num n)))
| (pos_num.bit1 n) := ``(@bit1 %%α %%h_one %%h_add (%%(pexpr_of_pos_num n)))

meta def expr_of_num (α : expr) (n : num) : tactic expr :=
match n with
| num.zero := do
  h_zero ← mk_app `has_zero [α] >>= mk_instance,
  to_expr ``(@has_zero.zero %%α %%h_zero)
| (num.pos (pos_num.one)) := do
  h_one ← mk_app `has_one [α] >>= mk_instance,
  to_expr ``(@has_one.one %%α %%h_one)
| (num.pos m) := do
  h_one ← mk_app `has_one [α] >>= mk_instance,
  h_add ← mk_app `has_add [α] >>= mk_instance,
  to_expr (pexpr_of_pos_num α h_one h_add m)
end

meta def expr_of_znum (α : expr) (n : znum) : tactic expr :=
match n with
| znum.zero := do
  h_zero ← mk_app `has_zero [α] >>= mk_instance,
  to_expr ``(@has_zero.zero %%α %%h_zero)
| (znum.pos n) :=
  expr_of_num α (num.pos n)
| (znum.neg n) := do
  h_neg ← mk_app `has_neg [α] >>= mk_instance,
  e ← expr_of_num α (num.pos n),
  to_expr ``(@has_neg.neg %%α %%h_neg %%e)
end

meta def expr_of_rat (α : expr) (q : ℚ) : tactic expr :=
let n : znum := q.num in
let d : znum := q.denom in
if d = 1 then
  expr_of_znum α n
else do
  a ← expr_of_znum α n,
  b ← expr_of_znum α d,
  to_expr ``(%%a / %%b)

end tactic

namespace rat

open polya.field

instance : const_space ℚ :=
{ df := by apply_instance,
  lt := (<),
  dec := by apply_instance,
}

instance {α} [discrete_field α] [char_zero α] : morph ℚ α :=
{ cast       := by apply_instance,
  morph_zero := rat.cast_zero,
  morph_one  := rat.cast_one,
  morph_add  := rat.cast_add,
  morph_neg  := rat.cast_neg,
  morph_mul  := rat.cast_mul,
  morph_inv  := rat.cast_inv,
  morph_inj  := begin
      intros a ha,
      apply rat.cast_inj.mp,
      { rw rat.cast_zero, apply ha },
      { resetI, apply_instance }
    end,
}

end rat

namespace list

def pall {α : Type*} (l : list α) (f : α → Prop) : Prop :=
l.foldr (λ a r, f a ∧ r) true

theorem pall_iff_forall_prop :
  ∀ {α : Type*} {p : α → Prop} [_inst_1 : decidable_pred p] {l : list α},
  list.pall l p ↔ ∀ (a : α), a ∈ l → p a :=
begin
  intros,
  apply iff.trans, swap,
  { exact @list.all_iff_forall_prop _ _ _inst_1 _ },
  { unfold pall, induction l with x xs ih,
    { simp },
    { simp [ih] }}
end

open polya.field tactic

meta def expr_reflect (type : expr) : list expr → tactic expr
| [] := to_expr ``([] : list %%type)
| (h::t) := do e ← expr_reflect t, to_expr ``(list.cons (%%h : %%type) %%e)

def to_dict {α} [inhabited α] (l : list α) : dict α :=
⟨λ i, list.func.get i l.reverse⟩

end list

--namespace finmap
--open field
--
--def to_dict {α} [discrete_field α] (m : finmap (λ _ : num, α)) : dict α :=
--⟨λ i, match finmap.lookup i m with (some x) := x | _ := 0 end⟩
--
--end finmap

namespace tactic
open native tactic

namespace polya.field
open polya.field polya.field.term

meta structure cache_ty :=
( new_atom : num )
( atoms    : rb_map expr num )
( dict     : rb_map num expr )

meta instance : has_emptyc cache_ty :=
⟨⟨0, rb_map.mk _ _, rb_map.mk _ _⟩⟩

meta def state_dict : Type → Type := state_t cache_ty tactic

namespace state_dict
meta instance : monad state_dict := state_t.monad
meta instance : monad_state cache_ty state_dict := state_t.monad_state
meta instance : alternative state_dict := state_t.alternative
meta instance {α} : has_coe (tactic α) (state_dict α) := ⟨state_t.lift⟩
end state_dict

meta def get_atom (e : expr) : state_dict num :=
get >>= λ s,
match s.atoms.find e with
| (some i) := return i
| none     := do
    let i := s.new_atom,
    put ⟨i + 1, s.atoms.insert e i, s.dict.insert i e⟩,
    return i
end

meta def cache_ty.dict_expr (α : expr) (s : cache_ty) : tactic expr :=
do
    e ← s.dict.values.expr_reflect α,
    mk_app `list.to_dict [e]

meta def term_of_expr : expr → state_dict term | e :=
match e with
| `(%%a + %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (add x y)
| `(%%a - %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (sub x y)
| `(%%a * %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (mul x y)
| `(%%a / %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (div x y)
| `(-%%a)      := do x ← term_of_expr a, return (neg x)
| `((%%a)⁻¹)   := do x ← term_of_expr a, return (inv x)
| `(%%a ^ %%b) := do x ← term_of_expr a, ( (do n ← b.to_nat, return (pow_nat x n)) <|> (do n ← b.to_int, return (pow_int x n)) )
| _            := do n ← e.to_nat, return (numeral n)
end <|> do i ← get_atom e, return (atom i)

--TODO: more generic
@[reducible] def α := ℚ
@[reducible] def γ := ℚ

meta def nterm_to_expr (s : cache_ty) : nterm γ → tactic expr
| (nterm.atom i)  := s.dict.find i
| (nterm.const c) := expr_of_rat `(α) c
| (nterm.add x y) := do a ← nterm_to_expr x, b ← nterm_to_expr y, to_expr ``(%%a + %%b)
| (nterm.mul x y) := do a ← nterm_to_expr x, b ← nterm_to_expr y, to_expr ``(%%a * %%b)
| (nterm.pow x n) := do a ← nterm_to_expr x, b ← expr_of_znum `(ℤ) n, to_expr ``(%%a ^ %%b)

meta def prove_norm_hyps (t : term) (s : cache_ty) : tactic (list expr × expr) :=
do
  let t_expr : expr := reflect t,
  ρ ← s.dict_expr `(α),

  let nhyps := norm_hyps γ t,
  nhyps ← monad.mapm (nterm_to_expr s) nhyps,
  nhyps ← monad.mapm (λ e, to_expr ``(%%e ≠ 0)) nhyps,
  mvars ← monad.mapm mk_meta_var nhyps,

  h ← to_expr ``(∀ x ∈ norm_hyps γ %%t_expr, nterm.eval %%ρ x ≠ 0),
  pe ← to_expr ( mvars.foldr (λ e pe, ``((and.intro %%e %%pe))) ``(trivial) ) tt ff,
  ((), pr) ← solve_aux h (refine ``(list.pall_iff_forall_prop.mp _) >> exact pe >> done),

  return (mvars, pr)

-- norm_expr e s = (new_e, pr, mv, mvs, new_s)
-- new_e is the canonized expression
-- pr is a proof that e = new_e
-- mv is a meta-variable to prove by reflexivity
-- mvs are neta-variables for the nonzero hypothesis made by the normalizer
-- new_s is the updated cache
meta def norm_expr (e : expr) (s : cache_ty) :
  tactic (expr × expr × expr × list expr × cache_ty) :=
do
  (t, s) ← (term_of_expr e).run s,
  let t_expr : expr := reflect t,
  let norm_t := norm γ t,
  norm_t_expr ← to_expr ``(norm γ %%t_expr),
  ρ_expr ← s.dict_expr `(α),

  (mvars, pr0) ← prove_norm_hyps t s,

  --reflexivity from expr to term
  h1 ← to_expr ``(%%e = term.eval %%ρ_expr %%t_expr),
  ((), pr1) ← solve_aux h1 `[refl, done],

  --correctness theorem
  --h2 ← to_expr ``(term.eval %%ρ_expr %%t_expr = nterm.eval %%ρ_expr %%norm_t_expr),
  pr2 ← mk_app `polya.field.correctness [pr0],

  --reflexivity from nterm to expr
  new_e ← nterm_to_expr s norm_t,
  h3 ← to_expr ``(nterm.eval %%ρ_expr %%norm_t_expr = %%new_e),
  pr3 ← mk_meta_var h3, --heavy computation in the kernel

  pr ← mk_eq_trans pr2 pr3 >>= mk_eq_trans pr1,
  return (new_e, pr, pr3, mvars, s)

end polya.field

meta def prove_by_reflexivity (mvs : list expr) : tactic unit :=
do
  gs ← get_goals,
  set_goals mvs,
  all_goals reflexivity,
  set_goals gs

end tactic

open tactic interactive interactive.types lean.parser
open tactic.polya.field

meta def tactic.interactive.field1 : tactic unit :=
do
  `(%%e1 = %%e2) ← target,

  (new_e1, pr1, mv1, mvs, s) ← norm_expr e1 ∅,
  (new_e2, pr2, mv2, mvs', s) ← norm_expr e2 s,

  ( do
    unify new_e1 new_e2,
    prove_by_reflexivity [mv1, mv2],
    gs ← get_goals,
    set_goals (gs ++ mvs ++ mvs'),
    pr ← mk_eq_symm pr2 >>= mk_eq_trans pr1,
    tactic.exact pr
  ) <|> ( do
    prove_by_reflexivity [mv1, mv2],
    pr0 ← to_expr ``(%%new_e1 = %%new_e2) >>= mk_meta_var,
    gs ← get_goals,
    set_goals (gs ++ [pr0] ++ mvs ++ mvs'),
    pr ← mk_eq_symm pr2 >>= mk_eq_trans pr0 >>= mk_eq_trans pr1,
    tactic.exact pr
  )


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Adam Topaz
-/
import category_theory.functor_category
import category_theory.fully_faithful

namespace category_theory
open category

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

variables (C : Type u₁) [category.{v₁} C]

/--
The data of a monad on C consists of an endofunctor T together with natural transformations
η : 𝟭 C ⟶ T and μ : T ⋙ T ⟶ T satisfying three equations:
- T μ_X ≫ μ_X = μ_(TX) ≫ μ_X (associativity)
- η_(TX) ≫ μ_X = 1_X (left unit)
- Tη_X ≫ μ_X = 1_X (right unit)
-/
structure monad extends C ⥤ C :=
(η' [] : 𝟭 _ ⟶ to_functor)
(μ' [] : to_functor ⋙ to_functor ⟶ to_functor)
(assoc' : ∀ X, to_functor.map (nat_trans.app μ' X) ≫ μ'.app _ = μ'.app _ ≫ μ'.app _ . obviously)
(left_unit' : ∀ X : C, η'.app (to_functor.obj X) ≫ μ'.app _ = 𝟙 _ . obviously)
(right_unit' : ∀ X : C, to_functor.map (η'.app X) ≫ μ'.app _ = 𝟙 _ . obviously)

/--
The data of a comonad on C consists of an endofunctor G together with natural transformations
ε : G ⟶ 𝟭 C and δ : G ⟶ G ⋙ G satisfying three equations:
- δ_X ≫ G δ_X = δ_X ≫ δ_(GX) (coassociativity)
- δ_X ≫ ε_(GX) = 1_X (left counit)
- δ_X ≫ G ε_X = 1_X (right counit)
-/
structure comonad extends C ⥤ C :=
(ε' [] : to_functor ⟶ 𝟭 _)
(δ' [] : to_functor ⟶ to_functor ⋙ to_functor)
(coassoc' : ∀ X, nat_trans.app δ' _ ≫ to_functor.map (δ'.app X) = δ'.app _ ≫ δ'.app _ . obviously)
(left_counit' : ∀ X : C, δ'.app X ≫ ε'.app (to_functor.obj X) = 𝟙 _ . obviously)
(right_counit' : ∀ X : C, δ'.app X ≫ to_functor.map (ε'.app X) = 𝟙 _ . obviously)

variables {C} (T : monad C) (G : comonad C)

instance coe_monad : has_coe (monad C) (C ⥤ C) := ⟨λ T, T.to_functor⟩
instance coe_comonad : has_coe (comonad C) (C ⥤ C) := ⟨λ G, G.to_functor⟩

@[simp] lemma monad_to_functor_eq_coe : T.to_functor = T := rfl
@[simp] lemma comonad_to_functor_eq_coe : G.to_functor = G := rfl

/-- The unit for the monad `T`. -/
def monad.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η'
/-- The multiplication for the monad `T`. -/
def monad.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ T := T.μ'

/-- The counit for the comonad `G`. -/
def comonad.ε : (G : C ⥤ C) ⟶ 𝟭 _  := G.ε'
/-- The comultiplication for the comonad `G`. -/
def comonad.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ G := G.δ'

/-- A custom simps projection for the functor part of a monad, as a coercion. -/
def monad.simps.coe := (T : C ⥤ C)
/-- A custom simps projection for the unit of a monad, in simp normal form. -/
def monad.simps.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η
/-- A custom simps projection for the multiplication of a monad, in simp normal form. -/
def monad.simps.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ (T : C ⥤ C) := T.μ

/-- A custom simps projection for the functor part of a comonad, as a coercion. -/
def comonad.simps.coe := (G : C ⥤ C)
/-- A custom simps projection for the counit of a comonad, in simp normal form. -/
def comonad.simps.ε : (G : C ⥤ C) ⟶ 𝟭 _ := G.ε
/-- A custom simps projection for the comultiplication of a comonad, in simp normal form. -/
def comonad.simps.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ (G : C ⥤ C) := G.δ

initialize_simps_projections category_theory.monad (to_functor → coe, η' → η, μ' → μ)
initialize_simps_projections category_theory.comonad (to_functor → coe, ε' → ε, δ' → δ)

@[reassoc]
lemma monad.assoc (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.μ.app X) ≫ T.μ.app _ = T.μ.app _ ≫ T.μ.app _ :=
T.assoc' X

@[simp, reassoc] lemma monad.left_unit (T : monad C) (X : C) :
  T.η.app ((T : C ⥤ C).obj X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.left_unit' X

@[simp, reassoc] lemma monad.right_unit (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.η.app X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.right_unit' X

@[reassoc]
lemma comonad.coassoc (G : comonad C) (X : C) :
  G.δ.app _ ≫ (G : C ⥤ C).map (G.δ.app X) = G.δ.app _ ≫ G.δ.app _ :=
G.coassoc' X

@[simp, reassoc] lemma comonad.left_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ G.ε.app ((G : C ⥤ C).obj X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.left_counit' X

@[simp, reassoc] lemma comonad.right_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ (G : C ⥤ C).map (G.ε.app X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.right_counit' X

/-- A morphism of monads is a natural transformation compatible with η and μ. -/
@[ext]
structure monad_hom (T₁ T₂ : monad C) extends nat_trans (T₁ : C ⥤ C) T₂ :=
(app_η' : ∀ {X}, T₁.η.app X ≫ app X = T₂.η.app X . obviously)
(app_μ' : ∀ {X}, T₁.μ.app X ≫ app X = ((T₁ : C ⥤ C).map (app X) ≫ app _) ≫ T₂.μ.app X . obviously)

/-- A morphism of comonads is a natural transformation compatible with ε and δ. -/
@[ext]
structure comonad_hom (M N : comonad C) extends nat_trans (M : C ⥤ C) N :=
(app_ε' : ∀ {X}, app X ≫ N.ε.app X = M.ε.app X . obviously)
(app_δ' : ∀ {X}, app X ≫ N.δ.app X = M.δ.app X ≫ app (M.obj X) ≫ N.map (app X) . obviously)

restate_axiom monad_hom.app_η'
restate_axiom monad_hom.app_μ'
attribute [simp, reassoc] monad_hom.app_η monad_hom.app_μ

restate_axiom comonad_hom.app_ε'
restate_axiom comonad_hom.app_δ'
attribute [simp, reassoc] comonad_hom.app_ε comonad_hom.app_δ

instance : category (monad C) :=
{ hom := monad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ _ _ _ f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance : category (comonad C) :=
{ hom := comonad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ M N L f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance {T : monad C} : inhabited (monad_hom T T) := ⟨𝟙 T⟩

@[simp]

instance {G : comonad C} : inhabited (comonad_hom G G) := ⟨𝟙 G⟩

@[simp] lemma comonad_hom.id_to_nat_trans (T : comonad C) :
  (𝟙 T : T ⟶ T).to_nat_trans = 𝟙 (T : C ⥤ C) :=
rfl
@[simp] lemma comp_to_nat_trans {T₁ T₂ T₃ : comonad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  (f ≫ g).to_nat_trans =
    ((f.to_nat_trans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.to_nat_trans : (T₁ : C ⥤ C) ⟶ T₃) :=
rfl

variable (C)

/--
The forgetful functor from the category of monads to the category of endofunctors.
-/
@[simps]
def monad_to_functor : monad C ⥤ (C ⥤ C) :=
{ obj := λ T, T,
  map := λ M N f, f.to_nat_trans }

instance : faithful (monad_to_functor C) := {}.

/--
The forgetful functor from the category of comonads to the category of endofunctors.
-/
@[simps]
def comonad_to_functor : comonad C ⥤ (C ⥤ C) :=
{ obj := λ G, G,
  map := λ M N f, f.to_nat_trans }

instance : faithful (comonad_to_functor C) := {}.

variable {C}

/--
An isomorphism of monads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def monad_iso.to_nat_iso {M N : monad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(monad_to_functor C).map_iso h

/--
An isomorphism of comonads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def comonad_iso.to_nat_iso {M N : comonad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(comonad_to_functor C).map_iso h

variable (C)

namespace monad

/-- The identity monad. -/
@[simps]
def id : monad C :=
{ to_functor := 𝟭 C,
  η' := 𝟙 (𝟭 C),
  μ' := 𝟙 (𝟭 C) }

instance : inhabited (monad C) := ⟨monad.id C⟩

end monad

namespace comonad

/-- The identity comonad. -/
@[simps]
def id : comonad C :=
{ to_functor := 𝟭 _,
  ε' := 𝟙 (𝟭 C),
  δ' := 𝟙 (𝟭 C) }

instance : inhabited (comonad C) := ⟨comonad.id C⟩

end comonad

end category_theory