import ReactorModel.Determinism.InstantaneousExecution

namespace Execution

open ReactorType
open State (Closed)

variable [Indexable α] {s s₁ s₂ : State α} [State.Nontrivial s] [State.Nontrivial s₁]

namespace AdvanceTag

theorem not_Closed (a : s₁ ⇓- s₂) : ¬(Closed s₂) :=
  have := a.advance.preserves_Nontrivial -- TODO: Make this work via type class inference.
  (absurd a.advance.progress_empty ·.progress_Nonempty.ne_empty)

theorem nonrepeatable (a₁ : s₁ ⇓- s₂) (a₂ : s₂ ⇓- s₃) : False :=
  absurd a₂.closed a₁.not_Closed

theorem tag_lt (a : s₁ ⇓- s₂) : s₁.tag < s₂.tag :=
  a.advance.tag_lt

theorem tag_ne (a : s₁ ⇓- s₂) : s₁.tag ≠ s₂.tag :=
  ne_of_lt a.tag_lt

theorem determinisic (a₁ : s ⇓- s₁) (a₂ : s ⇓- s₂) : s₁ = s₂ :=
  a₁.advance.determinisic a₂.advance

instance preserves_Nontrivial [State.Nontrivial s₁] {e : s₁ ⇓- s₂} : State.Nontrivial s₂ :=
  e.advance.preserves_Nontrivial

end AdvanceTag

namespace Instantaneous
namespace ClosedExecution

theorem not_Closed (e : s₁ ⇓| s₂) : ¬(Closed s₁) := by
  simp [Closed]
  have h := Partial.Nonempty.iff_ids_nonempty.mp $ State.Nontrivial.nontrivial (s := s₁)
  exact e.fresh ▸ h.ne_empty.symm

theorem preserves_tag (e : s₁ ⇓| s₂) : s₁.tag = s₂.tag :=
  e.exec.preserves_tag

theorem equiv (e : s₁ ⇓| s₂) : s₁.rtr ≈ s₂.rtr :=
  e.exec.equiv

theorem rcns_Nodup (e : s₁ ⇓| s₂) : e.rcns.Nodup :=
  e.exec.rcns_nodup

theorem progress_def (e : s₁ ⇓| s₂) : s₂.progress = s₁.rtr[.rcn].ids :=
  Equivalent.obj?_rcn_eq e.equiv ▸ e.closed

theorem mem_rcns_iff (e : s₁ ⇓| s₂) : rcn ∈ e.rcns ↔ (rcn ∈ s₁.rtr[.rcn] ∧ rcn ∉ s₁.progress) := by
  simp [Partial.mem_def, e.progress_def ▸ e.exec.mem_rcns_iff (rcn := rcn)]

theorem rcns_perm (e₁ : s ⇓| s₁) (e₂ : s ⇓| s₂) : e₁.rcns ~ e₂.rcns := by
  simp [List.perm_ext e₁.rcns_Nodup e₂.rcns_Nodup, e₁.mem_rcns_iff, e₂.mem_rcns_iff]

theorem tag_eq (e₁ : s ⇓| s₁) (e₂ : s ⇓| s₂) : s₁.tag = s₂.tag :=
  e₁.exec.preserves_tag ▸ e₂.exec.preserves_tag

theorem progress_eq (e₁ : s ⇓| s₁) (e₂ : s ⇓| s₂) : s₁.progress = s₂.progress := by
  simp [e₁.progress_def, e₂.progress_def]

theorem deterministic (e₁ : s ⇓| s₁) (e₂ : s ⇓| s₂) : s₁ = s₂ :=
  e₁.exec.deterministic e₂.exec (e₁.tag_eq e₂) (e₁.progress_eq e₂)

theorem step_determined (e : s ⇓| s₁) (a : s ⇓- s₂) : False :=
  absurd a.closed e.not_Closed

instance preserves_Nontrivial [h : State.Nontrivial s₁] {e : s₁ ⇓| s₂} : State.Nontrivial s₂ where
  nontrivial := Equivalent.obj?_rcn_eq e.equiv ▸ h.nontrivial

theorem nonrepeatable (e₁ : s₁ ⇓| s₂) (e₂ : s₂ ⇓| s₃) : False :=
  have := e₁.preserves_Nontrivial -- TODO: Make this work via type class inference.
  absurd e₁.closed $ e₂.not_Closed

theorem progress_ssubset (e : s₁ ⇓| s₂) : s₁.progress ⊂ s₂.progress := by
  have := e.preserves_Nontrivial -- TODO: Make this work via type class inference.
  rw [e.fresh]
  exact e.closed.progress_Nonempty.empty_ssubset

end ClosedExecution
end Instantaneous

namespace Step

theorem tag_le : (s₁ ⇓ s₂) → s₁.tag ≤ s₂.tag
  | close e   => le_of_eq e.preserves_tag
  | advance a => le_of_lt a.tag_lt

theorem deterministic : (s ⇓ s₁) → (s ⇓ s₂) → s₁ = s₂
  | close e₁, close e₂                      => e₁.deterministic e₂
  | advance a₁, advance a₂                  => a₁.determinisic a₂
  | close e, advance a | advance a, close e => e.step_determined a |>.elim

theorem seq_tag_lt : (s₁ ⇓ s₂) → (s₂ ⇓ s₃) → s₁.tag < s₃.tag
  | close e₁,   close e₂   => e₁.nonrepeatable e₂ |>.elim
  | advance a₁, advance a₂ => a₁.nonrepeatable a₂ |>.elim
  | close e,    advance a  => e.preserves_tag ▸ a.tag_lt
  | advance a,  close e    => e.preserves_tag ▸ a.tag_lt

instance preserves_Nontrivial [State.Nontrivial s₁] : (s₁ ⇓ s₂) → State.Nontrivial s₂
  | close e   => e.preserves_Nontrivial
  | advance a => a.preserves_Nontrivial

end Step

end Execution


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.tactic init.meta.attribute init.meta.constructor_tactic
import init.meta.relation_tactics init.meta.occurrences
import init.data.option.basic

open tactic

def tactic.id_tag.simp : unit := ()

def simp.default_max_steps := 10000000

/-- Prefix the given `attr_name` with `"simp_attr"`. -/
meta constant mk_simp_attr_decl_name (attr_name : name) : name

/-- Simp lemmas are used by the "simplifier" family of tactics.
`simp_lemmas` is essentially a pair of tables `rb_map (expr_type × name) (priority_list simp_lemma)`.
One of the tables is for congruences and one is for everything else.
An individual simp lemma is:
- A kind which can be `Refl`, `Simp` or `Congr`.
- A pair of `expr`s `l ~> r`. The rb map is indexed by the name of `get_app_fn(l)`.
- A proof that `l = r` or `l ↔ r`.
- A list of the metavariables that must be filled before the proof can be applied.
- A priority number
-/
meta constant simp_lemmas : Type
/-- Make a new table of simp lemmas -/
meta constant simp_lemmas.mk : simp_lemmas
/-- Merge the simp_lemma tables. -/
meta constant simp_lemmas.join : simp_lemmas → simp_lemmas → simp_lemmas
/-- Remove the given lemmas from the table. Use the names of the lemmas. -/
meta constant simp_lemmas.erase : simp_lemmas → list name → simp_lemmas
/-- Remove all simp lemmas from the table. -/
meta constant simp_lemmas.erase_simp_lemmas : simp_lemmas → simp_lemmas
/-- Makes the default simp_lemmas table which is composed of all lemmas tagged with `simp`. -/
meta constant simp_lemmas.mk_default : tactic simp_lemmas
/-- Add a simplification lemma by an expression `p`. Some conditions on `p` must hold for it to be added, see list below.
If your lemma is not being added, you can see the reasons by setting `set_option trace.simp_lemmas true`.

- `p` must have the type `Π (h₁ : _) ... (hₙ : _), LHS ~ RHS` for some reflexive, transitive relation (usually `=`).
- Any of the hypotheses `hᵢ` should either be present in `LHS` or otherwise a `Prop` or a typeclass instance.
- `LHS` should not occur within `RHS`.
- `LHS` should not occur within a hypothesis `hᵢ`.

 -/
meta constant simp_lemmas.add (s : simp_lemmas) (e : expr) (symm : bool := false) : tactic simp_lemmas
/-- Add a simplification lemma by it's declaration name. See `simp_lemmas.add` for more information.-/
meta constant simp_lemmas.add_simp (s : simp_lemmas) (id : name) (symm : bool := false) : tactic simp_lemmas
/-- Adds a congruence simp lemma to simp_lemmas.
A congruence simp lemma is a lemma that breaks the simplification down into separate problems.
For example, to simplify `a ∧ b` to `c ∧ d`, we should try to simp `a` to `c` and `b` to `d`.
For examples of congruence simp lemmas look for lemmas with the `@[congr]` attribute.
```lean
lemma if_simp_congr ... (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) : ite b x y = ite c u v := ...
lemma imp_congr_right (h : a → (b ↔ c)) : (a → b) ↔ (a → c) := ...
lemma and_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ∧ b) ↔ (c ∧ d) := ...
```
-/
meta constant simp_lemmas.add_congr : simp_lemmas → name → tactic simp_lemmas

/-- Add expressions to a set of simp lemmas using `simp_lemmas.add`.

  This is the new version of `simp_lemmas.append`,
  which also allows you to set the `symm` flag.
-/
meta def simp_lemmas.append_with_symm (s : simp_lemmas) (hs : list (expr × bool)) :
  tactic simp_lemmas :=
hs.mfoldl (λ s h, simp_lemmas.add s h.fst h.snd) s
/-- Add expressions to a set of simp lemmas using `simp_lemmas.add`.

  This is the backwards-compatibility version of `simp_lemmas.append_with_symm`,
  and sets all `symm` flags to `ff`.
-/
meta def simp_lemmas.append (s : simp_lemmas) (hs : list expr) : tactic simp_lemmas :=
hs.mfoldl (λ s h, simp_lemmas.add s h ff) s

/-- `simp_lemmas.rewrite s e prove R` apply a simplification lemma from 's'

   - 'e'     is the expression to be "simplified"
   - 'prove' is used to discharge proof obligations.
   - 'r'     is the equivalence relation being used (e.g., 'eq', 'iff')
   - 'md'    is the transparency; how aggresively should the simplifier perform reductions.

   Result (new_e, pr) is the new expression 'new_e' and a proof (pr : e R new_e) -/
meta constant simp_lemmas.rewrite (s : simp_lemmas) (e : expr)
                                  (prove : tactic unit := failed) (r : name := `eq) (md := reducible)
                                  : tactic (expr × expr)
meta constant simp_lemmas.rewrites (s : simp_lemmas) (e : expr)
                                  (prove : tactic unit := failed) (r : name := `eq) (md := reducible)
                                  : tactic $ list (expr × expr)
/-- `simp_lemmas.drewrite s e` tries to rewrite 'e' using only refl lemmas in 's' -/
meta constant simp_lemmas.drewrite (s : simp_lemmas) (e : expr) (md := reducible) : tactic expr

meta constant is_valid_simp_lemma_cnst : name → tactic bool
meta constant is_valid_simp_lemma : expr → tactic bool

meta constant simp_lemmas.pp : simp_lemmas → tactic format

meta instance : has_to_tactic_format simp_lemmas :=
⟨simp_lemmas.pp⟩

namespace tactic
/- Remark: `transform` should not change the target. -/
/-- Revert a local constant, change its type using `transform`.  -/
meta def revert_and_transform (transform : expr → tactic expr) (h : expr) : tactic unit :=
do num_reverted : ℕ ← revert h,
   t ← target,
   match t with
   | expr.pi n bi d b  :=
        do h_simp ← transform d,
           unsafe_change $ expr.pi n bi h_simp b
   | expr.elet n g e f :=
        do h_simp ← transform g,
           unsafe_change $ expr.elet n h_simp e f
   | _ := fail "reverting hypothesis created neither a pi nor an elet expr (unreachable?)"
   end,
   intron num_reverted

/-- `get_eqn_lemmas_for deps d` returns the automatically generated equational lemmas for definition d.
   If deps is tt, then lemmas for automatically generated auxiliary declarations used to define d are also included. -/
meta def get_eqn_lemmas_for (deps : bool) (d : name) : tactic (list name) := do
env ← get_env,
pure $ if deps then env.get_ext_eqn_lemmas_for d else env.get_eqn_lemmas_for d

structure dsimp_config :=
(md                        := reducible) -- reduction mode: how aggressively constants are replaced with their definitions.
(max_steps : nat           := simp.default_max_steps) -- The maximum number of steps allowed before failing.
(canonize_instances : bool := tt) -- See the documentation in `src/library/defeq_canonizer.h`
(single_pass : bool        := ff) -- Visit each subterm no more than once.
(fail_if_unchanged         := tt) -- Don't throw if dsimp didn't do anything.
(eta                       := tt) -- allow eta-equivalence: `(λ x, F $ x) ↝ F`
(zeta : bool               := tt) -- do zeta-reductions: `let x : a := b in c ↝ c[x/b]`.
(beta : bool               := tt) -- do beta-reductions: `(λ x, E) $ (y) ↝ E[x/y]`.
(proj : bool               := tt) -- reduce projections: `⟨a,b⟩.1 ↝ a`.
(iota : bool               := tt) -- reduce recursors for inductive datatypes: eg `nat.rec_on (succ n) Z R ↝ R n $ nat.rec_on n Z R`
(unfold_reducible          := ff) -- if tt, definitions with `reducible` transparency will be unfolded (delta-reduced)
(memoize                   := tt) -- Perform caching of dsimps of subterms.
end tactic

/-- (Definitional) Simplify the given expression using *only* reflexivity equality lemmas from the given set of lemmas.
   The resulting expression is definitionally equal to the input.

   The list `u` contains defintions to be delta-reduced, and projections to be reduced.-/
