import system.io
import utils
open tactic.unsafe

universes u v w

-- tools and help functions

-- def option.mmap {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m β) : option α → m (option β)
-- | none       := return none
-- | (some x) := do x' ← f x, return (some x')

def list.last_option {α : Type u}: list α → option α
| []        := none
| [a]       := some a
| (a::b::l) := list.last_option (b::l)

meta def expr.local_uniq_name_option : expr → option name
| (expr.local_const n m bi t) := some n
| e                      := none

meta def expr.mvar_uniq_name_option : expr → option name
| (expr.mvar n ppn t) := some n
| e                   := none

-- set the tactic state
meta def set_state (new_state: tactic_state): tactic unit :=
  -- this is in mathlib but easier to recreate
  λ _, interaction_monad.result.success () new_state

-- types for encoding tactic state information

meta structure mvar_decl :=
(unique_name : name)
(pp_name : name)
(expr_type : expr)
(local_cxt : list expr)
(type : option expr)
(assignment : option expr)

/- There already is a local_decl type, but
this is some more informtion for understanding
the type better.-/
meta structure local_decl2 :=
(unique_name : name)
(pp_name : name)
(expr_type : expr)
(bi : binder_info)
(type : option expr)
(prev : option name)
(frozen : bool)
(ld : option local_decl)

meta structure univ_mvar_decl :=
(unique_name : name)
(assignment : option level)

meta inductive context.decl
| mvar_decl (mv : mvar_decl) : context.decl
| univ_mvar_decl (mv : univ_mvar_decl) : context.decl
| local_decl (loc : local_decl2) : context.decl

meta structure context :=
-- in order of dependecies
(decls : list context.decl)
(names : name_set)

meta structure tactic_state_data :=
(decls : list context.decl)
(goals : list (name × tactic.tag))

-- meta instance : has_to_format tactic.tag := sorry
-- meta instance : has_to_format context.decl := sorry
-- -- meta instance : has_to_tactic_format context.decl := sorry
-- meta instance foo' : has_to_format $ list (name × tactic.tag) := by apply_instance
-- meta instance foo : has_to_format (list decl) := by apply_instance

-- meta instance : has_to_tactic_format tactic_state_data :=
-- ⟨λ ⟨decls, goals⟩, pure $ format!"tactic_state_data.mk \n\t decls := {decls} \n\t goals := {goals}"⟩

attribute [derive [has_to_format]] mvar_decl univ_mvar_decl binder_info
attribute [derive [has_to_format]] local_decl
attribute [derive [has_to_format]] local_decl2
attribute [derive [has_to_format]] context.decl
meta instance : has_to_format tactic.tag := (by apply_instance : has_to_format (list name))

attribute [derive [has_to_format]] tactic_state_data

section instances

attribute [derive [has_to_tactic_json]] mvar_decl
attribute [derive [has_to_tactic_json]] univ_mvar_decl
attribute [derive [has_to_tactic_json]] local_decl
attribute [derive [has_to_tactic_json]] local_decl
attribute [derive [has_to_tactic_json]] local_decl2

attribute [derive has_to_tactic_json] context.decl

meta instance : has_to_tactic_json tactic.tag :=
⟨by mk_to_tactic_json name.anonymous⟩

meta instance : has_from_json tactic.tag :=
has_from_json_list

attribute [derive has_to_tactic_json] tactic_state_data

meta instance : has_from_json mvar_decl :=
⟨λ msg, match msg with
  | (json.array $ [c, json.array [un, pp, ety, cxt, ty, assn]]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    if c_nm = `mvar_decl.mk then do
      mvar_decl.mk <$> (has_from_json.from_json un) <*> (has_from_json.from_json pp)
        <*> has_from_json.from_json ety <*> has_from_json.from_json cxt
          <*> has_from_json.from_json ty <*> has_from_json.from_json assn
    else
    tactic.fail format!"[has_from_json_mvar_decl] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_mvar_decl] unexpected: {exc}"
  end
⟩

meta instance : has_from_json univ_mvar_decl :=
⟨λ msg, match msg with
  | (json.array $ [c, json.array [un, pp]]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    if c_nm = `univ_mvar_decl.mk then do
      univ_mvar_decl.mk <$> (has_from_json.from_json un) <*> (has_from_json.from_json pp)
    else
    tactic.fail format!"[has_from_json_univ_mvar_decl] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_univ_mvar_decl] unexpected: {exc}"
  end
⟩

-- meta instance : has_from_json univ_mvar_decl := sorry

-- attribute [derive [has_to_tactic_json]] bool

run_cmd (has_to_tactic_json.to_tactic_json tt >>= (has_from_json.from_json : json → tactic bool))

meta instance : has_from_json local_decl :=
⟨λ msg, match msg with
  | (json.array $ [c, json.array [un, pp, ty, val, bi, idx]]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    if c_nm = `local_decl.mk then do
      local_decl.mk <$>
        (has_from_json.from_json un) <*>
          (has_from_json.from_json pp) <*>
                has_from_json.from_json ty <*>
                  has_from_json.from_json val <*>
                    has_from_json.from_json bi <*>
                      has_from_json.from_json idx
    else
    tactic.fail format!"[has_from_json_local_decl] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_local_decl] unexpected: {exc}"
  end
⟩

meta instance : has_from_json local_decl2 :=
⟨λ msg, match msg with
  | (json.array $ [c, json.array [un, pp, ety, bi, ty, prev, frozen, ld]]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    if c_nm = `local_decl2.mk then do
      local_decl2.mk <$>
        (has_from_json.from_json un) <*>
          (has_from_json.from_json pp) <*>
            has_from_json.from_json ety <*>
              has_from_json.from_json bi <*>
                has_from_json.from_json ty <*>
                  has_from_json.from_json prev <*>
                    has_from_json.from_json frozen <*>
                      has_from_json.from_json ld
    else
    tactic.fail format!"[has_from_json_local_decl2] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_local_decl2] unexpected: {exc}"
  end
⟩

meta instance : has_from_json context.decl :=
let ⟨fn₁⟩ := (by apply_instance : has_from_json mvar_decl) in
let ⟨fn₂⟩ := (by apply_instance : has_from_json univ_mvar_decl) in
let ⟨fn₃⟩ := (by apply_instance : has_from_json local_decl2) in
⟨λ msg, match msg with
  | (json.array $ [c, json.array args]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    tactic.trace format!"[has_from_json_context.decl] c_nm: {c_nm}",
    if c_nm = `context.decl.mvar_decl then context.decl.mvar_decl <$> fn₁ args.head else
    if c_nm = `context.decl.univ_mvar_decl then context.decl.univ_mvar_decl <$> fn₂ args.head else
    if c_nm = `context.decl.local_decl then context.decl.local_decl <$> fn₃ args.head else
    tactic.fail format!"[has_from_json_context.decl] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_context.decl] unexpected: {exc}"
  end
⟩

meta instance : has_from_json (list context.decl) := has_from_json_list
meta instance has_from_json_list_name_tactic_tag : has_from_json (list (name × tactic.tag)) := has_from_json_list

meta instance : has_from_json tactic_state_data :=
let ⟨fn₁⟩ := (by apply_instance : has_from_json (list context.decl)) in
let ⟨fn₂⟩ := (by apply_instance : has_from_json (list (name × tactic.tag))) in
⟨λ msg, match msg with
  | (json.array $ [c, json.array [decls_msg, goals_msg]]) := do
    (c_nm : name) ← has_from_json_name_aux c,
    tactic.trace format!"[has_from_json_tactic_state_data] c_nm: {c_nm}",
    if c_nm = `tactic_state_data.mk then tactic_state_data.mk <$> fn₁ decls_msg <*> fn₂ goals_msg else
    tactic.fail format!"[has_from_json_tactic_state_data] unexpected: {msg}"
  | exc := tactic.fail format!"[has_from_json_tactic_state_data] unexpected: {exc}"
  end
⟩

end instances

-- convience functions and instances

meta instance mvar_decl_has_to_string : has_to_format mvar_decl :=
⟨ λ d, format! "{{mvar_decl .\nunique_name := {d.unique_name},\npp_name := {d.pp_name},\nexpr_type := {d.expr_type},\nlocal_cxt := {d.local_cxt},\ntype := {d.type},\nassignment := {d.assignment},\n}" ⟩

meta instance univ_mvar_decl_has_to_string : has_to_format univ_mvar_decl :=
⟨ λ d, format! "{{univ_mvar_decl .\nunique_name := {d.unique_name},\nassignment := {d.assignment},\n}" ⟩

meta instance local_decl_has_to_string : has_to_format local_decl :=
⟨ λ d, format! "{{local_decl .\nunique_name := {d.unique_name},\npp_name := {d.pp_name},\ntype := {d.type},\nvalue := {d.value},\nbi := {repr d.bi},\nidx := {d.idx},\n}" ⟩

meta instance local_decl2_has_to_string : has_to_format local_decl2 :=
⟨ λ d, format! "{{local_decl2 .\nunique_name := {d.unique_name},\npp_name := {d.pp_name},\nexpr_type := {d.expr_type},\nbi := {repr d.bi},\ntype := {d.type},\nprev := {d.prev}\n},\nfrozen := {d.frozen},\nld := {d.ld}" ⟩

meta def context.decl.unique_name : context.decl -> name
| (context.decl.mvar_decl d) := d.unique_name
| (context.decl.univ_mvar_decl d) := d.unique_name
| (context.decl.local_decl d) := d.unique_name

meta instance context_decl_has_to_string : has_to_format context.decl :=
⟨ λ d, match d with
| context.decl.mvar_decl d := format! "{d}"
| context.decl.univ_mvar_decl d := format! "{d}"
| context.decl.local_decl d := format! "{d}"
end ⟩

meta instance context_has_to_string : has_to_format context :=
⟨ λ cxt, format! "{cxt.decls}" ⟩

-- constructors

meta def context.empty : context :=
{ decls := [], names := mk_name_set }

meta def context.mk1 (d : context.decl) : context :=
{ decls := [d], names := name_set.of_list [d.unique_name]}

meta def context.append (cxt1 : context) (cxt2 : context) : context :=
{ decls := cxt1.decls ++ (cxt2.decls.filter (λ d, ¬ (cxt1.names.contains d.unique_name))),
  names := cxt1.names.fold cxt2.names $ λ n ns, ns.insert n
}

meta instance context.has_append : has_append context := ⟨ context.append ⟩

/- Get univ metavariables level expression tree.-/
meta def context.process_level : level -> tactic context
| level.zero := return context.empty
| (level.succ lvl) := context.process_level lvl
| (level.max lvl1 lvl2) := do
  cxt1 <- context.process_level lvl1,
  cxt2 <- context.process_level lvl2,
  return (cxt1 ++ cxt2)
| (level.imax lvl1 lvl2) := do
  cxt1 <- context.process_level lvl1,
  cxt2 <- context.process_level lvl2,
  return (cxt1 ++ cxt2)
| (level.param _) := return context.empty
| lvl@(level.mvar nm) := do
  ass <- optional (tactic.get_univ_assignment lvl),
  let univ_decl := context.decl.univ_mvar_decl {
    unique_name := nm,
    assignment := ass
  },
  return (context.mk1 univ_decl)

def find_prev {α : Type} [decidable_eq α] (a : α) : list α -> option α
| [] := none
| [b] := none
| (b :: c :: ls) := if c = a then some b else find_prev (c :: ls)

/- Get metavariables and local constants inside an expression tree, follow recursively. -/
meta def context.process_expr : expr -> local_context -> tactic context
| (expr.var _) _ := return context.empty
| (expr.sort lvl) _ := context.process_level lvl
| (expr.const _ lvls) _ := do
  cxts <- lvls.mmap context.process_level,
  let cxt := cxts.foldl context.append context.empty,
  return cxt
| mv@(expr.mvar unique_nm pp_nm tp) _ := do
  lcxt <- type_context.run $ type_context.get_context mv,
  let local_cxt := lcxt.to_list,
  cxts <- local_cxt.mmap (λ e, e.unfold_macros >>= flip context.process_expr lcxt),
  let cxt := cxts.foldl context.append context.empty,
  tp_cxt <- tp.unfold_macros >>= flip context.process_expr lcxt,
  mv_type <- optional (tactic.infer_type mv),
  tp_cxt2 <- match mv_type with
  | (some e) := e.unfold_macros >>= flip context.process_expr lcxt
  | none := return context.empty
  end,
  assignment <- optional (tactic.get_assignment mv),
  ass_cxt <- match assignment with
  | (some e) := e.unfold_macros >>= flip context.process_expr lcxt
  | none := return context.empty
  end,
  let mv_dec := context.decl.mvar_decl {
    unique_name := unique_nm,
    pp_name := pp_nm,
    expr_type := tp,
    local_cxt := local_cxt,
    type := mv_type,
    assignment := assignment
  },
  return $ cxt ++ tp_cxt ++ tp_cxt2 ++ ass_cxt ++ (context.mk1 mv_dec)
| lconst@(expr.local_const unique_nm pp_nm bi tp) lcxt := do
  tp_cxt <- tp.unfold_macros >>= flip context.process_expr lcxt,
  loc_type <- optional (tactic.infer_type lconst),
  tp_cxt2 <- match loc_type with
  | (some e) := e.unfold_macros >>= flip context.process_expr lcxt
  | none := return context.empty
  end,
  let ld := lcxt.get_local_decl unique_nm,
  tp_cxt3 <- match ld with
  | (some ld) := ld.type.unfold_macros >>= flip context.process_expr  lcxt
  | none := return context.empty
  end,
  value_cxt <- match ld with
  | (some ld) := match ld.value with
    | (some e) := e.unfold_macros >>= flip context.process_expr lcxt
    | none := return context.empty
    end
  | none := return context.empty
  end,
  let (prev : option expr) := find_prev lconst lcxt.to_list,
  let prev_id := match prev with
  | some (expr.local_const id _ _ _) := some id
  | _ := none
  end,
  frozen_instances_opt <- tactic.frozen_local_instances,
  let frozen := match frozen_instances_opt with
  | none := ff
  | some frozen_instances := frozen_instances.any (λ e, e.local_uniq_name_option = some unique_nm)
  end,
  let loc_dec := context.decl.local_decl {
    unique_name := unique_nm,
    pp_name := pp_nm,
    expr_type := tp,
    bi := bi,
    type := loc_type,
    prev := prev_id,
    frozen := frozen,
    ld := lcxt.get_local_decl unique_nm,
  },
  return $ tp_cxt ++ tp_cxt2 ++ tp_cxt3 ++ value_cxt ++ (context.mk1 loc_dec)
| (expr.app expr1 expr2) lcxt := do
  cxt1 <- expr1.unfold_macros >>= flip context.process_expr lcxt,
  cxt2 <- expr2.unfold_macros >>= flip context.process_expr lcxt,
  return (cxt1 ++ cxt2)
| (expr.lam _ _ expr1 expr2) lcxt := do
  cxt1 <- expr1.unfold_macros >>= flip context.process_expr lcxt,
  cxt2 <- expr2.unfold_macros >>= flip context.process_expr lcxt,
  return (cxt1 ++ cxt2)
| (expr.pi _ _ expr1 expr2) lcxt := do
  cxt1 <- expr1.unfold_macros >>= flip context.process_expr lcxt,
  cxt2 <- expr2.unfold_macros >>= flip context.process_expr lcxt,
  return (cxt1 ++ cxt2)
| (expr.elet _ expr1 expr2 expr3) lcxt := do
  cxt1 <- expr1.unfold_macros >>= flip context.process_expr lcxt,
  cxt2 <- expr2.unfold_macros >>= flip context.process_expr lcxt,
  cxt3 <- expr3.unfold_macros >>= flip context.process_expr lcxt,
  return (cxt1 ++ cxt2 ++ cxt3)
| (expr.macro md deps) _ := tactic.fail format!"[process_expr] can't handle macro {expr.macro_def_name md}"

meta def context.get : tactic context := do
  lcxt <- type_context.run $ type_context.get_local_context,
  mvs <- tactic.get_goals,
  cxts <- mvs.mmap (λ e, e.unfold_macros >>= flip context.process_expr lcxt),
  let cxt := cxts.foldl context.append context.empty,
  return cxt

meta def tactic_state_data.get : tactic tactic_state_data := do
  cxt <- context.get,
  gs <- tactic.get_goals,
  goals <- gs.mmap $ λ g, do {
    nm <- g.mvar_uniq_name_option,
    tag <- tactic.get_tag g,
    return (nm, tag)
  },
  return {
    decls := cxt.decls,
    goals := goals
  }

-- tracing code for debugging

meta def trace_context : tactic unit := do
  -- cxt <- context.get,
  cxt ← tactic_state_data.get,
  has_to_tactic_json.to_tactic_json cxt >>= tactic.trace

-- rebuilding the context

meta def swap_univ_mvs (nm_map : name_map context.decl) : level → tactic level
| (level.mvar nm) := do {
  d <- nm_map.find nm,
  nm' <- match d with
  | (context.decl.univ_mvar_decl dd) := return dd.unique_name
  | _ := tactic.failed
  end,
  return $ level.mvar nm'
}
| (level.max lvl1 lvl2) := do {
  lvl1' <- swap_univ_mvs lvl1,
  lvl2' <- swap_univ_mvs lvl2,
  return $ level.max lvl1' lvl2'
}
| (level.imax lvl1 lvl2) := do {
  lvl1' <- swap_univ_mvs lvl1,
  lvl2' <- swap_univ_mvs lvl2,
  return $ level.imax lvl1' lvl2'
}
| (level.succ lvl) := do {
  lvl' <- swap_univ_mvs lvl,
  return $ level.succ lvl'
}
| lvl := return lvl  --level.zero and level.param

meta def swap_mvs (nm_map : name_map context.decl) : expr -> tactic expr
| (expr.mvar unique_nm pp_nm tp) := do {
  d <- nm_map.find unique_nm,
  (unique_nm', tp') <- match d with
  | (context.decl.mvar_decl dd) := return (dd.unique_name, dd.expr_type)
  | _ := tactic.failed
  end,
  return $ expr.mvar unique_nm pp_nm tp'
}
| (expr.local_const unique_nm pp_nm bi tp) := do {
  d <- nm_map.find unique_nm,
  (unique_nm', tp') <- match d with
  | (context.decl.local_decl dd) := return (dd.unique_name, dd.expr_type)
  | _ := tactic.failed
  end,
  return $ expr.local_const unique_nm' pp_nm bi tp'
}
| e@(expr.var _) := return e
| (expr.sort lvl) := do {
  lvl' <- swap_univ_mvs nm_map lvl,
  return $ expr.sort lvl'
}
| (expr.const nm lvls) := do {
  lvls' <- lvls.mmap (swap_univ_mvs nm_map),
  return $ expr.const nm lvls'
}
| (expr.app expr1 expr2) := do {
  expr1' <- swap_mvs expr1.unfold_string_macros.erase_annotations,
  expr2' <- swap_mvs expr2.unfold_string_macros.erase_annotations,
  return $ expr.app expr1' expr2'
}
| (expr.lam nm bi expr1 expr2) := do {
  expr1' <- swap_mvs expr1.unfold_string_macros.erase_annotations,
  expr2' <- swap_mvs expr2.unfold_string_macros.erase_annotations,
  return $ expr.lam nm bi expr1' expr2'
}
| (expr.pi nm bi expr1 expr2) := do {
  expr1' <- swap_mvs expr1.unfold_string_macros.erase_annotations,
  expr2' <- swap_mvs expr2.unfold_string_macros.erase_annotations,
  return $ expr.pi nm bi expr1' expr2'
}
| (expr.elet nm expr1 expr2 expr3) := do {
  expr1' <- swap_mvs expr1.unfold_string_macros.erase_annotations,
  expr2' <- swap_mvs expr2.unfold_string_macros.erase_annotations,
  expr3' <- swap_mvs expr3.unfold_string_macros.erase_annotations,
  return $ expr.elet nm expr1' expr2' expr3'
}
| (expr.macro _ _) := tactic.fail "[swap_mvs] can't handle macros yet"

/- A better constructor for locals which covers
frozen status and assignments. -/
meta def local_context.mk_local2 (pretty_name : name) (type : expr) (bi : binder_info) (frozen : bool) (assignment : option expr) (lcxt : local_context) : tactic (expr × local_context) := do
-- capture state
s <- tactic.read,
-- there are a few ways to add to local context,
-- the most direct being local_context.mk_local
-- however that doesn't handle assignments or frozen locals,
-- so we are setting the local context as the context of a goal
-- and using intro to push a new hypothesis onto the stack
target <- match (assignment, bi) with
| (none, bi) :=
pure $ expr.pi pretty_name bi type `(true)
| (some ass, binder_info.default) :=
pure $ expr.elet pretty_name type ass `(true)
| _ := tactic.fail "Unreachable state reached"
end,
goal_mv <- type_context.run $ type_context.mk_mvar "tmp_goal" target lcxt,
tactic.set_goals [goal_mv],
new_local <- tactic.intro_core pretty_name,
if frozen then
  tactic.freeze_local_instances
else
  pure (),
new_lcxt <- type_context.run $ type_context.get_local_context,
-- reset the state back to the beginning
_root_.set_state s,

return (new_local, new_lcxt)

meta def build_context_aux (nm_map : name_map context.decl) (loc_map : name_map local_context): context.decl -> tactic ((name_map context.decl) × (name_map local_context) × context.decl)
| (context.decl.univ_mvar_decl d) := do
  -- update dependencies
  new_assignment <- d.assignment.mmap (swap_univ_mvs nm_map),
  -- create mvar
  new_univ_mvar <- tactic.mk_meta_univ,
  new_uid <- match new_univ_mvar with
  | level.mvar nm := return nm
  | _ := tactic.failed
  end,
  -- assign mvar
  match new_assignment with
  | some lvl := type_context.run $ type_context.level.assign new_univ_mvar lvl
  | none := return ()
  end,
  -- return new decl
  let new_decl := context.decl.univ_mvar_decl {
    unique_name := new_uid,
    assignment := new_assignment
  },
  let new_nmap := nm_map.insert d.unique_name new_decl,
  return (new_nmap, loc_map, new_decl)
| (context.decl.local_decl d) := do
  -- update dependencies
  let pp_name := d.pp_name,
  new_type <- swap_mvs nm_map (d.type.get_or_else d.expr_type).unfold_string_macros.erase_annotations,
  let (new_lcxt_option : option local_context) := do {
    unique_name <- d.prev,
    loc_map.find unique_name
  },
  let new_lcxt := new_lcxt_option.get_or_else local_context.empty,
  ld <- d.ld,
  new_assignment <- ld.value.mmap ((swap_mvs nm_map) ∘ expr.unfold_string_macros ∘ expr.erase_annotations),
  -- create local
  (new_loc, new_lcxt) <- new_lcxt.mk_local2 pp_name new_type d.bi d.frozen new_assignment,
  (new_uid, new_tp) <- match new_loc with
  | expr.local_const nm _ bi tp := return (nm, tp)
  | _ := tactic.failed
  end,
  let (new_prev : option expr) := new_lcxt.fold (λ prev e, if e = new_loc then prev else some e) none,
  let new_prev_id := match new_prev with
  | some (expr.local_const id _ _ _) := some id
  | _ := none
  end,
  let new_decl := context.decl.local_decl {
    unique_name := new_uid,
    pp_name := pp_name,
    expr_type := new_tp,
    bi := d.bi,
    prev := new_prev_id,
    type := new_type,
    frozen := d.frozen,
    ld := new_lcxt.get_local_decl new_uid
  },
  let new_nmap := nm_map.insert d.unique_name new_decl,
  let new_loc_map := loc_map.insert d.unique_name new_lcxt,
  return (new_nmap, new_loc_map, new_decl)

| (context.decl.mvar_decl d) := do
  -- update dependencies
  let pp_name := d.pp_name,
  new_type <- swap_mvs nm_map (d.type.get_or_else d.expr_type).unfold_string_macros.erase_annotations,
  let (new_lcxt_option : option local_context) := do {
    last <- d.local_cxt.last_option,
    unique_name <- last.local_uniq_name_option,
    loc_map.find unique_name
  },
  let new_lcxt := new_lcxt_option.get_or_else local_context.empty,
  new_assignment <- d.assignment.mmap ((swap_mvs nm_map) ∘ expr.unfold_string_macros ∘ expr.erase_annotations),
  -- create mvar
  new_mvar <- type_context.run $ type_context.mk_mvar pp_name new_type new_lcxt,
  (new_uid, new_tp) <- match new_mvar with
  | expr.mvar nm _ tp := return (nm, tp)
  | _ := tactic.failed
  end,
  -- assign mvar
  match new_assignment with
  | some e := type_context.run $ type_context.assign new_mvar e
  | none := return ()
  end,
  let new_decl := context.decl.mvar_decl {
    unique_name := new_uid,
    pp_name := pp_name,
    expr_type := new_tp,
    local_cxt := new_lcxt.to_list,
    type := new_type,
    assignment := new_assignment
  },
  let new_nmap := nm_map.insert d.unique_name new_decl,
  return (new_nmap, loc_map, new_decl)

meta def rebuild_context : (list context.decl) -> tactic ((name_map context.decl) × (name_map local_context))
| [] := return (mk_name_map, mk_name_map)
| (d :: ds) := do
  (nm_map, loc_map) <- rebuild_context ds,
  (nm_map, loc_map, _) <- build_context_aux nm_map loc_map d,
  return (nm_map, loc_map)

meta def mvar_id : expr -> tactic name
| (expr.mvar uid _ _) := return uid
| _ := tactic.fail "Expecting mvar"

meta def rebuild_tactic_state (ts : tactic_state_data) : tactic unit := do
  (nm_map, _) <- rebuild_context ts.decls.reverse,
  goals_and_tags <- ts.goals.mmap $ λ ⟨nm, tag⟩, do {
    d <- nm_map.find nm,
    nm' <- match d with
    | context.decl.mvar_decl dd := return dd.unique_name
    | _ := tactic.fail "Expecting mvar_decl"
    end,
    mvars <- type_context.run type_context.list_mvars,
    mv <- mvars.mfirst $ λ e, do {
      nm2 <- mvar_id e,
      if nm' = nm2 then return e else failure
    },
    return (mv, tag)
  },
  let goals := goals_and_tags.map prod.fst,
  tactic.set_goals goals,
  goals_and_tags.mmap $ λ ⟨g, tag⟩, do {
    tactic.enable_tags tt,
    tactic.set_tag g tag,
    tactic.enable_tags ff -- seems to be off by default
  },
  return ()

-- for testing

meta def refresh_context : tactic unit := do
  cxt <- context.get,
  (nm_map, _) <- rebuild_context cxt.decls.reverse,
  gs <- tactic.get_goals,
  new_goals <- gs.mmap $ λ g, do {
    nm <- mvar_id g,
    d <- nm_map.find nm,
    tactic.trace (nm, d),
    nm' <- match d with
    | context.decl.mvar_decl dd := return dd.unique_name
    | _ := tactic.fail "Expecting mvar_decl"
    end,
    mvars <- type_context.run type_context.list_mvars,
    mv <- mvars.mfirst $ λ e, do {
      nm2 <- mvar_id e,
      if nm' = nm2 then return e else failure
    },
    return mv
  },
  tactic.set_goals new_goals

meta def refresh_tactic_state : tactic unit := do
  ts_data <- tactic_state_data.get,
  -- go into a clean tactic environment and build the tactic state
  ts <- tactic.unsafe_run_io $ io.run_tactic' $ do {
    rebuild_tactic_state ts_data,
    tactic.read  -- return tactic state
  },
  -- set tactic state to new one
  _root_.set_state ts

-- examples

section examples

-- example (α : Type) (a : nat): a=a := begin
-- trace_context,
-- refresh_tactic_state,
-- trace_context,
-- induction a,
-- trace_context,
-- refresh_tactic_state,  -- check that tags are still there
-- trace_context,
-- refl,
-- refl,
-- done,
-- trace_context,
-- end

-- -- Debug
-- example {α β γ : Type} --(f : α → β) (g : β → γ)
--   : α :=
-- begin
--   trace_context,
--   refresh_tactic_state,
--   trace_context,
-- end

-- -- Frozen local instances
-- def fish {α β γ} {m : Type → Type} [monad m] (f : m α → m β) (g : m β → m γ)
--   : m α → m γ :=
-- begin
--   trace_context,
--   refresh_tactic_state,
--   trace_context,
--   revert m, -- fails, `monad m` is a frozen instance
--   revert f, -- succeeds
--   revert α  -- succeeds
-- end

-- example : let x := 0 in x=0 := begin
-- intro,
-- trace_context,
-- refresh_tactic_state,
-- trace_context,
-- simp,
-- done,
-- end

end examples


import Smt

theorem contains : "a".contains 'a' := by
  smt
  sorry


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Scott Morrison, Keeley Hoek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.dlist.basic
import Mathlib.logic.function.basic
import Mathlib.control.basic
import Mathlib.meta.expr
import Mathlib.meta.rb_map
import Mathlib.data.bool
import Mathlib.tactic.binder_matching
import Mathlib.tactic.lean_core_docs
import Mathlib.tactic.interactive_expr
import Mathlib.Lean3Lib.system.io
import Mathlib.PostPort

universes u_1 l_2 l_1

namespace Mathlib

protected instance pos.has_lt : HasLess pos :=
  { Less := fun (x y : pos) => (pos.line x, pos.column x) < (pos.line y, pos.column y) }

namespace expr

/-- Given an expr `α` representing a type with numeral structure,
`of_nat α n` creates the `α`-valued numeral expression corresponding to `n`. -/
/-- Given an expr `α` representing a type with numeral structure,
`of_int α n` creates the `α`-valued numeral expression corresponding to `n`.
The output is either a numeral or the negation of a numeral. -/
/-- Generates an expression of the form `∃(args), inner`. `args` is assumed to be a list of local
constants. When possible, `p ∧ q` is used instead of `∃(_ : p), q`. -/
/-- `traverse f e` applies the monadic function `f` to the direct descendants of `e`. -/
/-- `mfoldl f a e` folds the monadic function `f` over the subterms of the expression `e`,
with initial value `a`. -/
/-- `kreplace e old new` replaces all occurrences of the expression `old` in `e`
with `new`. The occurrences of `old` in `e` are determined using keyed matching
with transparency `md`; see `kabstract` for details. If `unify` is true,
we may assign metavariables in `e` as we match subterms of `e` against `old`. -/
end expr

namespace interaction_monad

/-- `get_state` returns the underlying state inside an interaction monad, from within that monad. -/
-- Note that this is a generalization of `tactic.read` in core.

/-- `set_state` sets the underlying state inside an interaction monad, from within that monad. -/
-- Note that this is a generalization of `tactic.write` in core.

/--
`run_with_state state tac` applies `tac` to the given state `state` and returns the result,
subsequently restoring the original state.
If `tac` fails, then `run_with_state` does too.
-/
end interaction_monad

namespace format

/-- `join' [a,b,c]` produces the format object `abc`.
It differs from `format.join` by using `format.nil` instead of `""` for the empty list. -/
/-- `intercalate x [a, b, c]` produces the format object `a.x.b.x.c`,
where `.` represents `format.join`. -/
/-- `soft_break` is similar to `line`. Whereas in `group (x ++ line ++ y ++ line ++ z)`
the result either fits on one line or in three, `x ++ soft_break ++ y ++ soft_break ++ z`
each line break is decided independently -/
/-- Format a list as a comma separated list, without any brackets. -/
end format

/-- format a `list` by separating elements with `soft_break` instead of `line` -/
namespace tactic

/-- Private work function for `add_local_consts_as_local_hyps`: given
    `mappings : list (expr × expr)` corresponding to pairs `(var, hyp)` of variables and the local
    hypothesis created as a result and `(var :: rest) : list expr` of more local variables we
    examine `var` to see if it contains any other variables in `rest`. If it does, we put it to the
    back of the queue and recurse. If it does not, then we perform replacements inside the type of
    `var` using the `mappings`, create a new associate local hypothesis, add this to the list of
    mappings, and recurse. We are done once all local hypotheses have been processed.

    If the list of passed local constants have types which depend on one another (which can only
    happen by hand-crafting the `expr`s manually), this function will loop forever. -/
/-- `add_local_consts_as_local_hyps vars` add the given list `vars` of `expr.local_const`s to the
    tactic state. This is harder than it sounds, since the list of local constants which we have
    been passed can have dependencies between their types.

    For example, suppose we have two local constants `n : ℕ` and `h : n = 3`. Then we cannot blindly
    add `h` as a local hypothesis, since we need the `n` to which it refers to be the `n` created as
    a new local hypothesis, not the old local constant `n` with the same name. Of course, these
    dependencies can be nested arbitrarily deep.

    If the list of passed local constants have types which depend on one another (which can only
    happen by hand-crafting the `expr`s manually), this function will loop forever. -/
/- The `list.reverse` below is a performance optimisation since the list of available variables
   reported by the system is often mostly the reverse of the order in which they are dependent. -/

/-- Compute the arity of explicit arguments of `type`. -/
/-- Compute the arity of explicit arguments of `fn`'s type. -/
/--
For `e = f x₁ ... xₙ`, `get_app_fn_args_whnf e` returns `(f, [x₁, ..., xₙ])`. `e`
is normalised as necessary; for example:

```
get_app_fn_args_whnf `(let f := g x in f y) = (`(g), [`(x), `(y)])
```

The returned expression is in whnf, but the arguments are generally not.
-/
/--
`get_app_fn_whnf e md unfold_ginductive` is like `expr.get_app_fn e` but `e` is
normalised as necessary (with transparency `md`). `unfold_ginductive` controls
whether constructors of generalised inductive types are unfolded. The returned
expression is in whnf.
-/
/--
`get_app_fn_const_whnf e md unfold_ginductive` expects that `e = C x₁ ... xₙ`,
where `C` is a constant, after normalisation with transparency `md`. If so, the
name of `C` is returned. Otherwise the tactic fails. `unfold_ginductive`
controls whether constructors of generalised inductive types are unfolded.
-/
/--
`get_app_args_whnf e md unfold_ginductive` is like `expr.get_app_args e` but `e`
is normalised as necessary (with transparency `md`). `unfold_ginductive`
controls whether constructors of generalised inductive types are unfolded. The
returned expressions are not necessarily in whnf.
-/
/-- `pis loc_consts f` is used to create a pi expression whose body is `f`.
`loc_consts` should be a list of local constants. The function will abstract these local
constants from `f` and bind them with pi binders.

For example, if `a, b` are local constants with types `Ta, Tb`,
``pis [a, b] `(f a b)`` will return the expression
`Π (a : Ta) (b : Tb), f a b`. -/
/-- `lambdas loc_consts f` is used to create a lambda expression whose body is `f`.
`loc_consts` should be a list of local constants. The function will abstract these local
constants from `f` and bind them with lambda binders.

For example, if `a, b` are local constants with types `Ta, Tb`,
``lambdas [a, b] `(f a b)`` will return the expression
`λ (a : Ta) (b : Tb), f a b`. -/
-- TODO: move to `declaration` namespace in `meta/expr.lean`

/-- `mk_theorem n ls t e` creates a theorem declaration with name `n`, universe parameters named
`ls`, type `t`, and body `e`. -/
/-- `add_theorem_by n ls type tac` uses `tac` to synthesize a term with type `type`, and adds this
to the environment as a theorem with name `n` and universe parameters `ls`. -/
/-- `eval_expr' α e` attempts to evaluate the expression `e` in the type `α`.
This is a variant of `eval_expr` in core. Due to unexplained behavior in the VM, in rare
situations the latter will fail but the former will succeed. -/
/-- `mk_fresh_name` returns identifiers starting with underscores,
which are not legal when emitted by tactic programs. `mk_user_fresh_name`
turns the useful source of random names provided by `mk_fresh_name` into
names which are usable by tactic programs.

The returned name has four components which are all strings. -/
/-- `has_attribute' attr_name decl_name` checks
whether `decl_name` exists and has attribute `attr_name`. -/
/-- Checks whether the name is a simp lemma -/
/-- Checks whether the name is an instance. -/
/-- `local_decls` returns a dictionary mapping names to their corresponding declarations.
Covers all declarations from the current file. -/
/-- `get_decls_from` returns a dictionary mapping names to their
corresponding declarations.  Covers all declarations the files listed
in `fs`, with the current file listed as `none`.

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); e.g. `"src/tactic/core.lean"`

Possible issue: `get_decls_from` uses `get_cwd`, the current working
directory, which may not always point at the root of the project.
It would work better if it searched for the root directory or,
better yet, if Lean exposed its path information.
-/
/-- If `{nm}_{n}` doesn't exist in the environment, returns that, otherwise tries `{nm}_{n+1}` -/
/-- Return a name which doesn't already exist in the environment. If `nm` doesn't exist, it
returns that, otherwise it tries `nm_2`, `nm_3`, ... -/
/--
Returns a pair `(e, t)`, where `e ← mk_const d.to_name`, and `t = d.type`
but with universe params updated to match the fresh universe metavariables in `e`.

This should have the same effect as just
```lean
do e ← mk_const d.to_name,
   t ← infer_type e,
   return (e, t)
```
but is hopefully faster.
-/
/--
Replace every universe metavariable in an expression with a universe parameter.

(This is useful when making new declarations.)
-/
/-- `mk_local n` creates a dummy local variable with name `n`.
The type of this local constant is a constant with name `n`, so it is very unlikely to be
a meaningful expression. -/
/-- `mk_psigma [x,y,z]`, with `[x,y,z]` list of local constants of types `x : tx`,
`y : ty x` and `z : tz x y`, creates an expression of sigma type:
`⟨x,y,z⟩ : Σ' (x : tx) (y : ty x), tz x y`.
-/
/--
Update the type of a local constant or metavariable. For local constants and
metavariables obtained via, for example, `tactic.get_local`, the type stored in
the expression is not necessarily the same as the type returned by `infer_type`.
This tactic, given a local constant or metavariable, updates the stored type to
match the output of `infer_type`. If the input is not a local constant or
metavariable, `update_type` does nothing.
-/
/-- `elim_gen_prod n e _ ns` with `e` an expression of type `psigma _`, applies `cases` on `e` `n`
times and uses `ns` to name the resulting variables. Returns a triple: list of new variables,
remaining term and unused variable names.
-/
/-- `elim_gen_sum n e` applies cases on `e` `n` times. `e` is assumed to be a local constant whose
type is a (nested) sum `⊕`. Returns the list of local constants representing the components of `e`.
-/
/-- Given `elab_def`, a tactic to solve the current goal,
`extract_def n trusted elab_def` will create an auxiliary definition named `n` and use it
to close the goal. If `trusted` is false, it will be a meta definition. -/
/-- Attempts to close the goal with `dec_trivial`. -/
/-- Runs a tactic for a result, reverting the state after completion. -/
/-- Runs a tactic for a result, reverting the state after completion or error. -/
/-- Repeat a tactic at least once, calling it recursively on all subgoals,
until it fails. This tactic fails if the first invocation fails. -/
/-- `iterate_range m n t`: Repeat the given tactic at least `m` times and
at most `n` times or until `t` fails. Fails if `t` does not run at least `m` times. -/
/--
Given a tactic `tac` that takes an expression
and returns a new expression and a proof of equality,
use that tactic to change the type of the hypotheses listed in `hs`,
as well as the goal if `tgt = tt`.

Returns `tt` if any types were successfully changed.
-/
/-- `revert_after e` reverts all local constants after local constant `e`. -/
/-- `revert_target_deps` reverts all local constants on which the target depends (recursively).
  Returns the number of local constants that have been reverted. -/
/-- `generalize' e n` generalizes the target with respect to `e`. It creates a new local constant
with name `n` of the same type as `e` and replaces all occurrences of `e` by `n`.

`generalize'` is similar to `generalize` but also succeeds when `e` does not occur in the
goal, in which case it just calls `assert`.
In contrast to `generalize` it already introduces the generalized variable. -/
/--
`intron_no_renames n` calls `intro` `n` times, using the pretty-printing name
provided by the binder to name the new local constant.
Unlike `intron`, it does not rename introduced constants if the names shadow existing constants.
-/
/-!
### Various tactics related to local definitions (local constants of the form `x : α := t`)

We call `t` the value of `x`.
-/

/-- `local_def_value e` returns the value of the expression `e`, assuming that `e` has been defined
  locally using a `let` expression. Otherwise it fails. -/
/-- `is_local_def e` succeeds when `e` is a local definition (a local constant of the form
`e : α := t`) and otherwise fails. -/
/-- like `split_on_p p xs`, `partition_local_deps_aux vs xs acc` searches for matches in `xs`
(using membership to `vs` instead of a predicate) and breaks `xs` when matches are found.
whereas `split_on_p p xs` removes the matches, `partition_local_deps_aux vs xs acc` includes
them in the following partition. Also, `partition_local_deps_aux vs xs acc` discards the partition
running up to the first match. -/
/-- `partition_local_deps vs`, with `vs` a list of local constants,
reorders `vs` in the order they appear in the local context together
with the variables that follow them. If local context is `[a,b,c,d,e,f]`,
and that we call `partition_local_deps [d,b]`, we get `[[d,e,f], [b,c]]`.
The head of each list is one of the variables given as a parameter. -/
/-- `clear_value [e₀, e₁, e₂, ...]` clears the body of the local definitions `e₀`, `e₁`, `e₂`, ...
changing them into regular hypotheses. A hypothesis `e : α := t` is changed to `e : α`. The order of
locals `e₀`, `e₁`, `e₂` does not matter as a permutation will be chosen so as to preserve type
correctness. This tactic is called `clearbody` in Coq. -/
/--
`context_has_local_def` is true iff there is at least one local definition in
the context.
-/
/--
`context_upto_hyp_has_local_def h` is true iff any of the hypotheses in the
context up to and including `h` is a local definition.
-/
/-- A variant of `simplify_bottom_up`. Given a tactic `post` for rewriting subexpressions,
`simp_bottom_up post e` tries to rewrite `e` starting at the leaf nodes. Returns the resulting
expression and a proof of equality. -/
/-- Caches unary type classes on a type `α : Type.{univ}`. -/
/-- Creates an `instance_cache` for the type `α`. -/
namespace instance_cache

/-- If `n` is the name of a type class with one parameter, `get c n` tries to find an instance of
`n c.α` by checking the cache `c`. If there is no entry in the cache, it tries to find the instance
via type class resolution, and updates the cache. -/
/-- If `e` is a `pi` expression that binds an instance-implicit variable of type `n`,
`append_typeclasses e c l` searches `c` for an instance `p` of type `n` and returns `p :: l`. -/
/-- Creates the application `n c.α p l`, where `p` is a type class instance found in the cache `c`.
-/
/-- `c.of_nat n` creates the `c.α`-valued numeral expression corresponding to `n`. -/
/-- `c.of_int n` creates the `c.α`-valued numeral expression corresponding to `n`.
The output is either a numeral or the negation of a numeral. -/
end instance_cache

/-- A variation on `assert` where a (possibly incomplete)
proof of the assertion is provided as a parameter.

``(h,gs) ← local_proof `h p tac`` creates a local `h : p` and
use `tac` to (partially) construct a proof for it. `gs` is the
list of remaining goals in the proof of `h`.

The benefits over assert are:
- unlike with ``h ← assert `h p, tac`` , `h` cannot be used by `tac`;
- when `tac` does not complete the proof of `h`, returning the list
  of goals allows one to write a tactic using `h` and with the confidence
  that a proof will not boil over to goals left over from the proof of `h`,
  unlike what would be the case when using `tactic.swap`.
-/
/-- `var_names e` returns a list of the unique names of the initial pi bindings in `e`. -/
/-- When `struct_n` is the name of a structure type,
`subobject_names struct_n` returns two lists of names `(instances, fields)`.
The names in `instances` are the projections from `struct_n` to the structures that it extends
(assuming it was defined with `old_structure_cmd false`).
The names in `fields` are the standard fields of `struct_n`. -/
/-- `expanded_field_list struct_n` produces a list of the names of the fields of the structure
named `struct_n`. These are returned as pairs of names `(prefix, name)`, where the full name
of the projection is `prefix.name`.

`struct_n` cannot be a synonym for a `structure`, it must be itself a `structure` -/
/--
Return a list of all type classes which can be instantiated
for the given expression.
-/
/--
Finds an instance of an implication `cond → tgt`.
Returns a pair of a local constant `e` of type `cond`, and an instance of `tgt` that can mention
`e`. The local constant `e` is added as an hypothesis to the tactic state, but should not be used,
since it has been "proven" by a metavariable.
-/
/-- Create a list of `n` fresh metavariables. -/
/-- Returns the only goal, or fails if there isn't just one goal. -/
/-- `iterate_at_most_on_all_goals n t`: repeat the given tactic at most `n` times on all goals,
or until it fails. Always succeeds. -/
/-- `iterate_at_most_on_subgoals n t`: repeat the tactic `t` at most `n` times on the first
goal and on all subgoals thus produced, or until it fails. Fails iff `t` fails on
current goal. -/
/-- This makes sure that the execution of the tactic does not change the tactic state.
This can be helpful while using rewrite, apply, or expr munging.
Remember to instantiate your metavariables before you're done! -/
/--
`apply_list l`, for `l : list (tactic expr)`,
tries to apply the lemmas generated by the tactics in `l` on the first goal, and
fail if none succeeds.
-/
/--
Constructs a list of `tactic expr` given a list of p-expressions, as follows:
- if the p-expression is the name of a theorem, use `i_to_expr_for_apply` on it
- if the p-expression is a user attribute, add all the theorems with this attribute
  to the list.

We need to return a list of `tactic expr`, rather than just `expr`, because these expressions
will be repeatedly applied against goals, and we need to ensure that metavariables don't get stuck.
-/
/--`apply_rules hs n`: apply the list of rules `hs` (given as pexpr) and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times.

Unlike `solve_by_elim`, `apply_rules` does not do any backtracking, and just greedily applies
a lemma from the list until it can't.
 -/
/-- `replace h p` elaborates the pexpr `p`, clears the existing hypothesis named `h` from the local
context, and adds a new hypothesis named `h`. The type of this hypothesis is the type of `p`.
Fails if there is nothing named `h` in the local context. -/
/-- Auxiliary function for `iff_mp` and `iff_mpr`. Takes a name, which should be either `` `iff.mp``
or `` `iff.mpr``. If the passed expression is an iterated function type eventually producing an
`iff`, returns an expression with the `iff` converted to either the forwards or backwards
implication, as requested. -/
/-- `iff_mp_core e ty` assumes that `ty` is the type of `e`.
If `ty` has the shape `Π ..., A ↔ B`, returns an expression whose type is `Π ..., A → B`. -/
/-- `iff_mpr_core e ty` assumes that `ty` is the type of `e`.
If `ty` has the shape `Π ..., A ↔ B`, returns an expression whose type is `Π ..., B → A`. -/
/-- Given an expression whose type is (a possibly iterated function producing) an `iff`,
create the expression which is the forward implication. -/
/-- Given an expression whose type is (a possibly iterated function producing) an `iff`,
create the expression which is the reverse implication. -/
/--
Attempts to apply `e`, and if that fails, if `e` is an `iff`,
try applying both directions separately.
-/
/--
Configuration options for `apply_any`:
* `use_symmetry`: if `apply_any` fails to apply any lemma, call `symmetry` and try again.
* `use_exfalso`: if `apply_any` fails to apply any lemma, call `exfalso` and try again.
* `apply`: specify an alternative to `tactic.apply`; usually `apply := tactic.eapply`.
-/
/--
This is a version of `apply_any` that takes a list of `tactic expr`s instead of `expr`s,
and evaluates these as thunks before trying to apply them.

We need to do this to avoid metavariables getting stuck during subsequent rounds of `apply`.
-/
/--
`apply_any lemmas` tries to apply one of the list `lemmas` to the current goal.

`apply_any lemmas opt` allows control over how lemmas are applied.
`opt` has fields:
* `use_symmetry`: if no lemma applies, call `symmetry` and try again. (Defaults to `tt`.)
* `use_exfalso`: if no lemma applies, call `exfalso` and try again. (Defaults to `tt`.)
* `apply`: use a tactic other than `tactic.apply` (e.g. `tactic.fapply` or `tactic.eapply`).

`apply_any lemmas tac` calls the tactic `tac` after a successful application.
Defaults to `skip`. This is used, for example, by `solve_by_elim` to arrange
recursive invocations of `apply_any`.
-/
/-- Try to apply a hypothesis from the local context to the goal. -/
/-- `change_core e none` is equivalent to `change e`. It tries to change the goal to `e` and fails
if this is not a definitional equality.

`change_core e (some h)` assumes `h` is a local constant, and tries to change the type of `h` to `e`
by reverting `h`, changing the goal, and reintroducing hypotheses. -/
/--
`change_with_at olde newe hyp` replaces occurences of `olde` with `newe` at hypothesis `hyp`,
assuming `olde` and `newe` are defeq when elaborated.
-/
/-- Returns a list of all metavariables in the current partial proof. This can differ from
the list of goals, since the goals can be manually edited. -/
/--
`sorry_if_contains_sorry` will solve any goal already containing `sorry` in its type with `sorry`,
and fail otherwise.
-/
/-- Fail if the target contains a metavariable. -/
/-- Succeeds only if the current goal is a proposition. -/
/-- Succeeds only if we can construct an instance showing the
  current goal is a subsingleton type. -/
/--
Succeeds only if the current goal is "terminal",
in the sense that no other goals depend on it
(except possibly through shared metavariables; see `independent_goal`).
-/
/--
Succeeds only if the current goal is "independent", in the sense
that no other goals depend on it, even through shared meta-variables.
-/
/-- `triv'` tries to close the first goal with the proof `trivial : true`. Unlike `triv`,
it only unfolds reducible definitions, so it sometimes fails faster. -/
/-- Apply a tactic as many times as possible, collecting the results in a list.
Fail if the tactic does not succeed at least once. -/
/-- Introduces one or more variables and returns the new local constants.
Fails if `intro` cannot be applied. -/
/-- Run a tactic "under binders", by running `intros` before, and `revert` afterwards. -/
namespace interactive

/-- Run a tactic "under binders", by running `intros` before, and `revert` afterwards. -/
end interactive

/-- `successes` invokes each tactic in turn, returning the list of successful results. -/
/--
Try all the tactics in a list, each time starting at the original `tactic_state`,
returning the list of successful results,
and reverting to the original `tactic_state`.
-/
-- Note this is not the same as `successes`, which keeps track of the evolving `tactic_state`.

/--
Try all the tactics in a list, each time starting at the original `tactic_state`,
returning the list of successful results sorted by
the value produced by a subsequent execution of the `sort_by` tactic,
and reverting to the original `tactic_state`.
-/
/-- Return target after instantiating metavars and whnf. -/
/--
Just like `split`, `fsplit` applies the constructor when the type of the target is
an inductive data type with one constructor.
However it does not reorder goals or invoke `auto_param` tactics.
-/
-- FIXME check if we can remove `auto_param := ff`

/-- Calls `injection` on each hypothesis, and then, for each hypothesis on which `injection`
succeeds, clears the old hypothesis. -/
/-- Calls `cases` on every local hypothesis, succeeding if
it succeeds on at least one hypothesis. -/
/--
`note_anon t v`, given a proof `v : t`,
adds `h : t` to the current context, where the name `h` is fresh.

`note_anon none v` will infer the type `t` from `v`.
-/
-- While `note` provides a default value for `t`, it doesn't seem this could ever be used.

/-- `find_local t` returns a local constant with type t, or fails if none exists. -/
/-- `dependent_pose_core l`: introduce dependent hypotheses, where the proofs depend on the values
of the previous local constants. `l` is a list of local constants and their values. -/
/--
Instantiates metavariables that appear in the current goal.
-/
/--
Instantiates metavariables in all goals.
-/
/-- Protect the declaration `n` -/
end tactic

namespace lean.parser

/-- `emit_command_here str` behaves as if the string `str` were placed as a user command at the
current line. -/
/-- Inner recursion for `emit_code_here`. -/
/-- `emit_code_here str` behaves as if the string `str` were placed at the current location in
source code. -/
/-- `run_parser p` is like `run_cmd` but for the parser monad. It executes parser `p` at the
top level, giving access to operations like `emit_code_here`. -/
/-- `get_current_namespace` returns the current namespace (it could be `name.anonymous`).

This function deserves a C++ implementation in core lean, and will fail if it is not called from
the body of a command (i.e. anywhere else that the `lean.parser` monad can be invoked). -/
/-- `get_variables` returns a list of existing variable names, along with their types and binder
info. -/
/-- `get_included_variables` returns those variables `v` returned by `get_variables` which have been
"included" by an `include v` statement and are not (yet) `omit`ed. -/
/-- From the `lean.parser` monad, synthesize a `tactic_state` which includes all of the local
variables referenced in `es : list pexpr`, and those variables which have been `include`ed in the
local context---precisely those variables which would be ambiently accessible if we were in a
tactic-mode block where the goals had types `es.mmap to_expr`, for example.

Returns a new `ts : tactic_state` with these local variables added, and
`mappings : list (expr × expr)`, for which pairs `(var, hyp)` correspond to an existing variable
`var` and the local hypothesis `hyp` which was added to the tactic state `ts` as a result. -/
end lean.parser

namespace tactic

/--
Hole command used to fill in a structure's field when specifying an instance.

In the following:

```lean
instance : monad id :=
{! !}
```

invoking the hole command "Instance Stub" ("Generate a skeleton for the structure under
construction.") produces:

```lean
instance : monad id :=
{ map := _,
  map_const := _,
  pure := _,
  seq := _,
  seq_left := _,
  seq_right := _,
  bind := _ }
```
-/
/-- Like `resolve_name` except when the list of goals is
empty. In that situation `resolve_name` fails whereas
`resolve_name'` simply proceeds on a dummy goal -/
/-- Strips unnecessary prefixes from a name, e.g. if a namespace is open. -/
/-- Used to format return strings for the hole commands `match_stub` and `eqn_stub`. -/
/--
Hole command used to generate a `match` expression.

In the following:

```lean
meta def foo (e : expr) : tactic unit :=
{! e !}
```

invoking hole command "Match Stub" ("Generate a list of equations for a `match` expression")
produces:

```lean
meta def foo (e : expr) : tactic unit :=
match e with
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
end
```
-/
/--
Invoking hole command "Equations Stub" ("Generate a list of equations for a recursive definition")
in the following:

```lean
meta def foo : {! expr → tactic unit !} -- `:=` is omitted
```

produces:

```lean
meta def foo : expr → tactic unit
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
```

A similar result can be obtained by invoking "Equations Stub" on the following:

```lean
meta def foo : expr → tactic unit := -- do not forget to write `:=`!!
{! !}
```

```lean
meta def foo : expr → tactic unit := -- don't forget to erase `:=`!!
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
```

-/
/--
This command lists the constructors that can be used to satisfy the expected type.

Invoking "List Constructors" ("Show the list of constructors of the expected type")
in the following hole:

```lean
def foo : ℤ ⊕ ℕ :=
{! !}
```

produces:

```lean
def foo : ℤ ⊕ ℕ :=
{! sum.inl, sum.inr !}
```

and will display:

```lean
sum.inl : ℤ → ℤ ⊕ ℕ

sum.inr : ℕ → ℤ ⊕ ℕ
```

-/
/-- Makes the declaration `classical.prop_decidable` available to type class inference.
This asserts that all propositions are decidable, but does not have computational content. -/
/-- `mk_comp v e` checks whether `e` is a sequence of nested applications `f (g (h v))`, and if so,
returns the expression `f ∘ g ∘ h`. -/
/-- Given two expressions `e₀` and `e₁`, return the expression `` `(%%e₀ ↔ %%e₁)``. -/
/--
From a lemma of the shape `∀ x, f (g x) = h x`
derive an auxiliary lemma of the form `f ∘ g = h`
for reasoning about higher-order functions.
-/
/-- A user attribute that applies to lemmas of the shape `∀ x, f (g x) = h x`.
It derives an auxiliary lemma of the form `f ∘ g = h` for reasoning about higher-order functions.
-/
@[simp] theorem Mathlib.is_lawful_applicative.map_comp_pure {f : Type l_2 → Type l_1} [Applicative f] [c : is_lawful_applicative f] {α : Type l_2} {β : Type l_2} (g : α → β) : Functor.map g ∘ pure = pure ∘ g :=
  funext fun (x : α) => map_pure g x

/--
Copies a definition into the `tactic.interactive` namespace to make it usable
in proof scripts. It allows one to write

```lean
@[interactive]
meta def my_tactic := ...
```

instead of

```lean
meta def my_tactic := ...

run_cmd add_interactive [``my_tactic]
```
-/
/--
Use `refine` to partially discharge the goal,
or call `fconstructor` and try again.
-/
/-- Similar to `existsi`, `use l` will use entries in `l` to instantiate existential obligations
at the beginning of a target. Unlike `existsi`, the pexprs in `l` are elaborated with respect to
the expected type.

```lean
example : ∃ x : ℤ, x = x :=
by tactic.use ``(42)
```

See the doc string for `tactic.interactive.use` for more information.
 -/
/-- `clear_aux_decl_aux l` clears all expressions in `l` that represent aux decls from the
local context. -/
/-- `clear_aux_decl` clears all expressions from the local context that represent aux decls. -/
/-- `apply_at_aux e et [] h ht` (with `et` the type of `e` and `ht` the type of `h`)
finds a list of expressions `vs` and returns `(e.mk_args (vs ++ [h]), vs)`. -/
/-- `apply_at e h` applies implication `e` on hypothesis `h` and replaces `h` with the result. -/
/-- `symmetry_hyp h` applies `symmetry` on hypothesis `h`. -/
/-- `setup_tactic_parser` is a user command that opens the namespaces used in writing
interactive tactics, and declares the local postfix notation `?` for `optional` and `*` for `many`.
It does *not* use the `namespace` command, so it will typically be used after
`namespace tactic.interactive`.
-/
/-- `finally tac finalizer` runs `tac` first, then runs `finalizer` even if
`tac` fails. `finally tac finalizer` fails if either `tac` or `finalizer` fails. -/
/--
`on_exception handler tac` runs `tac` first, and then runs `handler` only if `tac` failed.
-/
/-- `decorate_error add_msg tac` prepends `add_msg` to an exception produced by `tac` -/
/-- Applies tactic `t`. If it succeeds, revert the state, and return the value. If it fails,
  returns the error message. -/
/-- Applies tactic `t`. If it succeeds, return the value. If it fails, returns the error message. -/
/-- This tactic succeeds if `t` succeeds or fails with message `msg` such that `p msg` is `tt`.
-/
/-- `trace_error msg t` executes the tactic `t`. If `t` fails, traces `msg` and the failure message
of `t`. -/
/--
``trace_if_enabled `n msg`` traces the message `msg`
only if tracing is enabled for the name `n`.

Create new names registered for tracing with `declare_trace n`.
Then use `set_option trace.n true/false` to enable or disable tracing for `n`.
-/
/--
``trace_state_if_enabled `n msg`` prints the tactic state,
preceded by the optional string `msg`,
only if tracing is enabled for the name `n`.
-/
/--
This combinator is for testing purposes. It succeeds if `t` fails with message `msg`,
and fails otherwise.
-/
/--
Construct a `Try this: refine ...` or `Try this: exact ...` string which would construct `g`.
-/
/-- `with_local_goals gs tac` runs `tac` on the goals `gs` and then restores the
initial goals and returns the goals `tac` ended on. -/
/-- like `with_local_goals` but discards the resulting goals -/
/-- Representation of a proof goal that lends itself to comparison. The
following goal:

```lean
l₀ : T,
l₁ : T
⊢ ∀ v : T, foo
```

is represented as

```
(2, ∀ l₀ l₁ v : T, foo)
```

The number 2 indicates that first the two bound variables of the
`∀` are actually local constant. Comparing two such goals with `=`
rather than `=ₐ` or `is_def_eq` tells us that proof script should
not see the difference between the two.
 -/
/-- proof state made of multiple `goal` meant for comparing
the result of running different tactics -/
/-- create a `packaged_goal` corresponding to the current goal -/
/-- `goal_of_mvar g`, with `g` a meta variable, creates a
`packaged_goal` corresponding to `g` interpretted as a proof goal -/
/-- `get_proof_state` lists the user visible goal for each goal
of the current state and for each goal, abstracts all of the
meta variables of the other gaols.

This produces a list of goals in the form of `ℕ × expr` where
the `expr` encodes the following proof state:

```lean
2 goals
l₁ : t₁,
l₂ : t₂,
l₃ : t₃
⊢ tgt₁

⊢ tgt₂
```

as

```lean
[ (3, ∀ (mv : tgt₁) (mv : tgt₂) (l₁ : t₁) (l₂ : t₂) (l₃ : t₃), tgt₁),
  (0, ∀ (mv : tgt₁) (mv : tgt₂), tgt₂) ]
```

with 2 goals, the first 2 bound variables encode the meta variable
of all the goals, the next 3 (in the first goal) and 0 (in the second goal)
are the local constants.

This representation allows us to compare goals and proof states while
ignoring information like the unique name of local constants and
the equality or difference of meta variables that encode the same goal.
-/
/--
Run `tac` in a disposable proof state and return the state.
See `proof_state`, `goal` and `get_proof_state`.
-/
/-- A type alias for `tactic format`, standing for "pretty print format". -/
/-- `mk` lifts `fmt : format` to the tactic monad (`pformat`). -/
/-- an alias for `pp`. -/
/-- See `format!` in `init/meta/interactive_base.lean`.

The main differences are that `pp` is called instead of `to_fmt` and that we can use
arguments of type `tactic α` in the quotations.

Now, consider the following:
```lean
e ← to_expr ``(3 + 7),
trace format!"{e}"  -- outputs `has_add.add.{0} nat nat.has_add
                    -- (bit1.{0} nat nat.has_one nat.has_add (has_one.one.{0} nat nat.has_one)) ...`
trace pformat!"{e}" -- outputs `3 + 7`
```

The difference is significant. And now, the following is expressible:

```lean
e ← to_expr ``(3 + 7),
trace pformat!"{e} : {infer_type e}" -- outputs `3 + 7 : ℕ`
```

See also: `trace!` and `fail!`
-/
/--
The combination of `pformat` and `fail`.
-/
/--
The combination of `pformat` and `trace`.
-/
/-- A hackish way to get the `src` directory of mathlib. -/
/-- Checks whether a declaration with the given name is declared in mathlib.
If you want to run this tactic many times, you should use `environment.is_prefix_of_file` instead,
since it is expensive to execute `get_mathlib_dir` many times. -/
/--
Runs a tactic by name.
If it is a `tactic string`, return whatever string it returns.
If it is a `tactic unit`, return the name.
(This is mostly used in invoking "self-reporting tactics", e.g. by `tidy` and `hint`.)
-/
/-- auxiliary function for `apply_under_n_pis` -/
/--
Assumes `pi_expr` is of the form `Π x1 ... xn xn+1..., _`.
Creates a pexpr of the form `Π x1 ... xn, func (arg x1 ... xn)`.
All arguments (implicit and explicit) to `arg` should be supplied. -/
/--
Assumes `pi_expr` is of the form `Π x1 ... xn, _`.
Creates a pexpr of the form `Π x1 ... xn, func (arg x1 ... xn)`.
All arguments (implicit and explicit) to `arg` should be supplied. -/
/--
If `func` is a `pexpr` representing a function that takes an argument `a`,
`get_pexpr_arg_arity_with_tgt func tgt` returns the arity of `a`.
When `tgt` is a `pi` expr, `func` is elaborated in a context
with the domain of `tgt`.

Examples:
* ```get_pexpr_arg_arity ``(ring) `(true)``` returns 0, since `ring` takes one non-function
  argument.
* ```get_pexpr_arg_arity_with_tgt ``(monad) `(true)``` returns 1, since `monad` takes one argument
  of type `α → α`.
* ```get_pexpr_arg_arity_with_tgt ``(module R) `(Π (R : Type), comm_ring R → true)``` returns 0
-/
/-- `find_private_decl n none` finds a private declaration named `n` in any of the imported files.

`find_private_decl n (some m)` finds a private declaration named `n` in the same file where a
declaration named `m` can be found. -/
/-- `import_private foo from bar` finds a private declaration `foo` in the same file as `bar`
and creates a local notation to refer to it.

`import_private foo` looks for `foo` in all imported files.

When possible, make `foo` non-private rather than using this feature.
 -/
/--
The command `mk_simp_attribute simp_name "description"` creates a simp set with name `simp_name`.
Lemmas tagged with `@[simp_name]` will be included when `simp with simp_name` is called.
`mk_simp_attribute simp_name none` will use a default description.

Appending the command with `with attr1 attr2 ...` will include all declarations tagged with
`attr1`, `attr2`, ... in the new simp set.

This command is preferred to using ``run_cmd mk_simp_attr `simp_name`` since it adds a doc string
to the attribute that is defined. If you need to create a simp set in a file where this command is
not available, you should use
```lean
run_cmd mk_simp_attr `simp_name
run_cmd add_doc_string `simp_attr.simp_name "Description of the simp set here"
```
-/


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

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)

! This file was ported from Lean 3 source module data.seq.parallel
! leanprover-community/mathlib commit a7e36e48519ab281320c4d192da6a7b348ce40ad
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Seq.Wseq

universe u v

namespace Computation

/- ./././Mathport/Syntax/Translate/Command.lean:224:11: unsupported: unusual advanced open style -/
/- ./././Mathport/Syntax/Translate/Command.lean:224:11: unsupported: unusual advanced open style -/
variable {α : Type u} {β : Type v}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
def Parallel.aux2 : List (Computation α) → Sum α (List (Computation α)) :=
  List.foldr
    (fun c o =>
      match o with
      | Sum.inl a => Sum.inl a
      | Sum.inr ls => rmap (fun c' => c'::ls) (destruct c))
    (Sum.inr [])
#align computation.parallel.aux2 Computation.Parallel.aux2

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
def Parallel.aux1 :
    List (Computation α) × Wseq (Computation α) →
      Sum α (List (Computation α) × Wseq (Computation α))
  | (l, S) =>
    rmap
      (fun l' =>
        match Seq.destruct S with
        | none => (l', Seq.nil)
        | some (none, S') => (l', S')
        | some (some c, S') => (c::l', S'))
      (Parallel.aux2 l)
#align computation.parallel.aux1 Computation.Parallel.aux1

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel (S : Wseq (Computation α)) : Computation α :=
  corec Parallel.aux1 ([], S)
#align computation.parallel Computation.parallel

theorem TerminatesParallel.aux :
    ∀ {l : List (Computation α)} {S c},
      c ∈ l → Terminates c → Terminates (corec Parallel.aux1 (l, S)) :=
  by
  have lem1 :
    ∀ l S, (∃ a : α, parallel.aux2 l = Sum.inl a) → terminates (corec parallel.aux1 (l, S)) :=
    by
    intro l S e
    cases' e with a e
    have : corec parallel.aux1 (l, S) = return a :=
      by
      apply destruct_eq_ret
      simp [parallel.aux1]
      rw [e]
      simp [rmap]
    rw [this]
    infer_instance
  intro l S c m T
  revert l S
  apply @terminates_rec_on _ _ c T _ _
  · intro a l S m
    apply lem1
    induction' l with c l IH generalizing m <;> simp at m
    · contradiction
    cases' m with e m
    · rw [← e]
      simp [parallel.aux2]
      cases' List.foldr parallel.aux2._match_1 (Sum.inr List.nil) l with a' ls
      exacts[⟨a', rfl⟩, ⟨a, rfl⟩]
    · cases' IH m with a' e
      simp [parallel.aux2]
      simp [parallel.aux2] at e
      rw [e]
      exact ⟨a', rfl⟩
  · intro s IH l S m
    have H1 : ∀ l', parallel.aux2 l = Sum.inr l' → s ∈ l' :=
      by
      induction' l with c l IH' generalizing m <;> intro l' e' <;> simp at m
      · contradiction
      cases' m with e m <;> simp [parallel.aux2] at e'
      · rw [← e] at e'
        cases' List.foldr parallel.aux2._match_1 (Sum.inr List.nil) l with a' ls <;>
          injection e' with e'
        rw [← e']
        simp
      · induction' e : List.foldr parallel.aux2._match_1 (Sum.inr List.nil) l with a' ls <;>
          rw [e] at e'
        · contradiction
        have := IH' m _ e
        simp [parallel.aux2] at e'
        cases destruct c <;> injection e' with h'
        rw [← h']
        simp [this]
    induction' h : parallel.aux2 l with a l'
    · exact lem1 _ _ ⟨a, h⟩
    · have H2 : corec parallel.aux1 (l, S) = think _ :=
        by
        apply destruct_eq_think
        simp [parallel.aux1]
        rw [h]
        simp [rmap]
      rw [H2]
      apply @Computation.think_terminates _ _ _
      have := H1 _ h
      rcases seq.destruct S with (_ | ⟨_ | c, S'⟩) <;> simp [parallel.aux1] <;> apply IH <;>
        simp [this]
#align computation.terminates_parallel.aux Computation.TerminatesParallel.aux

theorem terminates_parallel {S : Wseq (Computation α)} {c} (h : c ∈ S) [T : Terminates c] :
    Terminates (parallel S) :=
  by
  suffices
    ∀ (n) (l : List (Computation α)) (S c),
      c ∈ l ∨ some (some c) = Seq.nth S n → Terminates c → Terminates (corec Parallel.aux1 (l, S))
    from
    let ⟨n, h⟩ := h
    this n [] S c (Or.inr h) T
  intro n; induction' n with n IH <;> intro l S c o T
  · cases' o with a a
    · exact terminates_parallel.aux a T
    have H : seq.destruct S = some (some c, _) :=
      by
      unfold seq.destruct Functor.map
      rw [← a]
      simp
    induction' h : parallel.aux2 l with a l' <;> have C : corec parallel.aux1 (l, S) = _
    · apply destruct_eq_ret
      simp [parallel.aux1]
      rw [h]
      simp [rmap]
    · rw [C]
      skip
      infer_instance
    · apply destruct_eq_think
      simp [parallel.aux1]
      rw [h, H]
      simp [rmap]
    · rw [C]
      apply @Computation.think_terminates _ _ _
      apply terminates_parallel.aux _ T
      simp
  · cases' o with a a
    · exact terminates_parallel.aux a T
    induction' h : parallel.aux2 l with a l' <;> have C : corec parallel.aux1 (l, S) = _
    · apply destruct_eq_ret
      simp [parallel.aux1]
      rw [h]
      simp [rmap]
    · rw [C]
      skip
      infer_instance
    · apply destruct_eq_think
      simp [parallel.aux1]
      rw [h]
      simp [rmap]
    · rw [C]
      apply @Computation.think_terminates _ _ _
      have TT : ∀ l', terminates (corec parallel.aux1 (l', S.tail)) :=
        by
        intro
        apply IH _ _ _ (Or.inr _) T
        rw [a]
        cases' S with f al
        rfl
      induction' e : seq.nth S 0 with o
      · have D : seq.destruct S = none := by
          dsimp [seq.destruct]
          rw [e]
          rfl
        rw [D]
        simp [parallel.aux1]
        have TT := TT l'
        rwa [seq.destruct_eq_nil D, seq.tail_nil] at TT
      · have D : seq.destruct S = some (o, S.tail) :=
          by
          dsimp [seq.destruct]
          rw [e]
          rfl
        rw [D]
        cases' o with c <;> simp [parallel.aux1, TT]
#align computation.terminates_parallel Computation.terminates_parallel

theorem exists_of_mem_parallel {S : Wseq (Computation α)} {a} (h : a ∈ parallel S) :
    ∃ c ∈ S, a ∈ c :=
  by
  suffices
    ∀ C,
      a ∈ C →
        ∀ (l : List (Computation α)) (S),
          corec Parallel.aux1 (l, S) = C → ∃ c, (c ∈ l ∨ c ∈ S) ∧ a ∈ c
    from
    let ⟨c, h1, h2⟩ := this _ h [] S rfl
    ⟨c, h1.resolve_left id, h2⟩
  let F : List (Computation α) → Sum α (List (Computation α)) → Prop :=
    by
    intro l a
    cases' a with a l'
    exact ∃ c ∈ l, a ∈ c
    exact ∀ a', (∃ c ∈ l', a' ∈ c) → ∃ c ∈ l, a' ∈ c
  have lem1 : ∀ l : List (Computation α), F l (parallel.aux2 l) :=
    by
    intro l
    induction' l with c l IH <;> simp [parallel.aux2]
    · intro a h
      rcases h with ⟨c, hn, _⟩
      exact False.elim hn
    · simp [parallel.aux2] at IH
      cases' List.foldr parallel.aux2._match_1 (Sum.inr List.nil) l with a ls <;>
        simp [parallel.aux2]
      · rcases IH with ⟨c', cl, ac⟩
        refine' ⟨c', Or.inr cl, ac⟩
      · induction' h : destruct c with a c' <;> simp [rmap]
        · refine' ⟨c, List.mem_cons_self _ _, _⟩
          rw [destruct_eq_ret h]
          apply ret_mem
        · intro a' h
          rcases h with ⟨d, dm, ad⟩
          simp at dm
          cases' dm with e dl
          · rw [e] at ad
            refine' ⟨c, List.mem_cons_self _ _, _⟩
            rw [destruct_eq_think h]
            exact think_mem ad
          · cases' IH a' ⟨d, dl, ad⟩ with d dm
            cases' dm with dm ad
            exact ⟨d, Or.inr dm, ad⟩
  intro C aC
  refine' mem_rec_on aC _ fun C' IH => _ <;> intro l S e <;> have e' := congr_arg destruct e <;>
          have := lem1 l <;>
        simp [parallel.aux1] at e' <;>
      cases' parallel.aux2 l with a' l' <;>
    injection e' with h'
  · rw [h'] at this
    rcases this with ⟨c, cl, ac⟩
    exact ⟨c, Or.inl cl, ac⟩
  · induction' e : seq.destruct S with a <;> rw [e] at h'
    ·
      exact
        let ⟨d, o, ad⟩ := IH _ _ h'
        let ⟨c, cl, ac⟩ := this a ⟨d, o.resolve_right (wseq.not_mem_nil _), ad⟩
        ⟨c, Or.inl cl, ac⟩
    · cases' a with o S'
      cases' o with c <;> simp [parallel.aux1] at h' <;> rcases IH _ _ h' with ⟨d, dl | dS', ad⟩
      ·
        exact
          let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩
          ⟨c, Or.inl cl, ac⟩
      · refine' ⟨d, Or.inr _, ad⟩
        rw [seq.destruct_eq_cons e]
        exact seq.mem_cons_of_mem _ dS'
      · simp at dl
        cases' dl with dc dl
        · rw [dc] at ad
          refine' ⟨c, Or.inr _, ad⟩
          rw [seq.destruct_eq_cons e]
          apply seq.mem_cons
        ·
          exact
            let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩
            ⟨c, Or.inl cl, ac⟩
      · refine' ⟨d, Or.inr _, ad⟩
        rw [seq.destruct_eq_cons e]
        exact seq.mem_cons_of_mem _ dS'
#align computation.exists_of_mem_parallel Computation.exists_of_mem_parallel

theorem map_parallel (f : α → β) (S) : map f (parallel S) = parallel (S.map (map f)) :=
  by
  refine'
    eq_of_bisim
      (fun c1 c2 =>
        ∃ l S,
          c1 = map f (corec parallel.aux1 (l, S)) ∧
            c2 = corec parallel.aux1 (l.map (map f), S.map (map f)))
      _ ⟨[], S, rfl, rfl⟩
  intro c1 c2 h;
  exact
    match c1, c2, h with
    | _, _, ⟨l, S, rfl, rfl⟩ => by
      clear _match
      have : parallel.aux2 (l.map (map f)) = lmap f (rmap (List.map (map f)) (parallel.aux2 l)) :=
        by
        simp [parallel.aux2]
        induction' l with c l IH <;> simp
        rw [IH]
        cases List.foldr parallel.aux2._match_1 (Sum.inr List.nil) l <;> simp [parallel.aux2]
        cases destruct c <;> simp
      simp [parallel.aux1]
      rw [this]
      cases' parallel.aux2 l with a l' <;> simp
      apply S.rec_on _ (fun c S => _) fun S => _ <;> simp <;> simp [parallel.aux1] <;>
        exact ⟨_, _, rfl, rfl⟩
#align computation.map_parallel Computation.map_parallel

theorem parallel_empty (S : Wseq (Computation α)) (h : S.headI ~> none) : parallel S = empty _ :=
  eq_empty_of_not_terminates fun ⟨⟨a, m⟩⟩ =>
    by
    let ⟨c, cs, ac⟩ := exists_of_mem_parallel m
    let ⟨n, nm⟩ := Wseq.exists_nth_of_mem cs
    let ⟨c', h'⟩ := Wseq.head_some_of_nth_some nm
    injection h h'
#align computation.parallel_empty Computation.parallel_empty

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort
def parallelRec {S : Wseq (Computation α)} (C : α → Sort v) (H : ∀ s ∈ S, ∀ a ∈ s, C a) {a}
    (h : a ∈ parallel S) : C a :=
  by
  let T : wseq (Computation (α × Computation α)) := S.map fun c => c.map fun a => (a, c)
  have : S = T.map (map fun c => c.1) :=
    by
    rw [← wseq.map_comp]
    refine' (wseq.map_id _).symm.trans (congr_arg (fun f => wseq.map f S) _)
    funext c
    dsimp [id, Function.comp]
    rw [← map_comp]
    exact (map_id _).symm
  have pe := congr_arg parallel this
  rw [← map_parallel] at pe
  have h' := h
  rw [pe] at h'
  haveI : terminates (parallel T) := (terminates_map_iff _ _).1 ⟨⟨_, h'⟩⟩
  induction' e : get (parallel T) with a' c
  have : a ∈ c ∧ c ∈ S := by
    rcases exists_of_mem_map h' with ⟨d, dT, cd⟩
    rw [get_eq_of_mem _ dT] at e
    cases e
    dsimp at cd
    cases cd
    rcases exists_of_mem_parallel dT with ⟨d', dT', ad'⟩
    rcases wseq.exists_of_mem_map dT' with ⟨c', cs', e'⟩
    rw [← e'] at ad'
    rcases exists_of_mem_map ad' with ⟨a', ac', e'⟩
    injection e' with i1 i2
    constructor
    rwa [i1, i2] at ac'
    rwa [i2] at cs'
  cases' this with ac cs
  apply H _ cs _ ac
#align computation.parallel_rec Computation.parallelRec

theorem parallel_promises {S : Wseq (Computation α)} {a} (H : ∀ s ∈ S, s ~> a) : parallel S ~> a :=
  fun a' ma' =>
  let ⟨c, cs, ac⟩ := exists_of_mem_parallel ma'
  H _ cs ac
#align computation.parallel_promises Computation.parallel_promises

theorem mem_parallel {S : Wseq (Computation α)} {a} (H : ∀ s ∈ S, s ~> a) {c} (cs : c ∈ S)
    (ac : a ∈ c) : a ∈ parallel S := by
  haveI := terminates_of_mem ac <;> haveI := terminates_parallel cs <;>
    exact mem_of_promises _ (parallel_promises H)
#align computation.mem_parallel Computation.mem_parallel

theorem parallel_congr_lem {S T : Wseq (Computation α)} {a} (H : S.LiftRel Equiv T) :
    (∀ s ∈ S, s ~> a) ↔ ∀ t ∈ T, t ~> a :=
  ⟨fun h1 t tT =>
    let ⟨s, sS, se⟩ := Wseq.exists_of_liftRel_right H tT
    (promises_congr se _).1 (h1 _ sS),
    fun h2 s sS =>
    let ⟨t, tT, se⟩ := Wseq.exists_of_liftRel_left H sS
    (promises_congr se _).2 (h2 _ tT)⟩
#align computation.parallel_congr_lem Computation.parallel_congr_lem

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- The parallel operation is only deterministic when all computation paths lead to the same value
theorem parallel_congr_left {S T : Wseq (Computation α)} {a} (h1 : ∀ s ∈ S, s ~> a)
    (H : S.LiftRel Equiv T) : parallel S ~ parallel T :=
  let h2 := (parallel_congr_lem H).1 h1
  fun a' =>
  ⟨fun h => by
    have aa := parallel_promises h1 h <;> rw [← aa] <;> rw [← aa] at h <;>
      exact
        let ⟨s, sS, as⟩ := exists_of_mem_parallel h
        let ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_left H sS
        let aT := (st _).1 as
        mem_parallel h2 tT aT,
    fun h => by
    have aa := parallel_promises h2 h <;> rw [← aa] <;> rw [← aa] at h <;>
      exact
        let ⟨s, sS, as⟩ := exists_of_mem_parallel h
        let ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_right H sS
        let aT := (st _).2 as
        mem_parallel h1 tT aT⟩
#align computation.parallel_congr_left Computation.parallel_congr_left

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem parallel_congr_right {S T : Wseq (Computation α)} {a} (h2 : ∀ t ∈ T, t ~> a)
    (H : S.LiftRel Equiv T) : parallel S ~ parallel T :=
  parallel_congr_left ((parallel_congr_lem H).2 h2) H
#align computation.parallel_congr_right Computation.parallel_congr_right

end Computation


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

Monotone version of 1-point elimination for ∃ (and ∀).

  `∃x, t[x, R x a] ~> t[a, rfl]`

with the (reflexive) relation `R`, and `t` is monotone in `R`:
  `∀x y, R x y → t x → t y`.

Then
  (∃x, R x a ∧ p x) ↔ p a
then
  assume h : p a, ⟨a, h, R.refl a⟩
and
  assume ⟨x, hx, hxa⟩, mono x a hxa hx

Or with the following dependent monotonicity:
  `∀x y (h : R x y), t x h → t y R.refl`.

Then
  (∃x, ∃h:R x a, p x h) ↔ p a R.refl
then
  assume h : p a R.refl, ⟨a, h, R.refl a⟩
and
  assume ⟨x, hx, hxa⟩, mono x a hxa hx

-/
import simp_loop.conv

inductive bintree (α : Type*)
| leaf (a : α) : bintree
| node (l r : bintree) : bintree

def list.dedup {α : Type*} [decidable_eq α] : list α → list α
| []        := []
| (x :: xs) := (if x ∈ xs then xs.dedup else x :: xs.dedup)

namespace bintree
variables {α : Type*} {β : Type*}

def pos := list bool

def left : bintree α → bintree α
| (leaf a)   := leaf a
| (node l r) := l

def right : bintree α → bintree α
| (leaf a)   := leaf a
| (node l r) := r

def at_pos : pos → bintree α → bintree α
| []        t := t
| (ff :: p) t := at_pos p (left t)
| (tt :: p) t := at_pos p (right t)

def map (f : α → β) : bintree α → bintree β
| (leaf a) := leaf (f a)
| (node l r) := node (map l) (map r)

def mmap {m : Type* → Type*} [monad m] (f : α → m β) : bintree α → m (bintree β)
| (leaf a)   := leaf <$> f a
| (node l r) := node <$> mmap l <*> mmap r

end bintree

def monotone {α : Sort*} (r : α → α → Prop) (p : α → Prop) : Prop :=
∀x y, r x y → p x → p y

lemma monotone_eq {α : Type*} (p : α → Prop) : monotone (=) p :=
assume x y h, h ▸ id

-- do we/want need a dependent version?
lemma exists_elim_rel {α : Sort*} {r : α → α → Prop} {p : α → Prop} {a : α} [is_refl α r]
  (h : monotone r p) :
  (∃x, r x a ∧ p x) ↔ p a :=
⟨assume ⟨x, hxa, hx⟩, h x a hxa hx, assume ha, ⟨a, is_refl.refl r a, ha⟩⟩

lemma ex_extend {α : Type*} {p : α → Prop} : (∃a, p a) ↔ (∃a, p a ∧ true) :=
⟨assume ⟨a, ha⟩, ⟨a, ha, ⟨⟩⟩, assume ⟨a, ha, ⟨⟩⟩, ⟨a, ha⟩⟩

lemma l_eq {p E : Prop} : (p ∧ E) ↔ (E ∧ p) :=
and_comm _ _
lemma l_ex {p E : Prop} {r : E → Prop} : (p ∧ (∃h:E, r h)) ↔ (∃h:E, p ∧ r h) :=
⟨λ⟨h, e, r⟩, ⟨e, h, r⟩, λ⟨e, h, r⟩, ⟨h, e, r⟩⟩
lemma l_cn {p q E : Prop} : (p ∧ (E ∧ q)) ↔ (E ∧ (p ∧ q)) :=
⟨λ⟨h, e, r⟩, ⟨e, h, r⟩, λ⟨e, h, r⟩, ⟨h, e, r⟩⟩
lemma r_eq {p E : Prop} : (E ∧ p) ↔ (E ∧ p) :=
iff.refl _
lemma r_ex {p E : Prop} {r : E → Prop} : ((∃h:E, r h) ∧ p) ↔ (∃h:E, r h ∧ p) :=
⟨λ⟨⟨e, r⟩, h⟩, ⟨e, r, h⟩, λ⟨e, r, h⟩, ⟨⟨e, r⟩, h⟩⟩
lemma r_cn {p q E : Prop} : ((E ∧ q) ∧ p) ↔ (E ∧ (q ∧ p)) :=
⟨λ⟨⟨e, r⟩, h⟩, ⟨e, r, h⟩, λ⟨e, r, h⟩, ⟨⟨e, r⟩, h⟩⟩
lemma e_eq_Prop {p E : Prop} : (∃a:p, E) ↔ (E ∧ p) :=
⟨λ⟨a, h⟩, ⟨h, a⟩, λ⟨h, a⟩, ⟨a, h⟩⟩
lemma e_eq {α : Sort*} {E : Prop} : (∃a:α, E) ↔ (E ∧ ∃a:α, true) :=
⟨λ⟨a, h⟩, ⟨h, ⟨a, ⟨⟩⟩⟩, λ⟨h, ⟨a, _⟩⟩, ⟨a, h⟩⟩
lemma e_ex {α : Sort*} {E : Prop} {s : E → α → Prop} : (∃a:α, ∃h:E, s h a) ↔ (∃h:E, ∃a:α, s h a) :=
⟨λ⟨a, h, t⟩, ⟨h, a, t⟩, λ⟨a, h, t⟩, ⟨h, a, t⟩⟩
lemma e_cn {α : Sort*} {E : Prop} {t : α → Prop} : (∃a:α, E ∧ t a) ↔ (E ∧ (∃a:α, t a)) :=
⟨λ⟨a, e, t⟩, ⟨e, ⟨a, t⟩⟩, λ⟨e, ⟨a, t⟩⟩, ⟨a, e, t⟩⟩

lemma l_congr {p q r : Prop} (h : q ↔ r) : p ∧ q ↔ p ∧ r :=
and_congr (iff.refl p) h
lemma r_congr {p q r : Prop} (h : q ↔ r) : q ∧ p ↔ r ∧ p :=
and_congr h (iff.refl p)
lemma ex_congr {α : Sort*} {p q : α → Prop} (h : ∀a, p a ↔ q a) : (∃a, p a) ↔ (∃a, q a) :=
exists_congr h

lemma comm_l {α : Sort*} {p : Prop} {q : α → Prop} : p ∧ (∃a, q a) ↔ ∃a, p ∧ q a :=
⟨λ⟨a, hq, hp⟩, ⟨hq, ⟨a, hp⟩⟩, λ ⟨hq, ⟨a, hp⟩⟩, ⟨a, hq, hp⟩⟩
lemma comm_r {α : Sort*} {p : Prop} {q : α → Prop} : (∃a, q a) ∧ p ↔ ∃a, q a ∧ p :=
⟨λ ⟨⟨a, hp⟩, hq⟩, ⟨a, hp, hq⟩, λ⟨a, hp, hq⟩, ⟨⟨a, hp⟩, hq⟩⟩
lemma comm_ex {α : Sort*} {β : Sort*} {p : α → β → Prop} : (∃a b, p a b) ↔ (∃b a, p a b) :=
⟨λ⟨a, ⟨b, h⟩⟩, ⟨b, ⟨a, h⟩⟩, λ⟨a, ⟨b, h⟩⟩, ⟨b, ⟨a, h⟩⟩⟩

namespace simp_loop
open conv_t tactic expr

meta inductive info
| binder (v : expr) (dependent : bool) | operator (side : bool)

namespace info
open format
meta instance : has_to_format info :=
⟨λi, match i with
| info.binder v d := to_fmt "binder " ++ to_fmt v ++ " " ++ to_fmt d
| info.operator s := to_fmt "operator " ++ to_fmt s
end⟩
end info

meta inductive norm_form
| eq | ex | cn

namespace norm_form
open format
meta instance : has_to_format norm_form :=
⟨λi, match i with
| norm_form.eq := to_fmt "eq"
| norm_form.ex := to_fmt "ex"
| norm_form.cn := to_fmt "cn"
end⟩
end norm_form

meta def congr_ex {α} (c : conv α) : conv α := congr_binder ``ex_congr (λ_, c)

meta def congr {α} (c : conv α) : info → conv α
| (info.binder _ _) := congr_ex c
| (info.operator tt) := congr_simple ``r_congr c
| (info.operator ff) := congr_simple ``l_congr c

meta def apply_norm (n_eq n_ex n_cn : list name) : norm_form → conv norm_form
| norm_form.eq := do n_eq.mfirst apply_const, return norm_form.cn
| norm_form.ex := do n_ex.mfirst apply_const, return norm_form.ex
| norm_form.cn := do n_cn.mfirst apply_const, return norm_form.cn

meta def analyse (chk : expr → list expr → expr → bool)
  (v : expr) (deps : list expr) : expr → tactic (option $ list $ info × expr)
| `(@Exists %%α %%p) := if chk v deps α then
    return none
  else do
    (lam pp_n bi domain body) ← return p | return (some []),
    x ← mk_local' pp_n bi domain,
    return [(info.binder x (deps.any $ λv, v.occurs α), body.instantiate_var x)]
| `(%%p ∧ %%q) := return [(info.operator tt, p), (info.operator ff, q)]
| t := return $ if chk v deps t then none else some []

meta def find (chk : expr → list expr → expr → bool)
  (v : expr) : list expr → expr → tactic (list $ list info) | deps e := do
some is ← analyse chk v deps e | return [[]],
iss ← is.mmap (λ⟨i, t⟩, do
  deps ← return $ match i with (info.binder v tt) := v :: deps | _ := deps end,
  iss ← find deps t,
  return $ iss.map $ λis, i :: is),
return iss.join

section reorder

private meta def reorder_dependent : list info → conv norm_form
| [] := (do -- trace "reorder_equality []", trace_lhs,
  `(_ = _) ← lhs, return norm_form.eq) <|> return norm_form.ex
| (i::xs)  := do
  n ← congr (reorder_dependent xs) i,
  match i with
  | info.binder _ _  := apply_norm [``e_eq_Prop, ``e_eq] [``e_ex] [``e_cn] n
  | info.operator tt := apply_norm [``r_eq] [``r_ex] [``r_cn] n
  | info.operator ff := apply_norm [``l_eq] [``l_ex] [``l_cn] n
  end

private meta def reorder_non_dependent : list info → conv (option (list info))
| []      := return none
| (i::is) := (do info.binder _ ff ← return i, return is) <|> (do
  some is' ← congr (reorder_non_dependent is) i | return none,
  r ← return $ match i with
  | info.binder _ _  := ``comm_ex
  | info.operator tt := ``comm_r
  | info.operator ff := ``comm_l
  end,
  apply_const r,
  return (i :: is'))

meta def reorder {α} (elim : norm_form → conv α) : list info → conv α | l := do
-- trace (to_fmt "reorder_and_elim " ++ to_fmt l),
some l' ← congr_ex (reorder_non_dependent l) |
  (congr_ex (reorder_dependent l) >>= elim),
apply_const ``comm_ex,
congr_ex (reorder l')

end reorder

section term_focus

/-

Move a term on one side of a relation using Galois connections:

Symmetric rules:
  f x R y ↔ x Q g z

    ⟹ f x R t ↔ x Q t'
    ⟹ t Q g x ↔ t' R x

Injectivity rules:
  f x R g y ↔ x Q y

    ⟹ f x R t ↔ x Q t'
    ⟹ t R g x ↔ t' Q x

Splitting rules:
  f x R t ↔ (C₁ ∧ x Q₁ t₁) ∨ (C₂ ∧ x Q₂ t₂)

Setup:

* allow symmetric relations
* apply the rules symmetrically
* should we add dischargers for conditional rules, ala:
    0 < R → x / R ≤ S ↔ x ≤ S * R
  or:
    x / R ≤ S ↔ (0 < R ∧ x ≤ S * R) ∨ (R < 0 ∧ S * R ≤ x) ∨ (R = 0 ∧ 0 ≤ S)
    This one doesn't work for monotone elimination as we have x ≤ S * R and S * R ≤ x case.
* conditionals:
    ∀x n i : ℕ, x + n = i ↔ (n ≤ i ∧ x = i - n)
    ∀x n i : ℕ, x - n = i ↔ ((i = 0 ∧ x ≤ n) ∨ x = i + n)
    ∀x n i : ℕ, n - x = i ↔ ((i = 0 ∧ n ≤ x) ∨ (i ≤ n ∧ x = i - n))

-/

meta def connection_iff : user_attribute :=
{ name := `connection_iff,
  descr := "Connection rules of the form f x R y ↔ x Q g z, used for term focusing" }

section analyse

meta def conjs : expr → tactic (list expr)
| `(%%a ∧ %%b) := do
  as ← conjs a,
  bs ← conjs b,
  return (as ++ bs)
| e := return [e]

meta def disjs_of_conjs : expr → tactic (list $ list expr)
| `(%%a ∨ %%b) := do
  as ← disjs_of_conjs a,
  bs ← disjs_of_conjs b,
  return (as ++ bs)
| e := do
  d ← conjs e,
  return [d]

-- better `parse_rel`: this doesn't work with heq!
-- idea: use relation manager
meta def parse_rel : expr → tactic (expr × expr × expr)
| (expr.app (expr.app f a) b) := return (f, a, b)
| _ := fail "term is not a relation application"

def peep {α} : list α → list (list α × α × list α)
| []        := []
| (a :: xs) := ([], a, xs) :: (peep xs).map (λ⟨p, a', s⟩, (a::p, a', s))

private meta def analyse_connection_aux (ls : list level) (vs : list expr) (lhs rhs : expr) :
  tactic $ list pattern := do
disjs ← disjs_of_conjs rhs,
candidates ← disjs.mmap (λconjs, do
  candidates ← (peep conjs).mmap (λxs, (do
    (ps, e, ss) ← return xs,
    (rel, l, r) ← parse_rel e,
    return $
      (if l ∈ vs ∧ (r :: rel :: ps ++ ss).all (λe, ¬ l.occurs e) then [l] else []) ++
      (if r ∈ vs ∧ (l :: rel :: ps ++ ss).all (λe, ¬ r.occurs e) then [r] else []))
      <|> return []),
  return candidates.join),
let candidates := vs.filter $ λv, candidates.all $ λcs, v ∈ cs,

(rel, l, r) ← parse_rel lhs,
let candidates := candidates.filter $ λc,
  ¬ c.occurs rel ∧ ((c.occurs l ∧ ¬ c.occurs r) ∨ c.occurs r ∧ ¬ c.occurs l),
let candidates := candidates.dedup,
let vs' := vs.filter (λv, v.occurs lhs),
candidates.mmap (λc, mk_pattern ls vs' lhs [] [c])

/-- `analyse_connection ls r` a list of symm-flag and pattern. The pattern matches if the rule is
applicable. In this case `tactic.match_pattern` returns one expression where the focused variable
should occur. The symm-flag indicates if the iff-rule should be applied in its symmetric variant. -/
meta def analyse_connection (n : name) : tactic $ list $ bool × pattern := do
e ← get_env,
d ← e.get n,
let ls := d.univ_params.map level.param,
(vs, `(%%lhs ↔ %%rhs)) ← mk_local_pis d.type,
l ← analyse_connection_aux ls vs lhs rhs,
r ← analyse_connection_aux ls vs rhs lhs,
return (l.map (λp, (ff, p)) ++ r.map (λp, (tt, p)))

meta def ors (c : conv unit) : conv unit := do
`(_ ∨ _) ← lhs | c,
congr_core (congr_core skip ors) ors,
skip

meta def ands (c : conv unit) : conv unit := do
`(_ ∧ _) ← lhs | c,
congr_core (congr_core skip ands) ands,
skip

meta def local_eq (v₀ v₁ : expr) : bool :=
v₀.is_local_constant ∧ v₁.is_local_constant ∧ v₀.local_uniq_name = v₁.local_uniq_name

meta def term_focus (l : list (name × bool × pattern)) (v : expr) : conv unit :=
l.mfirst $ assume ⟨n, symm, pat⟩, do
  ([], [t]) ← match_pattern pat,
  guard $ v.occurs t,
  (if symm then apply_const n else fail "symmetric apply not supported yet"),
  ors (ands $ (do
    l ← lhs,
    (_, l, r) ← lift_tactic $ parse_rel l,
    guard ((v.occurs l ∧ ¬ local_eq l v) ∨ (v.occurs r ∧ ¬ local_eq r v)),
    term_focus) <|> skip)

end analyse

/-

Lattices

  x ≤ y ⊓ z ↔ x ≤ y ∧ x ≤ z

  y ⊓ z ≤ x ↔ y \ z ≤ x (Heyting algebra)

  a ⊔ b ≤ c ↔ a ≤ c ∧ b ≤ c

Case: Focus on a
  (∃ x, x ⊔ b ≤ c ∧ p x) ↔ (∃x, x ≤ c ∧ b ≤ c ∧ p x)

-/

end term_focus

#exit

section equality_elim

meta def check_eq (x : expr) (deps : list expr) : expr → bool
| `(%%l = %%r) := (l = x ∧ deps.all (λx, ¬ x.occurs r)) ∨ (r = x ∧ deps.all (λx, ¬ x.occurs l))
| _ := ff

meta def elim_equality (n : norm_form) : conv unit := do
-- trace (to_fmt "elim_equality [reordered] " ++ to_fmt n), trace_lhs,
apply_norm [``elim_eq_left, ``elim_eq_right] [``elim_ex_left, ``elim_ex_right] [``elim_cn_left, ``elim_cn_right] n,
skip

meta def run : conv unit := do
pss ← congr_binder ``ex_congr (λv, do t ← lhs, find check_eq v [v] t),
pss.mfirst (reorder elim_equality)

end equality_elim

end simp_loop


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Std.ShareCommon
import Lean.Parser.Command
import Lean.Util.CollectLevelParams
import Lean.Util.FoldConsts
import Lean.Meta.CollectFVars
import Lean.Elab.Command
import Lean.Elab.SyntheticMVars
import Lean.Elab.Binders
import Lean.Elab.DeclUtil
namespace Lean.Elab

inductive DefKind where
  | «def» | «theorem» | «example» | «opaque» | «abbrev»
  deriving Inhabited, BEq

def DefKind.isTheorem : DefKind → Bool
  | «theorem» => true
  | _         => false

def DefKind.isDefOrAbbrevOrOpaque : DefKind → Bool
  | «def»    => true
  | «opaque» => true
  | «abbrev» => true
  | _        => false

def DefKind.isExample : DefKind → Bool
  | «example» => true
  | _         => false

structure DefView where
  kind          : DefKind
  ref           : Syntax
  modifiers     : Modifiers
  declId        : Syntax
  binders       : Syntax
  type?         : Option Syntax
  value         : Syntax
  deriving?     : Option (Array Syntax) := none
  deriving Inhabited

namespace Command

open Meta

def mkDefViewOfAbbrev (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "abbrev " >> declId >> optDeclSig >> declVal
  let (binders, type) := expandOptDeclSig stx[2]
  let modifiers       := modifiers.addAttribute { name := `inline }
  let modifiers       := modifiers.addAttribute { name := `reducible }
  { ref := stx, kind := DefKind.abbrev, modifiers,
    declId := stx[1], binders, type? := type, value := stx[3] }

def mkDefViewOfDef (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "def " >> declId >> optDeclSig >> declVal >> optDefDeriving
  let (binders, type) := expandOptDeclSig stx[2]
  let deriving? := if stx[4].isNone then none else some stx[4][1].getSepArgs
  { ref := stx, kind := DefKind.def, modifiers,
    declId := stx[1], binders, type? := type, value := stx[3], deriving? }

def mkDefViewOfTheorem (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "theorem " >> declId >> declSig >> declVal
  let (binders, type) := expandDeclSig stx[2]
  { ref := stx, kind := DefKind.theorem, modifiers,
    declId := stx[1], binders, type? := some type, value := stx[3] }

namespace MkInstanceName

-- Table for `mkInstanceName`
private def kindReplacements : NameMap String :=
  Std.RBMap.ofList [
    (``Parser.Term.depArrow, "DepArrow"),
    (``Parser.Term.«forall», "Forall"),
    (``Parser.Term.arrow, "Arrow"),
    (``Parser.Term.prop,  "Prop"),
    (``Parser.Term.sort,  "Sort"),
    (``Parser.Term.type,  "Type")
  ]

abbrev M := StateRefT String CommandElabM

def isFirst : M Bool :=
  return (← get) == ""

def append (str : String) : M Unit :=
  modify fun s => s ++ str

partial def collect (stx : Syntax) : M Unit := do
  match stx with
  | Syntax.node k args =>
    unless (← isFirst) do
      match kindReplacements.find? k with
      | some r => append r
      | none   => pure ()
    for arg in args do
      collect arg
  | Syntax.ident (preresolved := preresolved) .. =>
    unless preresolved.isEmpty && (← resolveGlobalName stx.getId).isEmpty do
      match stx.getId.eraseMacroScopes with
      | Name.str _ str _ =>
          if str[0].isLower then
            append str.capitalize
          else
            append str
      | _ => pure ()
  | _ => pure ()

def mkFreshInstanceName : CommandElabM Name := do
  let s ← get
  let idx := s.nextInstIdx
  modify fun s => { s with nextInstIdx := s.nextInstIdx + 1 }
  return Lean.Elab.mkFreshInstanceName s.env idx

partial def main (type : Syntax) : CommandElabM Name := do
  /- We use `expandMacros` to expand notation such as `x < y` into `LT.lt x y` -/
  let type ← liftMacroM <| expandMacros type
  let (_, str) ← collect type |>.run ""
  if str.isEmpty then
    mkFreshInstanceName
  else
    liftMacroM <| mkUnusedBaseName <| Name.mkSimple ("inst" ++ str)

end MkInstanceName

def mkDefViewOfConstant (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView := do
  -- leading_parser "constant " >> declId >> declSig >> optional declValSimple
  let (binders, type) := expandDeclSig stx[2]
  let val ← match stx[3].getOptional? with
    | some val => pure val
    | none     =>
      let val ← `(arbitrary)
      pure $ Syntax.node ``Parser.Command.declValSimple #[ mkAtomFrom stx ":=", val ]
  return {
    ref := stx, kind := DefKind.opaque, modifiers := modifiers,
    declId := stx[1], binders := binders, type? := some type, value := val
  }

def mkDefViewOfInstance (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView := do
  -- leading_parser Term.attrKind >> "instance " >> optNamedPrio >> optional declId >> declSig >> declVal
  let attrKind        ← liftMacroM <| toAttributeKind stx[0]
  let prio            ← liftMacroM <| expandOptNamedPrio stx[2]
  let attrStx         ← `(attr| instance $(quote prio):numLit)
  let (binders, type) := expandDeclSig stx[4]
  let modifiers       := modifiers.addAttribute { kind := attrKind, name := `instance, stx := attrStx }
  let declId ← match stx[3].getOptional? with
    | some declId => pure declId
    | none        =>
      let id ← MkInstanceName.main type
      pure <| Syntax.node ``Parser.Command.declId #[mkIdentFrom stx id, mkNullNode]
  return {
    ref := stx, kind := DefKind.def, modifiers := modifiers,
    declId := declId, binders := binders, type? := type, value := stx[5]
  }

def mkDefViewOfExample (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "example " >> declSig >> declVal
  let (binders, type) := expandDeclSig stx[1]
  let id              := mkIdentFrom stx `_example
  let declId          := Syntax.node ``Parser.Command.declId #[id, mkNullNode]
  { ref := stx, kind := DefKind.example, modifiers := modifiers,
    declId := declId, binders := binders, type? := some type, value := stx[2] }

def isDefLike (stx : Syntax) : Bool :=
  let declKind := stx.getKind
  declKind == ``Parser.Command.«abbrev» ||
  declKind == ``Parser.Command.«def» ||
  declKind == ``Parser.Command.«theorem» ||
  declKind == ``Parser.Command.«constant» ||
  declKind == ``Parser.Command.«instance» ||
  declKind == ``Parser.Command.«example»

def mkDefView (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView :=
  let declKind := stx.getKind
  if declKind == ``Parser.Command.«abbrev» then
    pure $ mkDefViewOfAbbrev modifiers stx
  else if declKind == ``Parser.Command.«def» then
    pure $ mkDefViewOfDef modifiers stx
  else if declKind == ``Parser.Command.«theorem» then
    pure $ mkDefViewOfTheorem modifiers stx
  else if declKind == ``Parser.Command.«constant» then
    mkDefViewOfConstant modifiers stx
  else if declKind == ``Parser.Command.«instance» then
    mkDefViewOfInstance modifiers stx
  else if declKind == ``Parser.Command.«example» then
    pure $ mkDefViewOfExample modifiers stx
  else
    throwError "unexpected kind of definition"

builtin_initialize registerTraceClass `Elab.definition

end Command
end Lean.Elab