meta constant simp_lemmas.dsimplify (s : simp_lemmas) (u : list name := []) (e : expr) (cfg : tactic.dsimp_config := {}) : tactic expr

namespace tactic
/- Remark: the configuration parameters `cfg.md` and `cfg.eta` are ignored by this tactic. -/
meta constant dsimplify_core
  /- The user state type. -/
  {α : Type}
  /- Initial user data -/
  (a : α)
  /- (pre a e) is invoked before visiting the children of subterm 'e',
     if it succeeds the result (new_a, new_e, flag) where
       - 'new_a' is the new value for the user data
       - 'new_e' is a new expression that must be definitionally equal to 'e',
       - 'flag'  if tt 'new_e' children should be visited, and 'post' invoked. -/
  (pre             : α → expr → tactic (α × expr × bool))
  /- (post a e) is invoked after visiting the children of subterm 'e',
     The output is similar to (pre a e), but the 'flag' indicates whether
     the new expression should be revisited or not. -/
  (post            : α → expr → tactic (α × expr × bool))
  (e               : expr)
  (cfg             : dsimp_config := {})
  : tactic (α × expr)

meta def dsimplify
  (pre             : expr → tactic (expr × bool))
  (post            : expr → tactic (expr × bool))
  : expr → tactic expr :=
λ e, do (a, new_e) ← dsimplify_core ()
                       (λ u e, do r ← pre e, return (u, r))
                       (λ u e, do r ← post e, return (u, r)) e,
        return new_e

meta def get_simp_lemmas_or_default : option simp_lemmas → tactic simp_lemmas
| none     := simp_lemmas.mk_default
| (some s) := return s

meta def dsimp_target (s : option simp_lemmas := none) (u : list name := []) (cfg : dsimp_config := {}) : tactic unit :=
do
  s ← get_simp_lemmas_or_default s,
  t ← target >>= instantiate_mvars,
  s.dsimplify u t cfg >>= unsafe_change

meta def dsimp_hyp (h : expr) (s : option simp_lemmas := none) (u : list name := []) (cfg : dsimp_config := {}) : tactic unit :=
do s ← get_simp_lemmas_or_default s, revert_and_transform (λ e, s.dsimplify u e cfg) h

/- Remark: we use transparency.instances by default to make sure that we
   can unfold projections of type classes. Example:

          (@has_add.add nat nat.has_add a b)
-/

/-- Tries to unfold `e` if it is a constant or a constant application.
    Remark: this is not a recursive procedure. -/
meta constant dunfold_head (e : expr) (md := transparency.instances) : tactic expr

structure dunfold_config extends dsimp_config :=
(md := transparency.instances)

/- Remark: in principle, dunfold can be implemented on top of dsimp. We don't do it for
   performance reasons. -/

meta constant dunfold (cs : list name) (e : expr) (cfg : dunfold_config := {}) : tactic expr

meta def dunfold_target (cs : list name) (cfg : dunfold_config := {}) : tactic unit :=
do t ← target, dunfold cs t cfg >>= unsafe_change

meta def dunfold_hyp (cs : list name) (h : expr) (cfg : dunfold_config := {}) : tactic unit :=
revert_and_transform (λ e, dunfold cs e cfg) h

structure delta_config :=
(max_steps       := simp.default_max_steps)
(visit_instances := tt)

private meta def is_delta_target (e : expr) (cs : list name) : bool :=
cs.any (λ c,
  if e.is_app_of c then tt   /- Exact match -/
  else let f := e.get_app_fn in
       /- f is an auxiliary constant generated when compiling c -/
       f.is_constant && f.const_name.is_internal && (f.const_name.get_prefix = c))

/-- Delta reduce the given constant names -/
meta def delta (cs : list name) (e : expr) (cfg : delta_config := {}) : tactic expr :=
let unfold (u : unit) (e : expr) : tactic (unit × expr × bool) := do
  guard (is_delta_target e cs),
  (expr.const f_name f_lvls) ← return e.get_app_fn,
  env   ← get_env,
  decl  ← env.get f_name,
  new_f ← decl.instantiate_value_univ_params f_lvls,
  new_e ← head_beta (expr.mk_app new_f e.get_app_args),
  return (u, new_e, tt)
in do (c, new_e) ← dsimplify_core () (λ c e, failed) unfold e {max_steps := cfg.max_steps, canonize_instances := cfg.visit_instances},
      return new_e

meta def delta_target (cs : list name) (cfg : delta_config := {}) : tactic unit :=
do t ← target, delta cs t cfg >>= unsafe_change

meta def delta_hyp (cs : list name) (h : expr) (cfg : delta_config := {}) :tactic unit :=
revert_and_transform (λ e, delta cs e cfg) h

structure unfold_proj_config extends dsimp_config :=
(md := transparency.instances)

/-- If `e` is a projection application, try to unfold it, otherwise fail. -/
meta constant unfold_proj (e : expr) (md := transparency.instances) : tactic expr

meta def unfold_projs (e : expr) (cfg : unfold_proj_config := {}) : tactic expr :=
let unfold (changed : bool) (e : expr) : tactic (bool × expr × bool) := do
  new_e ← unfold_proj e cfg.md,
  return (tt, new_e, tt)
in do (tt, new_e) ← dsimplify_core ff (λ c e, failed) unfold e cfg.to_dsimp_config | fail "no projections to unfold",
      return new_e

meta def unfold_projs_target (cfg : unfold_proj_config := {}) : tactic unit :=
do t ← target, unfold_projs t cfg >>= unsafe_change

meta def unfold_projs_hyp (h : expr) (cfg : unfold_proj_config := {}) : tactic unit :=
revert_and_transform (λ e, unfold_projs e cfg) h

structure simp_config :=
(max_steps : nat           := simp.default_max_steps)
(contextual : bool         := ff)
(lift_eq : bool            := tt)
(canonize_instances : bool := tt)
(canonize_proofs : bool    := ff)
(use_axioms : bool         := tt)
(zeta : bool               := tt)
(beta : bool               := tt)
(eta  : bool               := tt)
(proj : bool               := tt) -- reduce projections
(iota : bool               := tt)
(iota_eqn : bool           := ff) -- reduce using all equation lemmas generated by equation/pattern-matching compiler
(constructor_eq : bool     := tt)
(single_pass : bool        := ff)
(fail_if_unchanged         := tt)
(memoize                   := tt)
(trace_lemmas              := ff)

/--
  `simplify s e cfg r prove` simplify `e` using `s` using bottom-up traversal.
  `discharger` is a tactic for dischaging new subgoals created by the simplifier.
   If it fails, the simplifier tries to discharge the subgoal by simplifying it to `true`.

   The parameter `to_unfold` specifies definitions that should be delta-reduced,
   and projection applications that should be unfolded.
-/
meta constant simplify (s : simp_lemmas) (to_unfold : list name := []) (e : expr) (cfg : simp_config := {}) (r : name := `eq)
                       (discharger : tactic unit := failed) : tactic (expr × expr × name_set)

meta def simp_target (s : simp_lemmas) (to_unfold : list name := []) (cfg : simp_config := {}) (discharger : tactic unit := failed) : tactic name_set :=
do t ← target >>= instantiate_mvars,
   (new_t, pr, lms) ← simplify s to_unfold t cfg `eq discharger,
   replace_target new_t pr ``id_tag.simp,
   return lms

meta def simp_hyp (s : simp_lemmas) (to_unfold : list name := []) (h : expr) (cfg : simp_config := {}) (discharger : tactic unit := failed) : tactic (expr × name_set) :=
do when (expr.is_local_constant h = ff) (fail "tactic simp_at failed, the given expression is not a hypothesis"),
   htype ← infer_type h,
   (h_new_type, pr, lms) ← simplify s to_unfold htype cfg `eq discharger,
   new_hyp ← replace_hyp h h_new_type pr ``id_tag.simp,
   return (new_hyp, lms)

/--
`ext_simplify_core a c s discharger pre post r e`:

- `a : α` - initial user data
- `c : simp_config` - simp configuration options
- `s : simp_lemmas` - the set of simp_lemmas to use. Remark: the simplification lemmas are not applied automatically like in the simplify tactic. The caller must use them at pre/post.
- `discharger : α → tactic α` - tactic for dischaging hypothesis in conditional rewriting rules. The argument 'α' is the current user data.
- `pre a s r p e` is invoked before visiting the children of subterm 'e'.
  + arguments:
    - `a` is the current user data
    - `s` is the updated set of lemmas if 'contextual' is `tt`,
    - `r` is the simplification relation being used,
    - `p` is the "parent" expression (if there is one).
    - `e` is the current subexpression in question.
  + if it succeeds the result is `(new_a, new_e, new_pr, flag)` where
    - `new_a` is the new value for the user data
    - `new_e` is a new expression s.t. `r e new_e`
    - `new_pr` is a proof for `r e new_e`, If it is none, the proof is assumed to be by reflexivity
    - `flag`  if tt `new_e` children should be visited, and `post` invoked.
- `(post a s r p e)` is invoked after visiting the children of subterm `e`,
  The output is similar to `(pre a r s p e)`, but the 'flag' indicates whether the new expression should be revisited or not.
- `r` is the simplification relation. Usually `=` or `↔`.
- `e` is the input expression to be simplified.

The method returns `(a,e,pr)` where

 - `a` is the final user data
 - `e` is the new expression
 - `pr` is the proof that the given expression equals the input expression.

Note that `ext_simplify_core` will succeed even if `pre` and `post` fail, as failures are used to indicate that the method should move on to the next subterm.
If it is desirable to propagate errors from `pre`, they can be propagated through the "user data".
An easy way to do this is to call `tactic.capture (do ...)` in the parts of `pre`/`post` where errors matter, and then use `tactic.unwrap a` on the result.

Additionally, `ext_simplify_core` does not propagate changes made to the tactic state by `pre` and `post.
If it is desirable to propagate changes to the tactic state in addition to errors, use `tactic.resume` instead of `tactic.unwrap`.
-/
meta constant ext_simplify_core
  {α : Type}
  (a : α)
  (c : simp_config)
  (s : simp_lemmas)
  (discharger : α → tactic α)
  (pre : α → simp_lemmas → name → option expr → expr → tactic (α × expr × option expr × bool))
  (post : α → simp_lemmas  → name → option expr → expr → tactic (α × expr × option expr × bool))
  (r : name) :
  expr → tactic (α × expr × expr)

private meta def is_equation : expr → bool
| (expr.pi n bi d b) := is_equation b
| e                  := match (expr.is_eq e) with (some a) := tt | none := ff end

meta def collect_ctx_simps : tactic (list expr) :=
local_context

section simp_intros

meta def intro1_aux : bool → list name → tactic expr
| ff _       := intro1
| tt (n::ns) := intro n
| _  _       := failed

structure simp_intros_config extends simp_config :=
(use_hyps := ff)

meta def simp_intros_aux (cfg : simp_config) (use_hyps : bool) (to_unfold : list name) : simp_lemmas → bool → list name → tactic simp_lemmas
| S tt     [] := try (simp_target S to_unfold cfg) >> return S
| S use_ns ns := do
  t ← target,
  if t.is_napp_of `not 1 then
    intro1_aux use_ns ns >> simp_intros_aux S use_ns ns.tail
  else if t.is_arrow then
    do {
      d ← return t.binding_domain,
      (new_d, h_d_eq_new_d, lms) ← simplify S to_unfold d cfg,
      h_d ← intro1_aux use_ns ns,
      h_new_d ← mk_eq_mp h_d_eq_new_d h_d,
      assertv_core h_d.local_pp_name new_d h_new_d,
      clear h_d,
      h_new   ← intro1,
      new_S ← if use_hyps then mcond (is_prop new_d) (S.add h_new ff) (return S)
              else return S,
      simp_intros_aux new_S use_ns ns.tail
    }
    <|>
    -- failed to simplify... we just introduce and continue
    (intro1_aux use_ns ns >> simp_intros_aux S use_ns ns.tail)
  else if t.is_pi || t.is_let then
    intro1_aux use_ns ns >> simp_intros_aux S use_ns ns.tail
  else do
    new_t ← whnf t reducible,
    if new_t.is_pi then unsafe_change new_t >> simp_intros_aux S use_ns ns
    else
      try (simp_target S to_unfold cfg) >>
      mcond (expr.is_pi <$> target)
        (simp_intros_aux S use_ns ns)
        (if use_ns ∧ ¬ns.empty then failed else return S)

meta def simp_intros (s : simp_lemmas) (to_unfold : list name := []) (ids : list name := []) (cfg : simp_intros_config := {}) : tactic unit :=
step $ simp_intros_aux cfg.to_simp_config cfg.use_hyps to_unfold s (bnot ids.empty) ids

end simp_intros

meta def mk_eq_simp_ext (simp_ext : expr → tactic (expr × expr)) : tactic unit :=
do (lhs, rhs)     ← target >>= match_eq,
   (new_rhs, heq) ← simp_ext lhs,
   unify rhs new_rhs,
   exact heq

/- Simp attribute support -/

meta def to_simp_lemmas : simp_lemmas → list name → tactic simp_lemmas
| S []      := return S
| S (n::ns) := do S' ← (has_attribute `congr n >> S.add_congr n) <|> S.add_simp n ff, to_simp_lemmas S' ns

meta def mk_simp_attr (attr_name : name) (attr_deps : list name := []) : command :=
do let t := `(user_attribute simp_lemmas),
   let v := `({name     := attr_name,
               descr    := "simplifier attribute",
               cache_cfg := {
                 mk_cache := λ ns, do {
                          s ← tactic.to_simp_lemmas simp_lemmas.mk ns,
                          s ← attr_deps.mfoldl
                                (λ s attr_name, do
                                   ns ← attribute.get_instances attr_name,
                                   to_simp_lemmas s ns)
                                s,
                          return s },
                 dependencies := `reducibility :: attr_deps}} : user_attribute simp_lemmas),
   let n := mk_simp_attr_decl_name attr_name,
   add_decl (declaration.defn n [] t v reducibility_hints.abbrev ff),
   attribute.register n
/--
### Example usage:
```lean
-- make a new simp attribute called "my_reduction"
run_cmd mk_simp_attr `my_reduction
-- Add "my_reduction" attributes to these if-reductions
attribute [my_reduction] if_pos if_neg dif_pos dif_neg

-- will return the simp_lemmas with the `my_reduction` attribute.
#eval get_user_simp_lemmas `my_reduction

```
 -/
meta def get_user_simp_lemmas (attr_name : name) : tactic simp_lemmas :=
if attr_name = `default then simp_lemmas.mk_default
else get_attribute_cache_dyn (mk_simp_attr_decl_name attr_name)

meta def join_user_simp_lemmas_core : simp_lemmas → list name → tactic simp_lemmas
| S []             := return S
| S (attr_name::R) := do S' ← get_user_simp_lemmas attr_name, join_user_simp_lemmas_core (S.join S') R

meta def join_user_simp_lemmas (no_dflt : bool) (attrs : list name) : tactic simp_lemmas :=
do s ← simp_lemmas.mk_default,
   let s := if no_dflt then s.erase_simp_lemmas else s,
   join_user_simp_lemmas_core s attrs

meta def simplify_top_down {α} (a : α) (pre : α → expr → tactic (α × expr × expr)) (e : expr) (cfg : simp_config := {}) : tactic (α × expr × expr) :=
ext_simplify_core a cfg simp_lemmas.mk (λ _, failed)
  (λ a _ _ _ e, do (new_a, new_e, pr) ← pre a e, guard (¬ new_e =ₐ e), return (new_a, new_e, some pr, tt))
  (λ _ _ _ _ _, failed)
  `eq e

meta def simp_top_down (pre : expr → tactic (expr × expr)) (cfg : simp_config := {}) : tactic unit :=
do t                   ← target,
   (_, new_target, pr) ← simplify_top_down () (λ _ e, do (new_e, pr) ← pre e, return ((), new_e, pr)) t cfg,
   replace_target new_target pr ``id_tag.simp

meta def simplify_bottom_up {α} (a : α) (post : α → expr → tactic (α × expr × expr)) (e : expr) (cfg : simp_config := {}) : tactic (α × expr × expr) :=
ext_simplify_core a cfg simp_lemmas.mk (λ _, failed)
  (λ _ _ _ _ _, failed)
  (λ a _ _ _ e, do (new_a, new_e, pr) ← post a e, guard (¬ new_e =ₐ e), return (new_a, new_e, some pr, tt))
  `eq e

meta def simp_bottom_up (post : expr → tactic (expr × expr)) (cfg : simp_config := {}) : tactic unit :=
do t                   ← target,
   (_, new_target, pr) ← simplify_bottom_up () (λ _ e, do (new_e, pr) ← post e, return ((), new_e, pr)) t cfg,
   replace_target new_target pr ``id_tag.simp

private meta def remove_deps (s : name_set) (h : expr) : name_set :=
if s.empty then s
else h.fold s (λ e o s, if e.is_local_constant then s.erase e.local_uniq_name else s)

/- Return the list of hypothesis that are propositions and do not have
   forward dependencies. -/
meta def non_dep_prop_hyps : tactic (list expr) :=
do
  ctx ← local_context,
  s   ← ctx.mfoldl (λ s h, do
           h_type ← infer_type h,
           let s := remove_deps s h_type,
           h_val  ← head_zeta h,
           let s := if h_val =ₐ h then s else remove_deps s h_val,
           mcond (is_prop h_type)
             (return $ s.insert h.local_uniq_name)
             (return s)) mk_name_set,
  t   ← target,
  let s := remove_deps s t,
  return $ ctx.filter (λ h, s.contains h.local_uniq_name)

section simp_all

meta structure simp_all_entry :=
(h        : expr) -- hypothesis
(new_type : expr) -- new type
(pr       : option expr) -- proof that type of h is equal to new_type
(s        : simp_lemmas) -- simplification lemmas for simplifying new_type

private meta def update_simp_lemmas (es : list simp_all_entry) (h : expr) : tactic (list simp_all_entry) :=
es.mmap $ λ e, do new_s ← e.s.add h ff, return {s := new_s, ..e}

/- Helper tactic for `init`.
   Remark: the following tactic is quadratic on the length of list expr (the list of non dependent propositions).
   We can make it more efficient as soon as we have an efficient simp_lemmas.erase. -/
private meta def init_aux : list expr → simp_lemmas → list simp_all_entry → tactic (simp_lemmas × list simp_all_entry)
| []      s r := return (s, r)
| (h::hs) s r := do
  new_r  ← update_simp_lemmas r h,
  new_s  ← s.add h ff,
  h_type ← infer_type h,
  init_aux hs new_s (⟨h, h_type, none, s⟩::new_r)

private meta def init (s : simp_lemmas) (hs : list expr) : tactic (simp_lemmas × list simp_all_entry) :=
init_aux hs s []

private meta def add_new_hyps (es : list simp_all_entry) : tactic unit :=
es.mmap' $ λ e,
   match e.pr with
   | none    := return ()
   | some pr :=
      assert e.h.local_pp_name e.new_type >>
      mk_eq_mp pr e.h >>= exact
   end

private meta def clear_old_hyps (es : list simp_all_entry) : tactic unit :=
es.mmap' $ λ e, when (e.pr ≠ none) (try (clear e.h))

private meta def join_pr : option expr → expr → tactic expr
| none       pr₂ := return pr₂
| (some pr₁) pr₂ := mk_eq_trans pr₁ pr₂

private meta def loop (cfg : simp_config) (discharger : tactic unit) (to_unfold : list name)
                      : list simp_all_entry → list simp_all_entry → simp_lemmas → bool → tactic name_set
| []      r  s m :=
  if m then loop r [] s ff
  else do
    add_new_hyps r,
    (lms, target_changed) ← (simp_target s to_unfold cfg discharger >>= λ ns, return (ns, tt)) <|>
                            (return (mk_name_set, ff)),
    guard (cfg.fail_if_unchanged = ff ∨ target_changed ∨ r.any (λ e, e.pr ≠ none)) <|> fail "simp_all tactic failed to simplify",
    clear_old_hyps r,
    return lms
| (e::es) r  s m := do
   let ⟨h, h_type, h_pr, s'⟩ := e,
   (new_h_type, new_pr, lms) ← simplify s' to_unfold h_type {fail_if_unchanged := ff, ..cfg} `eq discharger,
   if h_type =ₐ new_h_type then do
     new_lms ← loop es (e::r) s m,
     return (new_lms.fold lms (λ n ns, name_set.insert ns n))
   else do
     new_pr      ← join_pr h_pr new_pr,
     new_fact_pr ← mk_eq_mp new_pr h,
     if new_h_type = `(false) then do
       tgt         ← target,
       to_expr ``(@false.rec %%tgt %%new_fact_pr) >>= exact,
       return (mk_name_set)
     else do
       h0_type     ← infer_type h,
       let new_fact_pr := mk_tagged_proof new_h_type new_fact_pr ``id_tag.simp,
       new_es      ← update_simp_lemmas es new_fact_pr,
       new_r       ← update_simp_lemmas r new_fact_pr,
       let new_r := {new_type := new_h_type, pr := new_pr, ..e} :: new_r,
       new_s       ← s.add new_fact_pr ff,
       new_lms ← loop new_es new_r new_s tt,
       return (new_lms.fold lms (λ n ns, name_set.insert ns n))

meta def simp_all (s : simp_lemmas) (to_unfold : list name) (cfg : simp_config := {}) (discharger : tactic unit := failed) : tactic name_set :=
do hs      ← non_dep_prop_hyps,
   (s, es) ← init s hs,
   loop cfg discharger to_unfold es [] s ff

end simp_all

/- debugging support for algebraic normalizer -/

meta constant trace_algebra_info : expr → tactic unit

end tactic

export tactic (mk_simp_attr)

run_cmd mk_simp_attr `norm [`simp]


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.smt.smt_tactic init.meta.fun_info init.meta.rb_map

def tactic.id_tag.rsimp : unit := ()

open tactic

private meta def add_lemma (m : transparency) (h : name) (hs : hinst_lemmas) : tactic hinst_lemmas :=
(do h ← hinst_lemma.mk_from_decl_core m h tt, return $ hs.add h) <|> return hs

private meta def to_hinst_lemmas (m : transparency) (ex : name_set) : list name → hinst_lemmas → tactic hinst_lemmas
| []      hs := return hs
| (n::ns) hs :=
  if ex.contains n then to_hinst_lemmas ns hs else
  let add n := add_lemma m n hs >>= to_hinst_lemmas ns
  in do eqns   ← tactic.get_eqn_lemmas_for tt n,
  match eqns with
  | []  := add n
  | _   := mcond (is_prop_decl n) (add n) (to_hinst_lemmas eqns hs >>= to_hinst_lemmas ns)
  end

/-- Create a rsimp attribute named `attr_name`, the attribute declaration is named `attr_decl_name`.
    The cached hinst_lemmas structure is built using the lemmas marked with simp attribute `simp_attr_name`,
    but *not* marked with `ex_attr_name`.

    We say `ex_attr_name` is the "exception set". It is useful for excluding lemmas in `simp_attr_name`
    which are not good or redundant for ematching. -/
meta def mk_hinst_lemma_attr_from_simp_attr (attr_decl_name attr_name : name) (simp_attr_name : name) (ex_attr_name : name) : command :=
do let t := `(user_attribute hinst_lemmas),
   let v := `({name     := attr_name,
               descr    := sformat!"hinst_lemma attribute derived from '{simp_attr_name}'",
               cache_cfg := {
                 mk_cache := λ ns,
                 let aux := simp_attr_name in
                 let ex_attr := ex_attr_name in
                 do {
                   hs   ← to_hinst_lemmas reducible mk_name_set ns hinst_lemmas.mk,
                   ss   ← attribute.get_instances aux,
                   ex   ← get_name_set_for_attr ex_attr,
                   to_hinst_lemmas reducible ex ss hs
                 },
                 dependencies := [`reducibility, simp_attr_name]}} : user_attribute hinst_lemmas),
   add_decl (declaration.defn attr_decl_name [] t v reducibility_hints.abbrev ff),
   attribute.register attr_decl_name

run_cmd mk_name_set_attr `no_rsimp
run_cmd mk_hinst_lemma_attr_from_simp_attr `rsimp_attr `rsimp `simp `no_rsimp

/- The following lemmas are not needed by rsimp, and they actually hurt performance since they generate a lot of
   instances. -/
attribute [no_rsimp]
  id.def ne.def not_true not_false_iff ne_self_iff_false eq_self_iff_true heq_self_iff_true iff_not_self not_iff_self
  true_iff_false false_iff_true and.comm and.assoc and.left_comm and_true true_and and_false false_and not_and_self and_not_self
  and_self or.comm or.assoc or.left_comm or_true true_or or_false false_or or_self iff_true true_iff iff_false false_iff
  iff_self implies_true_iff false_implies_iff if_t_t if_true if_false

namespace rsimp

meta def is_value_like : expr → bool
| e :=
  if ¬ e.is_app then ff
  else let fn    := e.get_app_fn in
   if ¬ fn.is_constant then ff
   else let nargs := e.get_app_num_args,
            fname := fn.const_name in
     if      fname = ``has_zero.zero ∧ nargs = 2 then tt
     else if fname = ``has_one.one ∧ nargs = 2 then tt
     else if fname = ``bit0 ∧ nargs = 3 then is_value_like e.app_arg
     else if fname = ``bit1 ∧ nargs = 4 then is_value_like e.app_arg
     else if fname = ``char.of_nat ∧ nargs = 1 then is_value_like e.app_arg
     else ff

/-- Return the size of term by considering only explicit arguments. -/
meta def explicit_size : expr → tactic nat
| e :=
  if ¬ e.is_app then return 1
  else if is_value_like e then return 1
  else fold_explicit_args e 1
    (λ n arg, do r ← explicit_size arg, return $ r + n)

/-- Choose smallest element (with respect to explicit_size) in `e`s equivalence class. -/
meta def choose (ccs : cc_state) (e : expr) : tactic expr :=
do sz ← explicit_size e,
   p  ← ccs.mfold_eqc e (e, sz) $ λ p e',
     if p.2 = 1 then return p
     else do {
       sz' ← explicit_size e',
       if sz' < p.2 then return (e', sz')
       else return p
     },
   return p.1

meta def repr_map := expr_map expr
meta def mk_repr_map := expr_map.mk expr

meta def to_repr_map (ccs : cc_state) : tactic repr_map :=
ccs.roots.mfoldl (λ S e, do r ← choose ccs e, return $ S.insert e r) mk_repr_map

meta def rsimplify (ccs : cc_state) (e : expr) (m : option repr_map := none) : tactic (expr × expr) :=
do m ← match m with
       | none   := to_repr_map ccs
       | some m := return m
       end,
   r ← simplify_top_down () (λ _ t,
         do root  ← return $ ccs.root t,
            new_t ← m.find root,
            guard (¬ new_t =ₐ t),
            prf   ← ccs.eqv_proof t new_t,
            return ((), new_t, prf))
         e,
   return r.2

structure config :=
(attr_name   := `rsimp_attr)
(max_rounds  := 8)

open smt_tactic

private def tagged_proof.rsimp : unit := ()

meta def collect_implied_eqs (cfg : config := {}) (extra := hinst_lemmas.mk) : tactic cc_state :=
do focus1 $ using_smt_with {em_attr := cfg.attr_name} $
   do
     add_lemmas_from_facts,
     add_lemmas extra,
     iterate_at_most cfg.max_rounds (ematch >> try smt_tactic.close),
     (done >> return cc_state.mk)
     <|>
     to_cc_state

meta def rsimplify_goal (ccs : cc_state) (m : option repr_map := none) : tactic unit :=
do t           ← target,
   (new_t, pr) ← rsimplify ccs t m,
   try (replace_target new_t pr ``id_tag.rsimp)

meta def rsimplify_at (ccs : cc_state) (h : expr) (m : option repr_map := none) : tactic unit :=
do when (expr.is_local_constant h = ff) (tactic.fail "tactic rsimplify_at failed, the given expression is not a hypothesis"),
   htype            ← infer_type h,
   (new_htype, heq) ← rsimplify ccs htype m,
   try $ do assert (expr.local_pp_name h) new_htype,
            mk_eq_mp heq h >>= exact,
            try $ clear h
end rsimp

open rsimp

namespace tactic

meta def rsimp (cfg : config := {}) (extra := hinst_lemmas.mk) : tactic unit :=
do ccs ← collect_implied_eqs cfg extra,
   try $ rsimplify_goal ccs

meta def rsimp_at (h : expr) (cfg : config := {}) (extra := hinst_lemmas.mk) : tactic unit :=
do ccs ← collect_implied_eqs cfg extra,
   try $ rsimplify_at ccs h

namespace interactive

/- TODO(Leo): allow user to provide extra lemmas manually -/
meta def rsimp : tactic unit :=
tactic.rsimp

end interactive
end tactic


import ..utils.util
import all

section main

meta def main : io unit := do {
  args ← io.cmdline_args,
  names_file ← args.nth_except 0 "names_file",
  dest ← args.nth_except 1 "dest",
  nm_strs ← (io.mk_file_handle names_file io.mode.read >>= λ f,
    (string.split (λ c, c = '\n') <$> buffer.to_string <$> io.fs.read_to_end f)),

  (nms : list (name × list name)) ← (nm_strs.filter $ λ nm_str, string.length nm_str > 0).mmap $ λ nm_str, do {
    ((io.run_tactic' ∘ parse_decl_nm_and_open_ns) $ nm_str)
  },

  dest_handle ← io.mk_file_handle dest io.mode.write,

  io.run_tactic' $ do {
    env ← tactic.get_env,
    for_ nms $ λ ⟨nm, open_ns⟩, tactic.try $ do {
      decl ← env.get nm,
      if decl.is_theorem then do {
        tactic.trace format! "[filter_defs] KEEPING {nm.to_string}",
        tactic.unsafe_run_io $
          io.fs.put_str_ln_flush
            dest_handle
              (nm.to_string ++ " " ++ (" ".intercalate $ name.to_string <$> open_ns))
      } else do {
        tactic.trace format! "[filter_defs] DISCARDING {nm.to_string}",
        pure ()
      }
    }
  }
}

end main


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
Ported by: E.W.Ayers
-/
import Lean
import Lean.Data

open Lean
open Lean.Elab
open Lean.Elab.Command

/--
__DEPRECATED__: `restate_axiom` was necessary in Lean 3 but is no longer needed for Lean 4.
It is still present for backwards compatibility but will probably be removed in the future.

# Original Docstring

`restate_axiom` makes a new copy of a structure field, first definitionally simplifying the type.
This is useful to remove `auto_param` or `opt_param` from the statement.

As an example, we have:
```lean
structure A :=
(x : ℕ)
(a' : x = 1 . skip)

example (z : A) : z.x = 1 := by rw A.a' -- rewrite tactic failed, lemma is not an equality nor a iff

restate_axiom A.a'
example (z : A) : z.x = 1 := by rw A.a
```

By default, `restate_axiom` names the new lemma by removing a trailing `'`, or otherwise appending
`_lemma` if there is no trailing `'`. You can also give `restate_axiom` a second argument to
specify the new name, as in
```lean
restate_axiom A.a f
example (z : A) : z.x = 1 := by rw A.f
```
-/
elab "restate_axiom " oldName:ident newName:optional(ident) : command => do
  let oldName ← resolveGlobalConstNoOverloadWithInfo oldName
  let newName : Name :=
    match newName with
      | none =>
        match oldName with
        | Name.str n s =>
          if s.back = '\'' then
            Name.mkStr n $ s.extract 0 (s.endPos - ⟨1⟩)
          else
            Name.mkStr n $ s ++ "_lemma"
        | x => x
      | some n => Name.getPrefix oldName ++ n.getId
  liftCoreM do
    match ← getConstInfo oldName with
    | ConstantInfo.defnInfo info =>
      addAndCompile <| .defnDecl { info with name := newName }
    | ConstantInfo.thmInfo info =>
      addAndCompile <| .thmDecl { info with name := newName }
    | _ => throwError "Constant {oldName} is not a definition or theorem."


import Lean
import Lean.Meta
-- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/benchmarking.20commands/near/249677507

section
open Lean Elab Command

syntax (name := timeCmd)  "#time " command : command

@[commandElab timeCmd] def elabTimeCmd : CommandElab
  | `(#time%$tk $stx:command) => do
    let start ← IO.monoMsNow
    elabCommand stx
    logInfoAt tk m!"time: {(← IO.monoMsNow) - start}ms"
  | _ => throwUnsupportedSyntax

end
/-
set_option maxRecDepth 200000 in
#time example : (List.range 5100).length = 5100 := rfl
-/


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.bool.basic
import meta.rb_map
import tactic.core

/-!
# list_unused_decls

`#list_unused_decls` is a command used for theory development.
When writing a new theory one often tries
multiple variations of the same definitions: `foo`, `foo'`, `foo₂`,
`foo₃`, etc. Once the main definition or theorem has been written,
it's time to clean up and the file can contain a lot of dead code.
Mark the main declarations with `@[main_declaration]` and
`#list_unused_decls` will show the declarations in the file
that are not needed to define the main declarations.

Some of the so-called "unused" declarations may turn out to be useful
after all. The oversight can be corrected by marking those as
`@[main_declaration]`. `#list_unused_decls` will revise the list of
unused declarations. By default, the list of unused declarations will
not include any dependency of the main declarations.

The `@[main_declaration]` attribute should be removed before submitting
code to mathlib as it is merely a tool for cleaning up a module.
-/

namespace tactic

/-- Attribute `main_declaration` is used to mark declarations that are featured
in the current file.  Then, the `#list_unused_decls` command can be used to
list the declaration present in the file that are not used by the main
declarations of the file. -/
@[user_attribute]
meta def main_declaration_attr : user_attribute :=
{ name := `main_declaration,
  descr := "tag essential declarations to help identify unused definitions" }

/-- `update_unsed_decls_list n m` removes from the map of unneeded declarations those
referenced by declaration named `n` which is considerred to be a
main declaration -/
private meta def update_unsed_decls_list :
  name → name_map declaration → tactic (name_map declaration)
| n m :=
  do d ← get_decl n,
     if m.contains n then do
       let m := m.erase n,
       let ns := d.value.list_constant.union d.type.list_constant,
       ns.mfold m update_unsed_decls_list
     else pure m

/-- In the current file, list all the declaration that are not marked as `@[main_declaration]` and
that are not referenced by such declarations -/
meta def all_unused (fs : list (option string)) : tactic (name_map declaration) :=
do ds ← get_decls_from fs,
   ls ← ds.keys.mfilter (succeeds ∘ user_attribute.get_param_untyped main_declaration_attr),
   ds ← ls.mfoldl (flip update_unsed_decls_list) ds,
   ds.mfilter $ λ n d, do
     e ← get_env,
     return $ !d.is_auto_or_internal e

/-- expecting a string literal (e.g. `"src/tactic/find_unused.lean"`)
-/
meta def parse_file_name (fn : pexpr) : tactic (option string) :=
some <$> (to_expr fn >>= eval_expr string) <|> fail "expecting: \"src/dir/file-name\""

setup_tactic_parser

/-- The command `#list_unused_decls` lists the declarations that that
are not used the main features of the present file. The main features
of a file are taken as the declaration tagged with
`@[main_declaration]`.

A list of files can be given to `#list_unused_decls` as follows:

```lean
#list_unused_decls ["src/tactic/core.lean","src/tactic/interactive.lean"]
```

They are given in a list that contains file names written as Lean
strings. With a list of files, the declarations from all those files
in addition to the declarations above `#list_unused_decls` in the
current file will be considered and their interdependencies will be
analyzed to see which declarations are unused by declarations marked
as `@[main_declaration]`. The files listed must be imported by the
current file. The path of the file names is expected to be relative to
the root of the project (i.e. the location of `leanpkg.toml` when it
is present).

Neither `#list_unused_decls` nor `@[main_declaration]` should appear
in a finished mathlib development. -/
@[user_command]
meta def unused_decls_cmd (_ : parse $ tk "#list_unused_decls") : lean.parser unit :=
do fs ← pexpr_list,
   show tactic unit, from
   do fs ← fs.mmap parse_file_name,
      ds ← all_unused $ none :: fs,
      ds.to_list.mmap' $ λ ⟨n,_⟩, trace!"#print {n}"

add_tactic_doc
{ name                     := "#list_unused_decls",
  category                 := doc_category.cmd,
  decl_names               := [`tactic.unused_decls_cmd],
  tags                     := ["debugging"] }

end tactic


theorem ex1 : True := sorry


/-
Copyright 2022 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    https://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

Authors: Moritz Firsching
-/
import tactic
/-!
# On a lemma of Littlewook and Offord

## TODO
  - statement
    - proof
      - Claim
-/


import data.fix.inductive_decl
import mvqpf
import data.fix.equations
import category.bitraversable.instances

universes u

lemma foo {n} {p : mvpfunctor n} {v} (C : p.apply v → Sort*) {a : p.A} {f g : p.B a ⟹ v} (h : f = g) (x : C ⟨a,f⟩) : C ⟨a,g⟩ :=
by cases h; apply x

namespace tactic

open native

meta def map_arg' (m : rb_map expr expr) : expr → expr → tactic expr
| e (expr.pi n bi d b) :=
do v ← mk_local' n bi d,
   e' ← head_beta (e v) >>= whnf,
   map_arg' e' (b.instantiate_var v) >>= lambdas [v]
| e v@(expr.local_const _ _ _ _) :=
do some f ← pure $ m.find v | pure e,
   pure $ f e
| e _ := pure e

meta def map_arg (m : rb_map expr expr) (e : expr) : tactic expr :=
infer_type e >>= whnf >>= map_arg' m e

meta def find_dead_occ (n : name) (ps : list expr) : rb_map expr ℕ → expr → rb_map expr ℕ
| m `(%%a → %%b) := find_dead_occ (a.list_local_consts.foldl rb_map.erase m) b
| m (expr.local_const _ _ _ _) := m
| m e :=
if e.get_app_fn.const_name = n
  then m
  else e.list_local_consts.foldl rb_map.erase m

meta def live_vars (induct : inductive_type) : tactic $ rb_map expr ℕ × rb_map expr ℕ :=
do let n := induct.name,
   let params : list expr := induct.params,
   let e := (@expr.const tt n induct.u_params).mk_app params,
   let vs := rb_map.of_list $ params.enum.map prod.swap,
   let ls := induct.ctors,
   ls ← ls.mmap $ λ c,
     do { ts ← c.args.mmap infer_type,
          pure $ ts.foldl (find_dead_occ n params) vs },
   let m := ls.foldl rb_map.intersect vs,
   m.mfilter $ λ e _, expr.is_sort <$> infer_type e,
   let m' := vs.difference m,
   pure (m,m')

meta instance : has_repr expr := ⟨ to_string ⟩
meta instance task.has_repr {α} [has_repr α] : has_repr (task α) := ⟨ repr ∘ task.get ⟩

open level
meta def level.repr : level → ℕ → string
| zero n := repr n
| (succ a) n := level.repr a n.succ
| (max x y) n := sformat!"(max {level.repr x n} {level.repr y n})"
| (imax x y) n := sformat!"(imax {level.repr x n} {level.repr y n})"
| (param a) n := if n = 0 then repr a
                          else sformat!"({n} + {repr a})"
| (mvar a) n := if n = 0 then repr a
                         else sformat!"({n} + {repr a})"

meta instance level.has_repr : has_repr level := ⟨ λ l, level.repr l 0 ⟩

attribute [derive has_repr] reducibility_hints declaration type_cnstr inductive_type

@[derive has_repr]
meta structure internal_mvfunctor :=
(decl : declaration)
(induct : inductive_type)
(def_name eqn_name map_name abs_name repr_name pfunctor_name : name)
(univ_params : list level)
(vec_lvl : level)
(live_params : list $ expr × ℕ)
(dead_params : list $ expr × ℕ)
(params : list expr)
(type : expr)

meta def mk_inductive' : inductive_type → lean.parser unit
| decl :=
do let n₀ := name.anonymous,
   t ← pis decl.idx decl.type,
   cn ← mk_local_def (decl.name.replace_prefix decl.pre n₀) t,
   brs ← decl.ctors.mmap $ λ c,
       do { let rt := cn.mk_app c.result,
            t ← pis c.args rt,
            pure format!"| {(c.name.update_prefix n₀).to_string} : {expr.parsable_printer t}" },
   args ← decl.params.mmap $ λ p,
     do { t ← infer_type p,
          pure $ expr.fmt_binder p.local_pp_name p.binding_info (expr.parsable_printer t) },
   let xs := format!"
inductive {cn} {format.intercalate \" \" args} : {expr.parsable_printer t}
{format.intercalate \"\n\" brs}",
   lean.parser.with_input lean.parser.command_like xs.to_string,
   pure ()

meta def internalize_mvfunctor (ind : inductive_type) : tactic internal_mvfunctor :=
do let decl := declaration.cnst ind.name ind.u_names ind.type tt,
   let n := decl.to_name,
   let df_name := n <.> "internal",
   let lm_name := n <.> "internal_eq",
   -- decl ← get_decl n,
   (params,t) ← mk_local_pis decl.type,
   let params := ind.params ++ params,
   (m,m') ← live_vars ind,
   let m := rb_map.sort prod.snd m.to_list,
   let m' := rb_map.sort prod.snd m'.to_list,
   u ← mk_meta_univ,
   let vars := string.intercalate "," (m.map to_string),
   (params.mmap' (λ e, infer_type e >>= unify (expr.sort u))
     <|> fail format!"live type parameters ({params}) are not in the same universe" : tactic _),
   (level.succ u) ← get_univ_assignment u <|> pure level.zero.succ,
   ts ← (params.mmap infer_type : tactic _),
   pure { decl := decl,
          induct := ind,
          def_name := df_name,
          eqn_name := lm_name,
          map_name := (df_name <.> "map"),
          abs_name := (df_name <.> "abs"),
          repr_name := (df_name <.> "repr"),
          pfunctor_name := n <.> "pfunctor",
          vec_lvl := u,
          univ_params := decl.univ_params.map level.param,
          live_params := m,
          dead_params := m',
          params := params,
          type := t }

notation `⦃ ` r:( foldr `, ` (h t, typevec.append1 t h) fin'.elim0 ) ` ⦄` := r
notation `⦃`  `⦄` := fin'.elim0

local prefix `♯`:0 := cast (by try { simp only with typevec }; congr' 1; try { simp only with typevec })

meta def mk_internal_functor_def (func : internal_mvfunctor) : tactic unit :=
do let trusted := func.decl.is_trusted,
   let arity := func.live_params.length,
   let vec := @expr.const tt ``_root_.typevec [func.vec_lvl] `(arity),
   v_arg ← mk_local_def `v_arg vec,
   t ← pis (func.dead_params.map prod.fst ++ [v_arg]) func.type,
   (_,df) ← @solve_aux unit t $ do
     { m' ← func.dead_params.mmap $ λ v, prod.mk v.2 <$> intro v.1.local_pp_name,
       vs ← func.live_params.reverse.mmap $ λ x, do
         { refine ``(typevec.typevec_cases_cons _ _),
           x' ← intro x.1.local_pp_name,
           pure (x.2,x') },
       refine ``(typevec.typevec_cases_nil _),
       let args := (rb_map.sort prod.fst (m' ++ vs)).map prod.snd,
       let e := (@expr.const tt func.decl.to_name (func.decl.univ_params.map level.param)).mk_app args,
       exact e },
   df ← instantiate_mvars df,
   add_decl $ declaration.defn func.def_name func.decl.univ_params t df (reducibility_hints.regular 1 tt) trusted

meta def mk_live_vec (u : level) (vs : list expr) : tactic expr :=
do nil ← mk_mapp ``fin'.elim0 [@expr.sort tt $ level.succ u],
   vs.reverse.mfoldr (λ e s, mk_mapp ``typevec.append1 [none,s,e]) nil

meta def mk_map_vec (u : level) (vs : list expr) : tactic expr :=
do let nil := @expr.const tt ``typevec.nil_fun [u,u],
   vs.reverse.mfoldr (λ e s,
     mk_mapp ``typevec.append_fun [none,none,none,none,none,s,e]) nil

meta def mk_internal_functor_app (func : internal_mvfunctor) : tactic expr :=
do let decl := func.decl,
   vec ← mk_live_vec func.vec_lvl $ func.live_params.map prod.fst,
   pure $ (@expr.const tt func.def_name decl.univ_levels).mk_app (func.dead_params.map prod.fst ++ [vec])

meta def mk_internal_functor_eqn (func : internal_mvfunctor) : tactic unit :=
do let decl := func.decl,
   lhs ← mk_internal_functor_app func,
   let rhs := (@expr.const tt decl.to_name decl.univ_levels).mk_app func.params,
   p ← mk_app `eq [lhs,rhs] >>= pis func.params,
   (_,pr) ← solve_aux p $ intros >> reflexivity,
   pr ← instantiate_mvars pr,
   add_decl $ declaration.thm func.eqn_name decl.univ_params p (pure pr)

-- meta def mk_internal_functor (n : name) : tactic internal_mvfunctor :=
-- do decl ← get_decl n,
--    func ← internalize_mvfunctor decl,
--    mk_internal_functor_def func,
--    mk_internal_functor_eqn func,
--    pure func

meta def mk_internal_functor' (d : interactive.inductive_decl) : lean.parser internal_mvfunctor :=
do d ← inductive_type.of_decl d,
   mk_inductive' d,
   func ← internalize_mvfunctor d,
   mk_internal_functor_def func,
   mk_internal_functor_eqn func,
   pure func

open typevec

meta def destruct_typevec₃ (func : internal_mvfunctor) (v : name) : tactic (list $ expr × expr × expr × ℕ) :=
do vs ← func.live_params.reverse.mmap $ λ x : expr × ℕ, do
     { refine ``(typevec_cases_cons₃ _ _),
       α ← get_unused_name `α >>= intro,
       β ← get_unused_name `β >>= intro,
       f ← get_unused_name `f >>= intro,
       pure (α,β,f,x.2) },
   refine ``(typevec_cases_nil₃ _),
   pure vs

meta def destruct_typevec' (func : internal_mvfunctor) (v : name) : tactic (list $ expr × ℕ) :=
do vs ← func.live_params.reverse.mmap $ λ x : expr × ℕ, do
     { refine ``(typevec_cases_cons _ _),
       α ← get_unused_name `α >>= intro,
       pure (α,x.2) },
   refine ``(typevec_cases_nil _),
   pure vs

def mk_arg_list {α} (xs : list (α × ℕ)) : list α :=
(rb_map.sort prod.snd xs).map prod.fst

meta def internal_expr (func : internal_mvfunctor) :=
(@expr.const tt func.def_name func.decl.univ_levels).mk_app (func.dead_params.map prod.fst)

meta def functor_expr (func : internal_mvfunctor) :=
(@expr.const tt func.pfunctor_name func.decl.univ_levels).mk_app (func.dead_params.map prod.fst)

meta def mk_mvfunctor_map (func : internal_mvfunctor) : tactic expr :=
do let decl := func.decl,
   let intl := internal_expr func,
   let arity := func.live_params.length,
   α ← mk_local_def `α $ @expr.const tt ``typevec [func.vec_lvl] `(arity),
   β ← mk_local_def `β $ @expr.const tt ``typevec [func.vec_lvl] `(arity),
   f ← mk_app ``typevec.arrow [α,β] >>= mk_local_def `f,
   let r := expr.imp (intl α) (intl β),

   map_t ← pis (func.dead_params.map prod.fst ++ [α,β,f]) r,
   (_,df) ← @solve_aux unit map_t $ do
     { vs ← intron' func.dead_params.length,
       let vs := vs.zip $ func.dead_params.map prod.snd,
       mαβf ← destruct_typevec₃ func `α,
       let m := rb_map.of_list $ mαβf.map $ λ ⟨α,β,f,i⟩, (α,f),
       let β := mαβf.map $ λ ⟨α,β,f,i⟩, (β,i),
       target >>= instantiate_mvars >>= unsafe_change,
       let e := (@expr.const tt func.eqn_name func.decl.univ_levels),
       g ← target,
       (g',_) ← solve_aux g $
         repeat (rewrite_target e) >> target,
       unsafe_change g',
       x ← intro1,
       xs ← cases_core x,
       xs.mmap' $ λ ⟨c, args, _⟩, do
         { let e := (@expr.const tt c decl.univ_levels).mk_app $ mk_arg_list (vs ++ β),
           args' ← args.mmap (map_arg m),
           exact $ e.mk_app args' } },
   df ← instantiate_mvars df,
   add_decl' $ declaration.defn func.map_name decl.univ_params map_t df (reducibility_hints.regular 1 tt) decl.is_trusted

meta def mk_mvfunctor_map_eqn (func : internal_mvfunctor) : tactic unit :=
do env ← get_env,
   let decl := func.decl,
   let cs := env.constructors_of func.decl.to_name,
   live_params' ← func.live_params.mmap $ λ ⟨v,i⟩, flip prod.mk i <$> (infer_type v >>= mk_local_def (add_prime v.local_pp_name)),
   let arity := live_params'.length,
   fs ← mzip_with (λ v v' : expr × ℕ, prod.mk v.1 <$> mk_local_def ("f" ++ to_string v.2 : string) (v.1.imp v'.1)) func.live_params live_params',
   let m := rb_map.of_list fs,
   cs.enum.mmap' $ λ ⟨i,c⟩, do
     { let c := @expr.const tt c func.decl.univ_levels,
       let e := c.mk_app func.params,
       let e' := c.mk_app $ mk_arg_list $ func.dead_params ++ live_params',
       t  ← infer_type e,
       (vs,_) ← mk_local_pis t,
       t' ← infer_type e',
       vs' ← vs.mmap (map_arg m),
       α ← mk_live_vec func.vec_lvl (mk_arg_list func.live_params),
       β ← mk_live_vec func.vec_lvl (mk_arg_list live_params'),
       f ← mk_map_vec func.vec_lvl $ fs.map prod.snd,
       let x := e.mk_app vs,
       let map_e := (@expr.const tt func.map_name func.decl.univ_levels).mk_app (mk_arg_list func.dead_params ++ [α,β,f,x]),
       eqn ← mk_app `eq [map_e,(e'.mk_app vs')] >>= pis (func.params ++ live_params'.map prod.fst ++ fs.map prod.snd ++ vs),
       (_,pr) ← solve_aux eqn $ do
         { intros >> reflexivity },
       pr ← instantiate_mvars pr,
       add_decl $ declaration.thm (func.map_name <.> ("_equation_" ++ to_string i)) decl.univ_params eqn (pure pr),
       pure () }

meta def mk_mvfunctor_instance (func : internal_mvfunctor) : tactic unit :=
do map_d ← mk_mvfunctor_map func,
   mk_mvfunctor_map_eqn func,
   vec ← mk_live_vec func.vec_lvl $ func.live_params.map prod.fst,
   let decl := func.decl,
   let intl := (@expr.const tt func.def_name decl.univ_levels).mk_app (func.dead_params.map prod.fst),
   let vs := (func.dead_params.map prod.fst),

   t ← mk_app ``mvfunctor [intl] >>= pis vs,
   (_,df) ← @solve_aux unit t $ do
     { vs ← intro_lst $ vs.map expr.local_pp_name,
       to_expr ``( { mvfunctor . map := %%(map_d.mk_app vs) } ) >>= exact },
   df ← instantiate_mvars df,
   let inst_n := func.def_name <.> "mvfunctor",
   add_decl $ declaration.defn inst_n func.decl.univ_params t df (reducibility_hints.regular 1 tt) func.decl.is_trusted,
   set_basic_attribute `instance inst_n,
   pure ()

open expr (const)

meta def mk_head_t (decl : inductive_type) (func : internal_mvfunctor) : lean.parser inductive_type :=
do let n := decl.name,
   let head_n := (n <.> "head_t"),
   let sig_c  : expr := const n decl.u_params,
   cs ← decl.ctors.mmap $ λ d : type_cnstr,
   do { vs' ← d.args.mfilter $ λ v,
          do { t ← infer_type v,
               pure $ ¬ ∃ v ∈ func.live_params, expr.occurs (prod.fst v) t },
        pure { name := d.name.update_prefix head_n, args := vs', .. d } },
   let decl' := { name := head_n, ctors := cs, params := func.dead_params.map prod.fst, .. decl },
   decl' <$ mk_inductive' decl'

meta def mk_child_t (decl : inductive_type) (func : internal_mvfunctor) : lean.parser (list inductive_type) :=
do let n := decl.name,
   let mk_constr : name → expr := λ n', (const (n'.update_prefix $ n <.> "head_t") decl.u_params).mk_app $ func.dead_params.map prod.fst,
   let head_t : expr := const (n <.> "head_t") decl.u_params,
   func.live_params.mmap $ λ l,
     do let child_n := (n <.> "child_t" ++ l.1.local_pp_name),
        let sig_c  : expr := const n decl.u_params,
        cs ← (decl.ctors.mmap $ λ d : type_cnstr,
          do { (rec,vs') ← d.args.mpartition $ λ v,
                 do { t ← infer_type v,
                      pure $ expr.occurs l.1 t },
               vs' ← vs'.mfilter $ λ v,
                 do { t ← infer_type v,
                      pure $ ¬ ∃ v ∈ func.live_params, expr.occurs (prod.fst v) t },
               rec.enum.mmap $ λ ⟨i,r⟩, do
                 (args',r') ← infer_type r >>= unpi,
                 pure { name := (d.name.append_after i).update_prefix $ n <.> "child_t"  ++ l.1.local_pp_name,
                        args := vs' ++ args', result := [(mk_constr d.name).mk_app vs'], .. d } } : tactic _),
        idx ← (mk_local_def `i $ head_t.mk_app $ func.dead_params.map prod.fst : tactic _),
        let decl' := { name := child_n, params := func.dead_params.map prod.fst, idx := decl.idx ++ [idx], ctors := cs.join, .. decl },
        decl' <$ mk_inductive' decl'

meta def inductive_type.of_pfunctor (func : internal_mvfunctor) : lean.parser inductive_type :=
do -- mk_inductive' func.induct,
   let d := func.decl,
   let params := func.params,
   (idx,t) ← unpi (d.type.instantiate_pi params),
   env ← get_env,
   -- let (params,idx) := idx.split_at $ env.inductive_num_params d.to_name,
   cs ← (env.constructors_of d.to_name).mmap $ λ c : name,
   do { let e := @const tt c d.univ_levels,
        t ← infer_type $ e.mk_app params,
        (vs,t) ← unpi t,
        pure (t.get_app_fn.const_name,{ type_cnstr .
               name := c,
               args := vs,
               result := t.get_app_args.drop $ env.inductive_num_params d.to_name }) },
   pure { pre     := func.induct.pre,
          name    := d.to_name,
          u_names := d.univ_params,
          params  := params,
          idx     := idx, type := t,
          ctors   := cs.map prod.snd }

meta def mk_child_t_vec (decl : inductive_type) (func : internal_mvfunctor) (vs : list inductive_type) : lean.parser expr :=
do let n := decl.name,
   let head_t := (@const tt (n <.> "head_t") func.decl.univ_levels).mk_app $ func.dead_params.map prod.fst,
   let child_n := (n <.> "child_t"),
   let arity := func.live_params.length,
   punit.star ← coe $
     do { hd_v ← mk_local_def `hd head_t,
          (expr.sort u') ← pure decl.type,
          let u := u'.pred,
          let vec_t := @const tt ``typevec [u] (reflect arity),
          t ← pis (func.dead_params.map prod.fst ++ [hd_v]) vec_t,
          nil ← mk_mapp ``fin'.elim0 [some $ expr.sort u.succ],
          vec ← func.live_params.reverse.mfoldr (λ e v,
            do c ← mk_const $ child_n ++ e.1.local_pp_name,
               let c := (@const tt (n <.> "child_t" ++ e.1.local_pp_name) func.decl.univ_levels).mk_app $ func.dead_params.map prod.fst ++ [hd_v],
               mv ← mk_mvar,
               unify_app (const ``append1 [u]) [mv,v,c]) nil,
          -- vec ← mk_mapp ``_root_.id [vec_t,vec],
          df ← (instantiate_mvars vec >>= lambdas (func.dead_params.map prod.fst ++ [hd_v]) : tactic _),
          -- df ← instantiate_mvars vec,
          let r := reducibility_hints.regular 1 tt,
          add_decl' $ declaration.defn child_n func.decl.univ_params t df r tt,
          -- pure { eqn_compiler.fun_def .
          --        univs := func.induct.u_names,
          --        name := child_n,
          --        params := func.dead_params.map prod.fst ++ [hd_v],
          --        type := vec_t,
          --        body := eqn_compiler.def_body.term df }
          pure () },
   -- eqn_compiler.add_fn func.decl.to_name eqns,
   pure $ expr.const child_n $ func.induct.u_params

meta def mk_pfunctor (func : internal_mvfunctor) : lean.parser unit :=
do d ← inductive_type.of_pfunctor func,
   hd ← mk_head_t d func,
   ch ← mk_child_t d func,
   mk_child_t_vec d func ch,
   let arity := func.live_params.length,
   (expr.sort u') ← pure d.type,
   let u := u'.pred,
   let vec_t := @const tt ``mvpfunctor [u] $ reflect arity,
   t ← pis (func.dead_params.map prod.fst) vec_t,
   let n := d.name,
   let head_t := (@const tt (n <.> "head_t") func.decl.univ_levels).mk_app $ func.dead_params.map prod.fst,
   let child_t := (@const tt (n <.> "child_t") func.decl.univ_levels).mk_app $ func.dead_params.map prod.fst,
   df ← (mk_mapp ``mvpfunctor.mk [some $ reflect arity, head_t,child_t] >>= lambdas (func.dead_params.map prod.fst) : tactic _),
   add_decl $ mk_definition func.pfunctor_name func.decl.univ_params t df,
   pure ()

meta def mk_pfunc_constr (func : internal_mvfunctor) : tactic unit :=
do env ← get_env,
   let cs := env.constructors_of func.decl.to_name,
   let u := func.type.sort_univ.pred,
   let u' := func.univ_params.foldl level.max u,
   let out_t :=  (@const tt func.pfunctor_name func.univ_params).mk_app $ func.dead_params.map prod.fst,
   vec_t ← mk_live_vec func.vec_lvl $ func.live_params.map prod.fst,
   let arity := func.live_params.length,
   let fn := @const tt ``mvpfunctor.apply [u],
   r ← unify_app fn [reflect arity,out_t,vec_t],
   cs.mmap $ λ c,
     do { let p := c.update_prefix (c.get_prefix <.> "pfunctor"),
          let hd_c := c.update_prefix (func.decl.to_name <.> "head_t"),
          let e := (@const tt c func.univ_params).mk_app func.params,
          (args,_) ← infer_type e >>= mk_local_pis,
          sig ← pis (func.params ++ args) r,
          (rec,vs') ← args.mpartition $ λ v,
                 do { t ← infer_type v,
                      pure $ ¬ ∃ v ∈ func.live_params, expr.occurs (prod.fst v) t },

          let e := (@const tt hd_c func.univ_params).mk_app (func.dead_params.map prod.fst ++ rec),
          ms ← func.live_params.mmap $ λ l,
                do { let l_name := l.1.local_pp_name,
                     vs' ← vs'.mfilter $ λ v,
                       do { t ← infer_type v,
                            pure $ expr.occurs l.1 t },
                     y ← infer_type e >>= mk_local_def `y,
                     hy ← mk_app `eq [y,e] >>= mk_local_def `hy,
                     let ch_t := (@const tt (func.decl.to_name <.> "child_t" ++ l_name) func.univ_params).mk_app (func.dead_params.map prod.fst ++ [y]),
                     let ch_c := c.update_prefix (func.decl.to_name <.> "child_t" ++ l_name),
                     t ← pis (vs' ++ rec ++ [y,hy]) $ ch_t.imp l.1,
                     (_,f) ← @solve_aux unit t $ do
                       { (vs',σ₀) ← mk_substitution vs' ,
                         (rec,σ₁) ← mk_substitution rec ,
                         y ← intro1, hy ← intro1,
                         x ← intro `x,
                         interactive.generalize `hx () (to_pexpr x,`x'),
                         solve1 $ do
                         { a ← better_induction x,
                           gs ← get_goals,
                           rs ← mzip_with (λ (x : name × list (expr × option expr) × list (name × expr)) g,
                             do let ⟨ctor,a,b⟩ := x,
                                set_goals [g],
                                cases $ hy.instantiate_locals b,
                                gs ← get_goals,
                                pure $ gs.map $ λ g, (a,b,g)) a gs,
                           mzip_with' (λ (v : expr) (r : list (expr × option expr) × list (name × expr) × expr),
                             do let (a,b,g) := r,
                                set_goals [g],
                                x' ← get_local `x',
                                expr.app _ t ← infer_type x',
                                let ts := t.get_app_args.length - func.dead_params.length,
                                let a' := (a.drop ts).map prod.fst, exact $ v.mk_app a' ) vs' rs.join,
                           skip } },
                     pr ← mk_eq_refl e,
                     pure $ f.mk_app $ vs' ++ rec ++ [e,pr] },
          (_,df) ← solve_aux r $ do
            { m ← mk_map_vec func.vec_lvl ms,
              refine ``( ⟨ %%e, _ ⟩ ),
              exact m,
              pure () },
          let c' := c.update_prefix $ c.get_prefix <.> "pfunctor",
          let vs := func.params ++ args,
          r  ← pis vs r >>= instantiate_mvars,
          df ← instantiate_mvars df >>= lambdas vs,
          add_decl $ mk_definition c' func.decl.univ_params r df,
          pure () },
   pure ()

-- meta def saturate' : expr → expr → tactic expr
-- | (expr.pi n bi t b) e :=
-- do v ← mk_meta_var t,
--    t ← whnf $ b.instantiate_var v,
--    saturate' t (e v)
-- | t e := pure e

-- meta def saturate (e : expr) : tactic expr :=
-- do t ← infer_type e >>= whnf,
--    saturate' t e

open nat expr

meta def mk_motive : tactic expr :=
do (pi en bi d b) ← target,
   pure $ lam en bi d b

meta def destruct_multimap' : ℕ → expr → expr → list expr → tactic (list expr)
| 0 v₀ v₁ xs :=
do C ← mk_motive,
   refine ``(@typevec_cases_nil₂ %%C _),
   pure xs
| (succ n) v₀ v₁ xs :=
do C ← mk_motive,
   a ← mk_mvar, b ← mk_mvar,
   to_expr ``(append1 %%a %%b) tt ff >>= unify v₀,
   `(append1 %%a' %%b') ← pure v₁,
   refine ``(@typevec_cases_cons₂ _ %%b %%b' %%a %%a' %%C _),
   f ← intro `f,
   destruct_multimap' n a a' (f :: xs)

meta def destruct_multimap (e : expr) : tactic (list expr) :=
do `(%%v₀ ⟹ %%v₁) ← infer_type e,
   `(typevec %%n) ← infer_type v₀,
   n ← eval_expr ℕ n,
   n_h ← revert e,
   destruct_multimap' n v₀ v₁ [] <*
     intron (n_h-1)

def santas_helper {n} {P : mvpfunctor n} {α} (C : P.apply α → Sort*) {a : P.A} {b} (b')
  (x : C ⟨a,b⟩) (h : b = b') : C ⟨a,b'⟩ :=
by cases h; exact x

open list

section zip_vars
variables (n : name) (univs : list level)
  (args : list expr) (shape_args : list expr)

meta def mk_child_arg (e : expr × list expr) : list (expr × expr × ℕ) → list (expr × expr × ℕ) × list expr × expr
| [] := ([],shape_args.tail,shape_args.head)
| (⟨v,e',i⟩::vs) :=
if v.occurs e.1
  then let c : expr := const ( (n.update_prefix $ n.get_prefix ++ v.local_pp_name).append_after i ) univs
       in ( ⟨v,e',i+1⟩::vs, shape_args, expr.lambdas e.2 $ e' $ c.mk_app $ args ++ e.2)
  else prod.map (cons ⟨v,e',i⟩) id $ mk_child_arg vs

meta def zip_vars' : list expr → list (expr × expr × ℕ) → list (expr × list expr) → list expr
| _ xs [] := []
| shape_args xs (v :: vs) :=
let (xs',shape_args',v') := mk_child_arg n univs args shape_args v xs in
v' :: zip_vars' shape_args' xs' vs

meta def zip_vars (ls : list (expr × expr)) (vs : list expr) : tactic $ list expr :=
do vs' ← vs.mmap $ λ v, do { (vs,_) ← infer_type v >>= mk_local_pis, pure (v,vs) },
   pure $ zip_vars' n univs args shape_args (ls.map $ λ x, (x.1,x.2,0)) vs'

end zip_vars

meta def mk_pfunc_recursor (func : internal_mvfunctor) : tactic unit :=
do let u := fresh_univ func.induct.u_names,
   v ← mk_live_vec func.vec_lvl $ func.live_params.map prod.fst,
   fn ← mk_app `mvpfunctor.apply [functor_expr func,v],
   C ← mk_local' `C binder_info.implicit (expr.imp fn $ expr.sort $ level.param u),
   let dead_params := func.dead_params.map prod.fst,
   cases_t ← func.induct.ctors.mmap $ λ c,
   do { let n := c.name.update_prefix (func.decl.to_name <.> "pfunctor"),
        let e := (@expr.const tt n func.induct.u_params).mk_app (func.params ++ c.args),
        prod.mk c <$> (pis c.args (C e) >>= mk_local_def `v) },
   n ← mk_local_def `n fn,
   (_,df) ← solve_aux (expr.pis [n] $ C n) $ do
     { n ← intro1, [(_, [n_fst,n_snd], _)] ← cases_core n,
       hs ← cases_core n_fst,
       gs ← get_goals,
       gs ← list.mzip_with₃ (λ h g v,
         do { let ⟨c,h⟩ := (h : type_cnstr × expr),
              set_goals [g],
              ⟨n,xs,[(_,n_snd)]⟩ ← pure (v : name × list expr × list (name × expr)),
              fs ← destruct_multimap n_snd,
              n_snd ← mk_map_vec func.vec_lvl fs,
              let child_n := c.name.update_prefix $ func.induct.name <.> "child_t",
              let subst := (func.live_params.map prod.fst).zip fs,
              h_args ← zip_vars child_n func.induct.u_params (dead_params ++ xs) xs subst c.args,
              let h := h.mk_app h_args,
              let n_fst := (@const tt n func.induct.u_params).mk_app $ func.dead_params.map prod.fst ++ xs,
              vec ← mk_live_vec func.vec_lvl $ func.live_params.map prod.fst,
              fn ← mk_const ``santas_helper,
              unify_mapp fn [none,none,vec,C,none,none,n_snd,h,none] >>= refine ∘ to_pexpr,
              reflexivity <|> (congr; ext [rcases_patt.many [[rcases_patt.one `_]]] none; reflexivity),
              done }) cases_t gs hs,
       pure () },
   let vs := func.params.map expr.to_implicit_binder ++ C :: cases_t.map prod.snd,
   df ← instantiate_mvars df >>= lambdas vs,
   t ← pis (vs ++ [n]) (C n),
   add_decl $ mk_definition (func.pfunctor_name <.> "rec") (u :: func.induct.u_names) t df,
   pure ()

meta def mk_pfunc_rec_eqns (func : internal_mvfunctor) : tactic unit :=
do let u := fresh_univ func.induct.u_names,
   let rec := (@const tt (func.pfunctor_name <.> "rec") (level.param u :: func.induct.u_params)).mk_app func.params,
   let eqn := (@const tt func.eqn_name func.induct.u_params).mk_app func.params,
   (C::fs,_) ← infer_type rec >>= mk_local_pis,
   let rec := rec C,
   let fs := fs.init,
   mzip_with' (λ (c : type_cnstr) (f : expr), do
   { let cn := c.name.update_prefix $ c.name.get_prefix <.> "pfunctor",
     let c := (@const tt cn func.induct.u_params).mk_app func.params,
     (args,_) ← infer_type c >>= mk_local_pis,
     let x := c.mk_app args,
     t ← mk_app `eq [rec.mk_app (fs ++ [x]),f.mk_app args] >>= pis (func.params ++ C :: fs ++ args),
     (_,df) ← solve_aux t $ do
     { intros, reflexivity },
     df ← instantiate_mvars df,
     let n := cn.append_suffix "_rec",
     add_decl $ declaration.thm n (u :: func.induct.u_names) t (pure df),
     simp_attr.typevec.set n () tt }) func.induct.ctors fs,
   skip

meta def mk_qpf_abs (func : internal_mvfunctor) : tactic unit :=
do let n := func.live_params.length,
   let dead_params := func.dead_params.map prod.fst,
   let e := (@const tt func.def_name func.induct.u_params).mk_app dead_params,
   let e' := (@const tt func.pfunctor_name func.induct.u_params).mk_app dead_params,
   t ← to_expr ``(∀ v, mvpfunctor.apply %%e' v → %%e v),
   (_,df) ← @solve_aux unit t $ do
   { vs ← destruct_typevec' func `v,
     C ← mk_motive,
     let params := (rb_map.sort prod.snd $ func.dead_params ++ vs).map prod.fst,
     let rec := @const tt (func.pfunctor_name <.> "rec") $ level.succ func.vec_lvl :: func.induct.u_params,
     let branches := list.repeat (@none expr) func.induct.ctors.length,
     rec ← unify_mapp rec (params.map some ++ C :: branches),
     refine ∘ to_pexpr $ rec,
     let cs := func.induct.ctors,
     let c' := cs.map $ λ c : type_cnstr, c.name.update_prefix $ c.name.get_prefix <.> "pfunctor",
     let eqn := (@const tt func.eqn_name func.induct.u_params).mk_app params,
     cs.mmap $ λ c, solve1 $ do
       { xs ← intros,
         let n := c.name.update_prefix func.induct.name,
         let e := (@const tt n func.induct.u_params).mk_app $ params ++ xs,
         mk_eq_mpr eqn e >>= exact },
     done },
   t ← pis dead_params t,
   df ← instantiate_mvars df >>= lambdas dead_params,
   add_decl $ mk_definition func.abs_name func.induct.u_names t df

meta def mk_qpf_repr (func : internal_mvfunctor) : tactic unit :=
do let n := func.live_params.length,
   let dead_params := func.dead_params.map prod.fst,
   let e := (@const tt func.def_name func.induct.u_params).mk_app dead_params,
   let e' := (@const tt func.pfunctor_name func.induct.u_params).mk_app dead_params,
   t ← to_expr ``(∀ v, %%e v → mvpfunctor.apply %%e' v),
   (_,df) ← @solve_aux unit t $ do
   { vs ← destruct_typevec' func `v,
     C ← mk_motive,
     let params := (rb_map.sort prod.snd $ func.dead_params ++ vs).map prod.fst,
     let rec := @const tt (func.induct.name <.> "rec") $ level.succ func.vec_lvl :: func.induct.u_params,
     let branches := list.repeat (@none expr) func.induct.ctors.length,
     rec ← unify_mapp rec (params.map some ++ C :: branches),
     refine ∘ to_pexpr $ rec,
     let cs := func.induct.ctors,
     let c' := cs.map $ λ c : type_cnstr, c.name.update_prefix $ c.name.get_prefix <.> "pfunctor",
     let eqn := (@const tt func.eqn_name func.induct.u_params).mk_app params,
     cs.mmap $ λ c, solve1 $ do
       { xs ← intros,
         let n := c.name.update_prefix func.pfunctor_name,
         let e := (@const tt n func.induct.u_params).mk_app $ params ++ xs,
         exact e },
     done },
   t ← pis dead_params t,
   df ← instantiate_mvars df >>= lambdas dead_params,
   add_decl $ mk_definition func.repr_name func.induct.u_names t df

open bitraversable

meta def mk_pfunctor_map_eqn (func : internal_mvfunctor) : tactic unit :=
do β ← func.live_params.mmap $ tfst renew,
   fs ← mzip_with (λ x y : expr × _, mk_local_def `f $ x.1.imp y.1) func.live_params β,
   vf ← mk_map_vec func.vec_lvl fs,
   let cs := func.induct.ctors.map $ λ c : type_cnstr, c.name.update_prefix func.pfunctor_name,
   let params' := (rb_map.sort prod.snd $ func.dead_params ++ β).map prod.fst,
   cs.mmap' $ λ cn,
     do { let c := (@const tt cn func.induct.u_params).mk_app func.params,
          let c' := (@const tt cn func.induct.u_params).mk_app params',
          (vs,_) ← infer_type c >>= mk_local_pis,
          lhs ← mk_app ``mvfunctor.map [vf,c.mk_app vs],
          vs' ← vs.mmap $ λ v,
            do { some (_,f) ← pure $ ((func.live_params.map prod.fst).zip fs).find $ λ x : expr × expr, x.1.occurs v | pure v,
                 (ws,_) ← infer_type v >>= mk_local_pis,
                 lambdas ws (f $ v.mk_app ws) },
          let rhs := c'.mk_app vs',
          t ← mk_app `eq [lhs,rhs] >>= pis (func.params ++ β.map prod.fst ++ fs ++ vs),
          (_,df) ← solve_aux t $ do
          { intros,
            dunfold_target cs,
            map_eq ← mk_const ``mvpfunctor.map_eq, rewrite_target map_eq { md := semireducible },
            simp_only [``(append_fun_comp'),``(nil_fun_comp)],
            done <|> reflexivity <|> (congr; ext [rcases_patt.many [[rcases_patt.one `_]]] none; reflexivity),
            done },
          df ← instantiate_mvars df,
          let n := cn.append_suffix "_map",
          add_decl $ declaration.thm n func.induct.u_names t (pure df),
          let n' := mk_simp_attr_decl_name `typevec,
          simp_attr.typevec.set n () tt },
   skip

meta def prove_abs_repr (func : internal_mvfunctor) : tactic unit :=
do vs ← destruct_typevec' func `α,
   let cs := func.induct.ctors.map $ λ c : type_cnstr, c.name.update_prefix func.pfunctor_name,
   x ← intro1, cases x,
   repeat $ do
   { dunfold_target [func.repr_name,func.abs_name],
     simp_only [``(typevec.typevec_cases_nil_append1),``(typevec.typevec_cases_cons_append1)],
     dunfold_target $ [func.pfunctor_name <.> "rec"] ++ cs,
     `[dsimp],
     reflexivity }

meta def prove_abs_map (func : internal_mvfunctor) : tactic unit :=
do vs ← destruct_typevec₃ func `α,
   C ← mk_motive,
   let vs := vs.map $ λ ⟨α,β,f,i⟩, (α,i),
   let params := (rb_map.sort prod.snd $ func.dead_params ++ vs).map prod.fst,
   let rec_n := func.pfunctor_name <.> "rec",
   let rec := (@const tt rec_n $ level.zero :: func.induct.u_params).mk_app (params ++ [C]),
   let cs := func.induct.ctors.map $ λ c : type_cnstr, c.name.update_prefix func.pfunctor_name,
   apply rec,
   all_goals $ do
   { intros,
     dunfold_target [func.repr_name,func.abs_name],
     simp_only [``(typevec.typevec_cases_nil_append1),``(typevec.typevec_cases_cons_append1)] [`typevec],
     reflexivity }

meta def mk_mvqpf_instance (func : internal_mvfunctor) : tactic unit :=
do let n := func.live_params.length,
   let dead_params := func.dead_params.map prod.fst,
   let e := (@const tt func.def_name func.induct.u_params).mk_app dead_params,
   let abs_fn := (@const tt func.abs_name func.induct.u_params).mk_app dead_params,
   let repr_fn := (@const tt func.repr_name func.induct.u_params).mk_app dead_params,
   mk_qpf_abs func,
   mk_qpf_repr func,
   mk_pfunctor_map_eqn func,
   pfunctor_i ← mk_mapp ``mvfunctor [some (reflect n),e] >>= mk_instance,
   mvqpf_t ← mk_mapp ``mvqpf [some (reflect n),e,pfunctor_i] >>= instantiate_mvars,
   (_,df) ← solve_aux mvqpf_t $ do
     { let p := (@const tt func.pfunctor_name func.induct.u_params).mk_app dead_params,
       refine ``( { P := %%p, abs := %%abs_fn, repr' := %%repr_fn, .. } ),
       solve1 $ prove_abs_repr func,
       solve1 $ prove_abs_map func },
   df ← instantiate_mvars df >>= lambdas dead_params,
   mvqpf_t ← pis dead_params mvqpf_t,
   let inst_n := func.def_name <.> "mvqpf",
   add_decl $ mk_definition inst_n func.induct.u_names mvqpf_t df,
   set_basic_attribute `instance inst_n

open interactive lean.parser lean

@[user_command]
meta def qpf_decl (meta_info : decl_meta_info) (_ : parse (tk "qpf")) : lean.parser unit :=
do d ← inductive_decl.parse meta_info,
   func ← mk_internal_functor' d,
   trace_error "mk_mvfunctor_instance" $ mk_mvfunctor_instance func,
   mk_pfunctor func,
   trace_error "mk_pfunc_constr" $ mk_pfunc_constr func,
   trace_error "mk_pfunc_recursor" $ mk_pfunc_recursor func,
   -- trace_error $ mk_pfunc_rec_eqns func,
   -- mk_pfunc_map func,
   -- mk_pfunc_mvfunctor_instance func,
   trace_error "mk_mvqpf_instance" $ mk_mvqpf_instance func,
   pure ()

-- local attribute [user_command]  qpf_decl

end tactic


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Tactic.Simp
import Lean.Elab.Tactic.Basic
import Lean.Elab.Tactic.ElabTerm
import Lean.Elab.Tactic.Location
import Lean.Meta.Tactic.Replace
import Lean.Elab.BuiltinNotation

namespace Lean.Elab.Tactic
open Meta

unsafe def evalSimpConfigUnsafe (e : Expr) : TermElabM Meta.Simp.Config :=
  Term.evalExpr Meta.Simp.Config ``Meta.Simp.Config e
@[implementedBy evalSimpConfigUnsafe] constant evalSimpConfig (e : Expr) : TermElabM Meta.Simp.Config

unsafe def evalSimpConfigCtxUnsafe (e : Expr) : TermElabM Meta.Simp.ConfigCtx :=
  Term.evalExpr Meta.Simp.ConfigCtx ``Meta.Simp.ConfigCtx e
@[implementedBy evalSimpConfigCtxUnsafe] constant evalSimpConfigCtx (e : Expr) : TermElabM Meta.Simp.ConfigCtx

/-
  `optConfig` is of the form `("(" "config" ":=" term ")")?`
  If `ctx == false`, the argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise. -/
def elabSimpConfig (optConfig : Syntax) (ctx : Bool) : TermElabM Meta.Simp.Config := do
  if optConfig.isNone then
    if ctx then
      return { : Meta.Simp.ConfigCtx }.toConfig
    else
      return {}
  else
    withoutModifyingState <| withLCtx {} {} <| Term.withSynthesize do
      let c ← Term.elabTermEnsuringType optConfig[3] (Lean.mkConst (if ctx then ``Meta.Simp.ConfigCtx else ``Meta.Simp.Config))
      if ctx then
        return (← evalSimpConfigCtx (← instantiateMVars c)).toConfig
      else
        evalSimpConfig (← instantiateMVars c)

private def addDeclToUnfoldOrLemma (lemmas : Meta.SimpLemmas) (e : Expr) (post : Bool) : MetaM Meta.SimpLemmas := do
  if e.isConst then
    let declName := e.constName!
    let info ← getConstInfo declName
    if (← isProp info.type) then
      lemmas.addConst declName post
    else
      lemmas.addDeclToUnfold declName
  else
    lemmas.add #[] e post

private def addSimpLemma (lemmas : Meta.SimpLemmas) (stx : Syntax) (post : Bool) : TermElabM Meta.SimpLemmas := do
  let (levelParams, proof) ← Term.withoutModifyingElabMetaState <| withRef stx <| Term.withoutErrToSorry do
    let e ← Term.elabTerm stx none
    Term.synthesizeSyntheticMVarsUsingDefault
    let e ← instantiateMVars e
    let e := e.eta
    if e.hasMVar then
      let r ← abstractMVars e
      return (r.paramNames, r.expr)
    else
      return (#[], e)
  lemmas.add levelParams proof

/--
  Elaborate extra simp lemmas provided to `simp`. `stx` is of the `simpLemma,*`
  If `eraseLocal == true`, then we consider local declarations when resolving names for erased lemmas (`- id`),
  this option only makes sense for `simp_all`.
-/
private def elabSimpLemmas (stx : Syntax) (ctx : Simp.Context) (eraseLocal : Bool) : TacticM Simp.Context := do
  if stx.isNone then
    return ctx
  else
    /-
    syntax simpPre := "↓"
    syntax simpPost := "↑"
    syntax simpLemma := (simpPre <|> simpPost)? term

    syntax simpErase := "-" ident
    -/
    withMainContext do
      let mut lemmas := ctx.simpLemmas
      for arg in stx[1].getSepArgs do
        if arg.getKind == ``Lean.Parser.Tactic.simpErase then
          if eraseLocal && (← Term.isLocalIdent? arg[1]).isSome then
            -- We use `eraseCore` because the simp lemma for the hypothesis was not added yet
            lemmas ← lemmas.eraseCore arg[1].getId
          else
            let declName ← resolveGlobalConstNoOverloadWithInfo arg[1]
            lemmas ← lemmas.erase declName
        else
          let post :=
            if arg[0].isNone then
              true
            else
              arg[0][0].getKind == ``Parser.Tactic.simpPost
          match (← resolveSimpIdLemma? arg[1]) with
          | some e => lemmas ← addDeclToUnfoldOrLemma lemmas e post
          | _      => lemmas ← addSimpLemma lemmas arg[1] post
      return { ctx with simpLemmas := lemmas }
where
  resolveSimpIdLemma? (simpArgTerm : Syntax) : TacticM (Option Expr) := do
    if simpArgTerm.isIdent then
      try
        Term.resolveId? simpArgTerm (withInfo := true)
      catch _ =>
        return none
    else
      Term.elabCDotFunctionAlias? simpArgTerm

--  If `ctx == false`, the argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise. -/
private def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (ctx := false) : TacticM Simp.Context := do
  let simpOnly := !stx[2].isNone
  elabSimpLemmas stx[3] (eraseLocal := eraseLocal) {
    config      := (← elabSimpConfig stx[1] (ctx := ctx))
    simpLemmas  := if simpOnly then {} else (← getSimpLemmas)
    congrLemmas := (← getCongrLemmas)
  }

/-
  "simp " ("(" "config" ":=" term ")")? ("only ")? ("[" simpLemma,* "]")? (location)?
-/
@[builtinTactic Lean.Parser.Tactic.simp] def evalSimp : Tactic := fun stx => do
  let ctx  ← mkSimpContext stx (eraseLocal := false)
  -- trace[Meta.debug] "Lemmas {← toMessageData ctx.simpLemmas.post}"
  let loc := expandOptLocation stx[4]
  match loc with
  | Location.targets hUserNames simpTarget =>
    withMainContext do
      let fvarIds ← hUserNames.mapM fun hUserName => return (← getLocalDeclFromUserName hUserName).fvarId
      go ctx fvarIds simpTarget
  | Location.wildcard =>
    withMainContext do
      go ctx (← getNondepPropHyps (← getMainGoal)) true
where
  go (ctx : Simp.Context) (fvarIdsToSimp : Array FVarId) (simpType : Bool) : TacticM Unit := do
    let mut mvarId ← getMainGoal
    let mut toAssert : Array Hypothesis := #[]
    for fvarId in fvarIdsToSimp do
      let localDecl ← getLocalDecl fvarId
      let type ← instantiateMVars localDecl.type
      match (← simpStep mvarId (mkFVar fvarId) type ctx) with
      | none => replaceMainGoal []; return ()
      | some (value, type) => toAssert := toAssert.push { userName := localDecl.userName, type := type, value := value }
    if simpType then
      match (← simpTarget mvarId ctx) with
      | none => replaceMainGoal []; return ()
      | some mvarIdNew => mvarId := mvarIdNew
    let (_, mvarIdNew) ← assertHypotheses mvarId toAssert
    let mvarIdNew ← tryClearMany mvarIdNew fvarIdsToSimp
    replaceMainGoal [mvarIdNew]

@[builtinTactic Lean.Parser.Tactic.simpAll] def evalSimpAll : Tactic := fun stx => do
  let ctx  ← mkSimpContext stx (eraseLocal := true) (ctx := true)
  match (← simpAll (← getMainGoal) ctx) with
  | none => replaceMainGoal []
  | some mvarId => replaceMainGoal [mvarId]

end Lean.Elab.Tactic


import Qq
open Qq

set_option linter.unusedVariables false in
def typeClassArgument (α : Q(Sort u)) (inst : Q(Inhabited $α)) : Q($α) :=
  q(Inhabited.default)

example : Q(Nat) :=
  typeClassArgument q(Nat) q(inferInstance)

open Lean in
#eval show MetaM Q(Nat) from do
  let _ ← synthInstanceQ q(Inhabited Nat)
  return typeClassArgument (u := levelOne) q(Nat) q(inferInstance)


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

universes u v w z u_1 u_2 u_3

namespace Mathlib

namespace list

/- zip & unzip -/

@[simp] theorem zip_with_cons_cons {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (a : α)
    (b : β) (l₁ : List α) (l₂ : List β) :
    zip_with f (a :: l₁) (b :: l₂) = f a b :: zip_with f l₁ l₂ :=
  rfl

@[simp] theorem zip_cons_cons {α : Type u} {β : Type v} (a : α) (b : β) (l₁ : List α)
    (l₂ : List β) : zip (a :: l₁) (b :: l₂) = (a, b) :: zip l₁ l₂ :=
  rfl

@[simp] theorem zip_with_nil_left {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ)
    (l : List β) : zip_with f [] l = [] :=
  rfl

@[simp] theorem zip_with_nil_right {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ)
    (l : List α) : zip_with f l [] = [] :=
  list.cases_on l (Eq.refl (zip_with f [] []))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (zip_with f (l_hd :: l_tl) [])

@[simp] theorem zip_nil_left {α : Type u} {β : Type v} (l : List α) : zip [] l = [] := rfl

@[simp] theorem zip_nil_right {α : Type u} {β : Type v} (l : List α) : zip l [] = [] :=
  zip_with_nil_right Prod.mk l

@[simp] theorem zip_swap {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) :
    map prod.swap (zip l₁ l₂) = zip l₂ l₁ :=
  sorry

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

@[simp] theorem length_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) :
    length (zip l₁ l₂) = min (length l₁) (length l₂) :=
  length_zip_with Prod.mk

theorem lt_length_left_of_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {i : ℕ}
    {l : List α} {l' : List β} (h : i < length (zip_with f l l')) : i < length l :=
  and.left
    (eq.mp (Eq._oldrec (Eq.refl (i < min (length l) (length l'))) (propext lt_min_iff))
      (eq.mp (Eq._oldrec (Eq.refl (i < length (zip_with f l l'))) (length_zip_with f l l')) h))

theorem lt_length_right_of_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {i : ℕ}
    {l : List α} {l' : List β} (h : i < length (zip_with f l l')) : i < length l' :=
  and.right
    (eq.mp (Eq._oldrec (Eq.refl (i < min (length l) (length l'))) (propext lt_min_iff))
      (eq.mp (Eq._oldrec (Eq.refl (i < length (zip_with f l l'))) (length_zip_with f l l')) h))

theorem lt_length_left_of_zip {α : Type u} {β : Type v} {i : ℕ} {l : List α} {l' : List β}
    (h : i < length (zip l l')) : i < length l :=
  lt_length_left_of_zip_with h

theorem lt_length_right_of_zip {α : Type u} {β : Type v} {i : ℕ} {l : List α} {l' : List β}
    (h : i < length (zip l l')) : i < length l' :=
  lt_length_right_of_zip_with h

theorem zip_append {α : Type u} {β : Type v} {l₁ : List α} {r₁ : List α} {l₂ : List β} {r₂ : List β}
    (h : length l₁ = length l₂) : zip (l₁ ++ r₁) (l₂ ++ r₂) = zip l₁ l₂ ++ zip r₁ r₂ :=
  sorry

theorem zip_map {α : Type u} {β : Type v} {γ : Type w} {δ : Type z} (f : α → γ) (g : β → δ)
    (l₁ : List α) (l₂ : List β) : zip (map f l₁) (map g l₂) = map (prod.map f g) (zip l₁ l₂) :=
  sorry

theorem zip_map_left {α : Type u} {β : Type v} {γ : Type w} (f : α → γ) (l₁ : List α)
    (l₂ : List β) : zip (map f l₁) l₂ = map (prod.map f id) (zip l₁ l₂) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (zip (map f l₁) l₂ = map (prod.map f id) (zip l₁ l₂)))
        (Eq.symm (zip_map f id l₁ l₂))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (zip (map f l₁) l₂ = zip (map f l₁) (map id l₂))) (map_id l₂)))
      (Eq.refl (zip (map f l₁) l₂)))

theorem zip_map_right {α : Type u} {β : Type v} {γ : Type w} (f : β → γ) (l₁ : List α)
    (l₂ : List β) : zip l₁ (map f l₂) = map (prod.map id f) (zip l₁ l₂) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (zip l₁ (map f l₂) = map (prod.map id f) (zip l₁ l₂)))
        (Eq.symm (zip_map id f l₁ l₂))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (zip l₁ (map f l₂) = zip (map id l₁) (map f l₂))) (map_id l₁)))
      (Eq.refl (zip l₁ (map f l₂))))

theorem zip_map' {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : α → γ) (l : List α) :
    zip (map f l) (map g l) = map (fun (a : α) => (f a, g a)) l :=
  sorry

theorem mem_zip {α : Type u} {β : Type v} {a : α} {b : β} {l₁ : List α} {l₂ : List β} :
    (a, b) ∈ zip l₁ l₂ → a ∈ l₁ ∧ b ∈ l₂ :=
  sorry

theorem map_fst_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) :
    length l₁ ≤ length l₂ → map prod.fst (zip l₁ l₂) = l₁ :=
  sorry

theorem map_snd_zip {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) :
    length l₂ ≤ length l₁ → map prod.snd (zip l₁ l₂) = l₂ :=
  sorry

@[simp] theorem unzip_nil {α : Type u} {β : Type v} : unzip [] = ([], []) := rfl

@[simp] theorem unzip_cons {α : Type u} {β : Type v} (a : α) (b : β) (l : List (α × β)) :
    unzip ((a, b) :: l) = (a :: prod.fst (unzip l), b :: prod.snd (unzip l)) :=
  sorry

theorem unzip_eq_map {α : Type u} {β : Type v} (l : List (α × β)) :
    unzip l = (map prod.fst l, map prod.snd l) :=
  sorry

theorem unzip_left {α : Type u} {β : Type v} (l : List (α × β)) :
    prod.fst (unzip l) = map prod.fst l :=
  sorry

theorem unzip_right {α : Type u} {β : Type v} (l : List (α × β)) :
    prod.snd (unzip l) = map prod.snd l :=
  sorry

theorem unzip_swap {α : Type u} {β : Type v} (l : List (α × β)) :
    unzip (map prod.swap l) = prod.swap (unzip l) :=
  sorry

theorem zip_unzip {α : Type u} {β : Type v} (l : List (α × β)) :
    zip (prod.fst (unzip l)) (prod.snd (unzip l)) = l :=
  sorry

theorem unzip_zip_left {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β} :
    length l₁ ≤ length l₂ → prod.fst (unzip (zip l₁ l₂)) = l₁ :=
  sorry

theorem unzip_zip_right {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β}
    (h : length l₂ ≤ length l₁) : prod.snd (unzip (zip l₁ l₂)) = l₂ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (prod.snd (unzip (zip l₁ l₂)) = l₂)) (Eq.symm (zip_swap l₂ l₁))))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (prod.snd (unzip (map prod.swap (zip l₂ l₁))) = l₂))
          (unzip_swap (zip l₂ l₁))))
      (unzip_zip_left h))

theorem unzip_zip {α : Type u} {β : Type v} {l₁ : List α} {l₂ : List β}
    (h : length l₁ = length l₂) : unzip (zip l₁ l₂) = (l₁, l₂) :=
  sorry

theorem zip_of_prod {α : Type u} {β : Type v} {l : List α} {l' : List β} {lp : List (α × β)}
    (hl : map prod.fst lp = l) (hr : map prod.snd lp = l') : lp = zip l l' :=
  sorry

theorem map_prod_left_eq_zip {α : Type u} {β : Type v} {l : List α} (f : α → β) :
    map (fun (x : α) => (x, f x)) l = zip l (map f l) :=
  sorry

theorem map_prod_right_eq_zip {α : Type u} {β : Type v} {l : List α} (f : α → β) :
    map (fun (x : α) => (f x, x)) l = zip (map f l) l :=
  sorry

@[simp] theorem length_revzip {α : Type u} (l : List α) : length (revzip l) = length l := sorry

@[simp] theorem unzip_revzip {α : Type u} (l : List α) : unzip (revzip l) = (l, reverse l) :=
  unzip_zip (Eq.symm (length_reverse l))

@[simp] theorem revzip_map_fst {α : Type u} (l : List α) : map prod.fst (revzip l) = l :=
  eq.mpr (id (Eq._oldrec (Eq.refl (map prod.fst (revzip l) = l)) (Eq.symm (unzip_left (revzip l)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (prod.fst (unzip (revzip l)) = l)) (unzip_revzip l)))
      (Eq.refl (prod.fst (l, reverse l))))

@[simp] theorem revzip_map_snd {α : Type u} (l : List α) : map prod.snd (revzip l) = reverse l :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (map prod.snd (revzip l) = reverse l))
        (Eq.symm (unzip_right (revzip l)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (prod.snd (unzip (revzip l)) = reverse l)) (unzip_revzip l)))
      (Eq.refl (prod.snd (l, reverse l))))

theorem reverse_revzip {α : Type u} (l : List α) : reverse (revzip l) = revzip (reverse l) := sorry

theorem revzip_swap {α : Type u} (l : List α) : map prod.swap (revzip l) = revzip (reverse l) :=
  sorry

theorem nth_zip_with {α : Type u_1} {β : Type u_1} {γ : Type u_1} (f : α → β → γ) (l₁ : List α)
    (l₂ : List β) (i : ℕ) : nth (zip_with f l₁ l₂) i = f <$> nth l₁ i <*> nth l₂ i :=
  sorry

theorem nth_zip_with_eq_some {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ)
    (l₁ : List α) (l₂ : List β) (z : γ) (i : ℕ) :
    nth (zip_with f l₁ l₂) i = some z ↔
        ∃ (x : α), ∃ (y : β), nth l₁ i = some x ∧ nth l₂ i = some y ∧ f x y = z :=
  sorry

theorem nth_zip_eq_some {α : Type u} {β : Type v} (l₁ : List α) (l₂ : List β) (z : α × β) (i : ℕ) :
    nth (zip l₁ l₂) i = some z ↔ nth l₁ i = some (prod.fst z) ∧ nth l₂ i = some (prod.snd z) :=
  sorry

@[simp] theorem nth_le_zip_with {α : Type u} {β : Type v} {γ : Type w} {f : α → β → γ} {l : List α}
    {l' : List β} {i : ℕ} {h : i < length (zip_with f l l')} :
    nth_le (zip_with f l l') i h =
        f (nth_le l i (lt_length_left_of_zip_with h))
          (nth_le l' i (lt_length_right_of_zip_with h)) :=
  sorry

@[simp] theorem nth_le_zip {α : Type u} {β : Type v} {l : List α} {l' : List β} {i : ℕ}
    {h : i < length (zip l l')} :
    nth_le (zip l l') i h =
        (nth_le l i (lt_length_left_of_zip h), nth_le l' i (lt_length_right_of_zip h)) :=
  nth_le_zip_with

theorem mem_zip_inits_tails {α : Type u} {l : List α} {init : List α} {tail : List α} :
    (init, tail) ∈ zip (inits l) (tails l) ↔ init ++ tail = l :=
  sorry

end Mathlib