/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.traversable.derive
import control.traversable.lemmas
import data.dlist
import tactic.monotonicity.basic

variables {a b c p : Prop}

namespace tactic.interactive

open lean lean.parser  interactive
open interactive.types
open tactic

local postfix `?`:9001 := optional
local postfix *:9001 := many

meta inductive mono_function (elab : bool := tt)
 | non_assoc : expr elab → list (expr elab) → list (expr elab) → mono_function
 | assoc : expr elab → option (expr elab) → option (expr elab) → mono_function
 | assoc_comm : expr elab → expr elab → mono_function

meta instance : decidable_eq mono_function :=
by mk_dec_eq_instance

meta def mono_function.to_tactic_format : mono_function → tactic format
 | (mono_function.non_assoc fn xs ys) := do
  fn' ← pp fn,
  xs' ← mmap pp xs,
  ys' ← mmap pp ys,
  return format!"{fn'} {xs'} _ {ys'}"
 | (mono_function.assoc fn xs ys) := do
  fn' ← pp fn,
  xs' ← pp xs,
  ys' ← pp ys,
  return format!"{fn'} {xs'} _ {ys'}"
 | (mono_function.assoc_comm fn xs) := do
  fn' ← pp fn,
  xs' ← pp xs,
  return format!"{fn'} _ {xs'}"

meta instance has_to_tactic_format_mono_function : has_to_tactic_format mono_function :=
{ to_tactic_format := mono_function.to_tactic_format }

@[derive traversable]
meta structure ac_mono_ctx' (rel : Type) :=
  (to_rel : rel)
  (function : mono_function)
  (left right rel_def : expr)

@[reducible]
meta def ac_mono_ctx := ac_mono_ctx' (option (expr → expr → expr))
@[reducible]
meta def ac_mono_ctx_ne := ac_mono_ctx' (expr → expr → expr)

meta def ac_mono_ctx.to_tactic_format (ctx : ac_mono_ctx) : tactic format :=
do fn  ← pp ctx.function,
   l   ← pp ctx.left,
   r   ← pp ctx.right,
   rel ← pp ctx.rel_def,
   return format!"{{ function := {fn}\n, left  := {l}\n, right := {r}\n, rel_def := {rel} }}"

meta instance has_to_tactic_format_mono_ctx : has_to_tactic_format ac_mono_ctx :=
{ to_tactic_format := ac_mono_ctx.to_tactic_format }

meta def as_goal (e : expr) (tac : tactic unit) : tactic unit :=
do gs ← get_goals,
   set_goals [e],
   tac,
   set_goals gs

open list (hiding map) functor dlist

section config

parameter opt : mono_cfg
parameter asms : list expr

meta def unify_with_instance (e : expr) : tactic unit :=
as_goal e $
apply_instance
<|>
apply_opt_param
<|>
apply_auto_param
<|>
tactic.solve_by_elim { lemmas := some asms }
<|>
reflexivity
<|>
applyc ``id
<|>
return ()

private meta def match_rule_head  (p : expr)
: list expr → expr → expr → tactic expr
 | vs e t :=
(unify t p >> mmap' unify_with_instance vs >> instantiate_mvars e)
<|>
do (expr.pi _ _ d b) ← return t | failed,
   v ← mk_meta_var d,
   match_rule_head (v::vs) (expr.app e v) (b.instantiate_var v)

meta def pi_head : expr → tactic expr
| (expr.pi n _ t b) :=
do v ← mk_meta_var t,
   pi_head (b.instantiate_var v)
| e := return e

meta def delete_expr (e : expr)
: list expr → tactic (option (list expr))
 | [] := return none
 | (x :: xs) :=
(compare opt e x >> return (some xs))
<|>
(map (cons x) <$> delete_expr xs)

meta def match_ac'
: list expr → list expr → tactic (list expr × list expr × list expr)
 | es (x :: xs) := do
    es' ← delete_expr x es,
    match es' with
     | (some es') := do
       (c,l,r) ← match_ac' es' xs, return (x::c,l,r)
     | none := do
       (c,l,r) ← match_ac' es xs, return (c,l,x::r)
    end
 | es [] := do
return ([],es,[])

meta def match_ac (l : list expr) (r : list expr)
: tactic (list expr × list expr × list expr) :=
do (s',l',r') ← match_ac' l r,
   s' ← mmap instantiate_mvars s',
   l' ← mmap instantiate_mvars l',
   r' ← mmap instantiate_mvars r',
   return (s',l',r')

meta def match_prefix
: list expr → list expr → tactic (list expr × list expr × list expr)
| (x :: xs) (y :: ys) :=
  (do compare opt x y,
      prod.map ((::) x) id <$> match_prefix xs ys)
<|> return ([],x :: xs,y :: ys)
| xs ys := return ([],xs,ys)

/--
`(prefix,left,right,suffix) ← match_assoc unif l r` finds the
longest prefix and suffix common to `l` and `r` and
returns them along with the differences  -/
meta def match_assoc (l : list expr) (r : list expr)
: tactic (list expr × list expr × list expr × list expr) :=
do (pre,l₁,r₁) ← match_prefix l r,
   (suf,l₂,r₂) ← match_prefix (reverse l₁) (reverse r₁),
   return (pre,reverse l₂,reverse r₂,reverse suf)

meta def check_ac : expr → tactic (bool × bool × option (expr × expr × expr) × expr)
 | (expr.app (expr.app f x) y) :=
   do t ← infer_type x,
      a ← try_core $ to_expr ``(is_associative %%t %%f) >>= mk_instance,
      c ← try_core $ to_expr ``(is_commutative %%t %%f) >>= mk_instance,
      i ← try_core (do
          v ← mk_meta_var t,
          l_inst_p ← to_expr ``(is_left_id %%t %%f %%v),
          r_inst_p ← to_expr ``(is_right_id %%t %%f %%v),
          l_v ← mk_meta_var l_inst_p,
          r_v ← mk_meta_var r_inst_p ,
          l_id ← mk_mapp `is_left_id.left_id [some t,f,v,some l_v],
          mk_instance l_inst_p >>= unify l_v,
          r_id ← mk_mapp `is_right_id.right_id [none,f,v,some r_v],
          mk_instance r_inst_p >>= unify r_v,
          v' ← instantiate_mvars v,
          return (l_id,r_id,v')),
      return (a.is_some,c.is_some,i,f)
 | _ := return (ff,ff,none,expr.var 1)

meta def parse_assoc_chain' (f : expr) : expr → tactic (dlist expr)
 | e :=
 (do (expr.app (expr.app f' x) y) ← return e,
     is_def_eq f f',
     (++) <$> parse_assoc_chain' x <*> parse_assoc_chain' y)
<|> return (singleton e)

meta def parse_assoc_chain (f : expr) : expr → tactic (list expr) :=
map dlist.to_list ∘ parse_assoc_chain' f

meta def fold_assoc (op : expr) :
  option (expr × expr × expr) → list expr → option (expr × list expr)
| _ (x::xs) := some (foldl (expr.app ∘ expr.app op) x xs, [])
| none []   := none
| (some (l_id,r_id,x₀)) [] := some (x₀,[l_id,r_id])

meta def fold_assoc1 (op : expr) : list expr → option expr
| (x::xs) := some $ foldl (expr.app ∘ expr.app op) x xs
| []   := none

meta def same_function_aux
: list expr → list expr → expr → expr → tactic (expr × list expr × list expr)
 | xs₀ xs₁ (expr.app f₀ a₀) (expr.app f₁ a₁) :=
   same_function_aux (a₀ :: xs₀) (a₁ :: xs₁) f₀ f₁
 | xs₀ xs₁ e₀ e₁ := is_def_eq e₀ e₁ >> return (e₀,xs₀,xs₁)

meta def same_function : expr → expr → tactic (expr × list expr × list expr) :=
same_function_aux [] []

meta def parse_ac_mono_function (l r : expr)
: tactic (expr × expr × list expr × mono_function) :=
do (full_f,ls,rs) ← same_function l r,
   (a,c,i,f) ← check_ac l,
   if a
   then if c
   then do
     (s,ls,rs) ← monad.join (match_ac
                   <$> parse_assoc_chain f l
                   <*> parse_assoc_chain f r),
     (l',l_id) ← fold_assoc f i ls,
     (r',r_id) ← fold_assoc f i rs,
     s' ← fold_assoc1 f s,
     return (l',r',l_id ++ r_id,mono_function.assoc_comm f s')
   else do -- a ∧ ¬ c
     (pre,ls,rs,suff) ← monad.join (match_assoc
                   <$> parse_assoc_chain f l
                   <*> parse_assoc_chain f r),
     (l',l_id) ← fold_assoc f i ls,
     (r',r_id) ← fold_assoc f i rs,
     let pre'  := fold_assoc1 f pre,
     let suff' := fold_assoc1 f suff,
     return (l',r',l_id ++ r_id,mono_function.assoc f pre' suff')
   else do -- ¬ a
     (xs₀,x₀,x₁,xs₁) ← find_one_difference opt ls rs,
     return (x₀,x₁,[],mono_function.non_assoc full_f xs₀ xs₁)

meta def parse_ac_mono_function' (l r : pexpr) :=
do l' ← to_expr l,
   r' ← to_expr r,
   parse_ac_mono_function l' r'

meta def ac_monotonicity_goal : expr → tactic (expr × expr × list expr × ac_mono_ctx)
 | `(%%e₀ → %%e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     t₀ ← infer_type e₀,
     t₁ ← infer_type e₁,
     rel_def ← to_expr ``(λ x₀ x₁, (x₀ : %%t₀) → (x₁ : %%t₁)),
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := some $ expr.pi `x binder_info.default
            , rel_def := rel_def })
 | `(%%e₀ = %%e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     t₀ ← infer_type e₀,
     t₁ ← infer_type e₁,
     rel_def ← to_expr ``(λ x₀ x₁, (x₀ : %%t₀) = (x₁ : %%t₁)),
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := none
            , rel_def := rel_def })
 | (expr.app (expr.app rel e₀) e₁) :=
  do (l,r,id_rs,f) ← parse_ac_mono_function e₀ e₁,
     return (e₀, e₁, id_rs,
            { function := f
            , left := l, right := r
            , to_rel := expr.app ∘ expr.app rel
            , rel_def := rel })
 | _ := fail "invalid monotonicity goal"

meta def bin_op_left (f : expr)  : option expr → expr → expr
| none e := e
| (some e₀) e₁ := f.mk_app [e₀,e₁]

meta def bin_op (f a b : expr) : expr :=
f.mk_app [a,b]

meta def bin_op_right (f : expr) : expr → option expr → expr
| e none := e
| e₀ (some e₁) := f.mk_app [e₀,e₁]

meta def mk_fun_app : mono_function → expr → expr
 | (mono_function.non_assoc f x y) z := f.mk_app (x ++ z :: y)
 | (mono_function.assoc f x y) z := bin_op_left f x (bin_op_right f z y)
 | (mono_function.assoc_comm f x) z := f.mk_app [z,x]

meta inductive mono_law
   /- `assoc (l₀,r₀) (r₁,l₁)` gives first how to find rules to prove
      x+(y₀+z) R x+(y₁+z);
      if that fails, helps prove (x+y₀)+z R (x+y₁)+z -/
 | assoc : expr × expr → expr × expr → mono_law
   /- `congr r` gives the rule to prove `x = y → f x = f y` -/
 | congr : expr → mono_law
 | other : expr → mono_law

meta def mono_law.to_tactic_format : mono_law → tactic format
 | (mono_law.other e) := do e ← pp e, return format!"other {e}"
 | (mono_law.congr r) := do e ← pp r, return format!"congr {e}"
 | (mono_law.assoc (x₀,x₁) (y₀,y₁)) :=
do x₀ ← pp x₀,
   x₁ ← pp x₁,
   y₀ ← pp y₀,
   y₁ ← pp y₁,
   return format!"assoc {x₀}; {x₁} | {y₀}; {y₁}"

meta instance has_to_tactic_format_mono_law : has_to_tactic_format mono_law :=
{ to_tactic_format := mono_law.to_tactic_format }

meta def mk_rel (ctx : ac_mono_ctx_ne) (f : expr → expr) : expr :=
ctx.to_rel (f ctx.left) (f ctx.right)

meta def mk_congr_args (fn : expr) (xs₀ xs₁ : list expr) (l r : expr) : tactic expr :=
do p ← mk_app `eq [fn.mk_app $ xs₀ ++ l :: xs₁,fn.mk_app $ xs₀ ++ r :: xs₁],
   prod.snd <$> solve_aux p
     (do iterate_exactly (xs₁.length) (applyc `congr_fun),
         applyc `congr_arg)

meta def mk_congr_law (ctx : ac_mono_ctx) : tactic expr :=
match ctx.function with
 | (mono_function.assoc f x₀ x₁) :=
    if (x₀ <|> x₁).is_some
       then mk_congr_args f x₀.to_monad x₁.to_monad ctx.left ctx.right
       else failed
 | (mono_function.assoc_comm f x₀) := mk_congr_args f [x₀] [] ctx.left ctx.right
 | (mono_function.non_assoc f x₀ x₁) := mk_congr_args f x₀ x₁ ctx.left ctx.right
end

meta def mk_pattern (ctx : ac_mono_ctx) : tactic mono_law :=
match (sequence ctx : option (ac_mono_ctx' _)) with
 | (some ctx) :=
   match ctx.function with
    | (mono_function.assoc f (some x) (some y)) :=
      return $ mono_law.assoc
       ( mk_rel ctx (λ i, bin_op f x (bin_op f i y))
       , mk_rel ctx (λ i, bin_op f i y))
       ( mk_rel ctx (λ i, bin_op f (bin_op f x i) y)
       , mk_rel ctx (λ i, bin_op f x i))
    | (mono_function.assoc f (some x) none) :=
      return $ mono_law.other $
        mk_rel ctx (λ e, mk_fun_app ctx.function e)
    | (mono_function.assoc f none (some y)) :=
      return $ mono_law.other $
        mk_rel ctx (λ e, mk_fun_app ctx.function e)
    | (mono_function.assoc f none none) :=
      none
    | _ :=
      return $ mono_law.other $
         mk_rel ctx (λ e, mk_fun_app ctx.function e)
   end
 | none := mono_law.congr <$> mk_congr_law ctx
end

meta def match_rule (pat : expr) (r : name) : tactic expr :=
do  r' ← mk_const r,
    t  ← infer_type r',
    t  ← expr.dsimp t { fail_if_unchanged := ff } tt [] [
      simp_arg_type.expr ``(monotone), simp_arg_type.expr ``(strict_mono)],
    match_rule_head pat [] r' t

meta def find_lemma (pat : expr) : list name → tactic (list expr)
 | [] := return []
 | (r :: rs) :=
 do (cons <$> match_rule pat r <|> pure id) <*> find_lemma rs

meta def match_chaining_rules (ls : list name) (x₀ x₁ : expr) : tactic (list expr) :=
do x' ← to_expr ``(%%x₁ → %%x₀),
   r₀ ← find_lemma x' ls,
   r₁ ← find_lemma x₁ ls,
   return (expr.app <$> r₀ <*> r₁)

meta def find_rule (ls : list name) : mono_law → tactic (list expr)
 | (mono_law.assoc (x₀,x₁) (y₀,y₁)) :=
(match_chaining_rules ls x₀ x₁)
<|> (match_chaining_rules ls y₀ y₁)
 | (mono_law.congr r) := return [r]
 | (mono_law.other p) := find_lemma p ls

universes u v

def apply_rel {α : Sort u} (R : α → α → Sort v) {x y : α}
  (x' y' : α)
  (h : R x y)
  (hx : x = x')
  (hy : y = y')
: R x' y' :=
by { rw [← hx,← hy], apply h }

meta def ac_refine (e : expr) : tactic unit :=
refine ``(eq.mp _ %%e) ; ac_refl

meta def one_line (e : expr) : tactic format :=
do lbl ← pp e,
   asm ← infer_type e >>= pp,
   return format!"\t{asm}\n"

meta def side_conditions (e : expr) : tactic format :=
do let vs := e.list_meta_vars,
   ts ← mmap one_line vs.tail,
   let r := e.get_app_fn.const_name,
   return format!"{r}:\n{format.join ts}"

open monad

/-- tactic-facing function, similar to `interactive.tactic.generalize` with the
exception that meta variables -/
private meta def monotonicity.generalize' (h : name) (v : expr) (x : name) : tactic (expr × expr) :=
do tgt ← target,
   t ← infer_type v,
   tgt' ← do
   { ⟨tgt', _⟩ ← solve_aux tgt (tactic.generalize v x >> target),
     to_expr ``(λ y : %%t, Π x, y = x → %%(tgt'.binding_body.lift_vars 0 1)) }
   <|> to_expr ``(λ y : %%t, Π x, %%v = x → %%tgt),
   t ← head_beta (tgt' v) >>= assert h,
   swap,
   r ← mk_eq_refl v,
   solve1 $ tactic.exact (t v r),
   prod.mk <$> tactic.intro x <*> tactic.intro h

private meta def hide_meta_vars (tac : list expr → tactic unit) : tactic unit :=
focus1 $
do tgt ← target >>= instantiate_mvars,
   tactic.change tgt,
   ctx ← local_context,
   let vs := tgt.list_meta_vars,
   vs' ← mmap (λ v,
             do h ← get_unused_name `h,
                x ← get_unused_name `x,
                prod.snd <$> monotonicity.generalize' h v x) vs,
     tac ctx;
     vs'.mmap' (try ∘ tactic.subst)

meta def hide_meta_vars' (tac : itactic) : itactic :=
hide_meta_vars $ λ _, tac

end config

meta def solve_mvar (v : expr) (tac : tactic unit) : tactic unit :=
do gs ← get_goals,
   set_goals [v],
   target >>= instantiate_mvars >>= tactic.change,
   tac, done,
   set_goals $ gs

def list.minimum_on {α β} [linear_order β] (f : α → β) : list α → list α
| [] := []
| (x :: xs) := prod.snd $ xs.foldl (λ ⟨k,a⟩ b,
     let k' := f b in
     if k < k' then (k,a)
     else if k' < k then (k', [b])
     else (k,b :: a)) (f x, [x])

open format mono_selection

meta def best_match {β} (xs : list expr) (tac : expr → tactic β) : tactic unit :=
do t ← target,
   xs ← xs.mmap (λ x,
     try_core $ prod.mk x <$> solve_aux t (tac x >> get_goals)),
   let xs := xs.filter_map id,
   let r := list.minimum_on (list.length ∘ prod.fst ∘ prod.snd) xs,
   match r with
   | [(_,gs,pr)] :=  tactic.exact pr >> set_goals gs
   | [] := fail "no good match found"
   | _ :=
     do lmms ← r.mmap (λ ⟨l,gs,_⟩,
          do ts ← gs.mmap infer_type,
             msg ← ts.mmap pp,
             pure $ foldl compose "\n\n" $
               list.intersperse "\n" $ to_fmt l.get_app_fn.const_name :: msg),
        let msg := foldl compose "" lmms,
        fail format!("ambiguous match: {msg}\n\n" ++
          "Tip: try asserting a side condition to distinguish between the lemmas")
   end

meta def mono_aux (dir : parse side) :
  tactic unit :=
do t ← target >>= instantiate_mvars,
   ns ← get_monotonicity_lemmas t dir,
   asms ← local_context,
   rs ← find_lemma asms t ns,
   focus1 $ () <$ best_match rs (λ law, tactic.refine $ to_pexpr law)

/--
- `mono` applies a monotonicity rule.
- `mono*` applies monotonicity rules repetitively.
- `mono with x ≤ y` or `mono with [0 ≤ x,0 ≤ y]` creates an assertion for the listed
  propositions. Those help to select the right monotonicity rule.
- `mono left` or `mono right` is useful when proving strict orderings:
   for `x + y < w + z` could be broken down into either
    - left:  `x ≤ w` and `y < z` or
    - right: `x < w` and `y ≤ z`
- `mono using [rule1,rule2]` calls `simp [rule1,rule2]` before applying mono.
- The general syntax is
  `mono '*'? ('with' hyp | 'with' [hyp1,hyp2])? ('using' [hyp1,hyp2])? mono_cfg?`

To use it, first import `tactic.monotonicity`.

Here is an example of mono:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, -- unfold `(-)`, apply add_le_add
  { -- ⊢ k + 3 + x ≤ k + 4 + x
    mono, -- apply add_le_add, refl
    -- ⊢ k + 3 ≤ k + 4
    mono },
  { -- ⊢ -y ≤ -z
    mono /- apply neg_le_neg -/ }
end
```

More succinctly, we can prove the same goal as:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
by mono*
```

-/
meta def mono (many : parse (tk "*")?)
  (dir : parse side)
  (hyps : parse $ tk "with" *> pexpr_list_or_texpr <|> pure [])
  (simp_rules : parse $ tk "using" *> simp_arg_list <|> pure []) :
  tactic unit :=
do hyps ← hyps.mmap (λ p, to_expr p >>= mk_meta_var),
   hyps.mmap' (λ pr, do h ← get_unused_name `h, note h none pr),
   when (¬ simp_rules.empty) (simp_core { } failed tt simp_rules [] (loc.ns [none]) >> skip),
   if many.is_some
     then repeat $ mono_aux dir
     else mono_aux dir,
   gs ← get_goals,
   set_goals $ hyps ++ gs

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

/--
transforms a goal of the form `f x ≼ f y` into `x ≤ y` using lemmas
marked as `monotonic`.

Special care is taken when `f` is the repeated application of an
associative operator and if the operator is commutative
-/
meta def ac_mono_aux (cfg : mono_cfg := { mono_cfg . }) :
  tactic unit :=
hide_meta_vars $ λ asms,
do try `[simp only [sub_eq_add_neg]],
   tgt ← target >>= instantiate_mvars,
   (l,r,id_rs,g) ← ac_monotonicity_goal cfg tgt
             <|> fail "monotonic context not found",
   ns ← get_monotonicity_lemmas tgt both,
   p ← mk_pattern g,
   rules ← find_rule asms ns p <|> fail "no applicable rules found",
   when (rules = []) (fail "no applicable rules found"),
   err ← format.join <$> mmap side_conditions rules,
   focus1 $ best_match rules (λ rule, do
     t₀ ← mk_meta_var `(Prop),
     v₀ ← mk_meta_var t₀,
     t₁ ← mk_meta_var `(Prop),
     v₁ ← mk_meta_var t₁,
     tactic.refine $ ``(apply_rel %%(g.rel_def) %%l %%r %%rule %%v₀ %%v₁),
     solve_mvar v₀ (try (any_of id_rs rewrite_target) >>
             ( done <|>
               refl <|>
               ac_refl <|>
               `[simp only [is_associative.assoc]]) ),
     solve_mvar v₁ (try (any_of id_rs rewrite_target) >>
             ( done <|>
               refl <|>
               ac_refl <|>
               `[simp only [is_associative.assoc]]) ),
     n ← num_goals,
     iterate_exactly (n-1) (try $ solve1 $ apply_instance <|>
       tactic.solve_by_elim { lemmas := some asms }))

open sum nat

/-- (repeat_until_or_at_most n t u): repeat tactic `t` at most n times or until u succeeds -/
meta def repeat_until_or_at_most : nat → tactic unit → tactic unit → tactic unit
| 0        t _ := fail "too many applications"
| (succ n) t u := u <|> (t >> repeat_until_or_at_most n t u)

meta def repeat_until : tactic unit → tactic unit → tactic unit :=
repeat_until_or_at_most 100000

@[derive _root_.has_reflect, derive _root_.inhabited]
inductive rep_arity : Type
| one | exactly (n : ℕ) | many

meta def repeat_or_not : rep_arity → tactic unit → option (tactic unit) → tactic unit
 | rep_arity.one  tac none := tac
 | rep_arity.many tac none := repeat tac
 | (rep_arity.exactly n) tac none := iterate_exactly' n tac
 | rep_arity.one  tac (some until) := tac >> until
 | rep_arity.many tac (some until) := repeat_until tac until
 | (rep_arity.exactly n) tac (some until) := iterate_exactly n tac >> until

meta def assert_or_rule : lean.parser (pexpr ⊕ pexpr) :=
(tk ":=" *> inl <$> texpr <|> (tk ":" *> inr <$> texpr))

meta def arity : lean.parser rep_arity :=
rep_arity.many <$ tk "*" <|>
rep_arity.exactly <$> (tk "^" *> small_nat) <|>
pure rep_arity.one

/--

`ac_mono` reduces the `f x ⊑ f y`, for some relation `⊑` and a
monotonic function `f` to `x ≺ y`.

`ac_mono*` unwraps monotonic functions until it can't.

`ac_mono^k`, for some literal number `k` applies monotonicity `k`
times.

`ac_mono := h`, with `h` a hypothesis, unwraps monotonic functions and
uses `h` to solve the remaining goal. Can be combined with `*` or `^k`:
`ac_mono* := h`

`ac_mono : p` asserts `p` and uses it to discharge the goal result
unwrapping a series of monotonic functions. Can be combined with * or
^k: `ac_mono* : p`

In the case where `f` is an associative or commutative operator,
`ac_mono` will consider any possible permutation of its arguments and
use the one the minimizes the difference between the left-hand side
and the right-hand side.

To use it, first import `tactic.monotonicity`.

`ac_mono` can be used as follows:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
  ac_mono,
  -- ⊢ m + x + n ≤ y + n + m
  ac_mono,
end
```

As with `mono*`, `ac_mono*` solves the goal in one go and so does
`ac_mono* := h₁`. The latter syntax becomes especially interesting in the
following example:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : m + x + n ≤ y + n + m) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by ac_mono* := h₁.
```

By giving `ac_mono` the assumption `h₁`, we are asking `ac_refl` to
stop earlier than it would normally would.
-/
meta def ac_mono (rep : parse arity) :
         parse assert_or_rule? →
         opt_param mono_cfg { mono_cfg . } →
         tactic unit
 | none opt := focus1 $ repeat_or_not rep (ac_mono_aux opt) none
 | (some (inl h)) opt :=
do focus1 $ repeat_or_not rep (ac_mono_aux opt) (some $ done <|> to_expr h >>= ac_refine)
 | (some (inr t)) opt :=
do h ← i_to_expr t >>= assert `h,
   tactic.swap,
   focus1 $ repeat_or_not rep (ac_mono_aux opt) (some $ done <|> ac_refine h)
/-
TODO(Simon): with `ac_mono := h` and `ac_mono : p` split the remaining
  gaol if the provided rule does not solve it completely.
-/

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

attribute [mono] and.imp or.imp

end tactic.interactive


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

notation, basic datatypes and type classes
-/
prelude
import Init.Prelude
import Init.SizeOf

universe u v w

def inline {α : Sort u} (a : α) : α := a

@[inline] def flip {α : Sort u} {β : Sort v} {φ : Sort w} (f : α → β → φ) : β → α → φ :=
  fun b a => f a b

/--
  Thunks are "lazy" values that are evaluated when first accessed using `Thunk.get/map/bind`.
  The value is then stored and not recomputed for all further accesses. -/
-- NOTE: the runtime has special support for the `Thunk` type to implement this behavior
structure Thunk (α : Type u) : Type u where
  -- TODO: make private
  fn : Unit → α

attribute [extern "lean_mk_thunk"] Thunk.mk

/-- Store a value in a thunk. Note that the value has already been computed, so there is no laziness. -/
@[extern "lean_thunk_pure"] protected def Thunk.pure (a : α) : Thunk α :=
  ⟨fun _ => a⟩
-- NOTE: we use `Thunk.get` instead of `Thunk.fn` as the accessor primitive as the latter has an additional `Unit` argument
@[extern "lean_thunk_get_own"] protected def Thunk.get (x : @& Thunk α) : α :=
  x.fn ()
@[inline] protected def Thunk.map (f : α → β) (x : Thunk α) : Thunk β :=
  ⟨fun _ => f x.get⟩
@[inline] protected def Thunk.bind (x : Thunk α) (f : α → Thunk β) : Thunk β :=
  ⟨fun _ => (f x.get).get⟩

abbrev Eq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} {b : α} (h : a = b) (m : motive a) : motive b :=
  Eq.ndrec m h

structure Iff (a b : Prop) : Prop where
  intro :: (mp : a → b) (mpr : b → a)

infix:20 " <-> " => Iff
infix:20 " ↔ "   => Iff

inductive Sum (α : Type u) (β : Type v) where
  | inl (val : α) : Sum α β
  | inr (val : β) : Sum α β

inductive PSum (α : Sort u) (β : Sort v) where
  | inl (val : α) : PSum α β
  | inr (val : β) : PSum α β

structure Sigma {α : Type u} (β : α → Type v) where
  fst : α
  snd : β fst

attribute [unbox] Sigma

structure PSigma {α : Sort u} (β : α → Sort v) where
  fst : α
  snd : β fst

inductive Exists {α : Sort u} (p : α → Prop) : Prop where
  | intro (w : α) (h : p w) : Exists p

/- Auxiliary type used to compile `for x in xs` notation. -/
inductive ForInStep (α : Type u) where
  | done  : α → ForInStep α
  | yield : α → ForInStep α

class ForIn (m : Type u₁ → Type u₂) (ρ : Type u) (α : outParam (Type v)) where
  forIn {β} [Monad m] (x : ρ) (b : β) (f : α → β → m (ForInStep β)) : m β

export ForIn (forIn)

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPRBC (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPRBC α β σ
  | «return»   : β → σ → DoResultPRBC α β σ
  | «break»    : σ → DoResultPRBC α β σ
  | «continue» : σ → DoResultPRBC α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPR (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPR α β σ
  | «return»   : β → σ → DoResultPR α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultBC (σ : Type u) where
  | «break»    : σ → DoResultBC σ
  | «continue» : σ → DoResultBC σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultSBC (α σ : Type u) where
  | «pureReturn» : α → σ → DoResultSBC α σ
  | «break»      : σ → DoResultSBC α σ
  | «continue»   : σ → DoResultSBC α σ

class HasEquiv  (α : Sort u) where
  Equiv : α → α → Sort v

infix:50 " ≈ "  => HasEquiv.Equiv

class EmptyCollection (α : Type u) where
  emptyCollection : α

notation "{" "}" => EmptyCollection.emptyCollection
notation "∅"     => EmptyCollection.emptyCollection

/- Remark: tasks have an efficient implementation in the runtime. -/
structure Task (α : Type u) : Type u where
  pure :: (get : α)
  deriving Inhabited

attribute [extern "lean_task_pure"] Task.pure
attribute [extern "lean_task_get_own"] Task.get

namespace Task
/-- Task priority. Tasks with higher priority will always be scheduled before ones with lower priority. -/
abbrev Priority := Nat
def Priority.default : Priority := 0
-- see `LEAN_MAX_PRIO`
def Priority.max : Priority := 8
/--
  Any priority higher than `Task.Priority.max` will result in the task being scheduled immediately on a dedicated thread.
  This is particularly useful for long-running and/or I/O-bound tasks since Lean will by default allocate no more
  non-dedicated workers than the number of cores to reduce context switches. -/
def Priority.dedicated : Priority := 9

@[noinline, extern "lean_task_spawn"]
protected def spawn {α : Type u} (fn : Unit → α) (prio := Priority.default) : Task α :=
  ⟨fn ()⟩

@[noinline, extern "lean_task_map"]
protected def map {α : Type u} {β : Type v} (f : α → β) (x : Task α) (prio := Priority.default) : Task β :=
  ⟨f x.get⟩

@[noinline, extern "lean_task_bind"]
protected def bind {α : Type u} {β : Type v} (x : Task α) (f : α → Task β) (prio := Priority.default) : Task β :=
  ⟨(f x.get).get⟩

end Task

/- Some type that is not a scalar value in our runtime. -/
structure NonScalar where
  val : Nat

/- Some type that is not a scalar value in our runtime and is universe polymorphic. -/
inductive PNonScalar : Type u where
  | mk (v : Nat) : PNonScalar

theorem natAddZero (n : Nat) : n + 0 = n := rfl

theorem optParamEq (α : Sort u) (default : α) : optParam α default = α := rfl

/- Boolean operators -/

@[extern c inline "#1 || #2"] def strictOr  (b₁ b₂ : Bool) := b₁ || b₂
@[extern c inline "#1 && #2"] def strictAnd (b₁ b₂ : Bool) := b₁ && b₂

@[inline] def bne {α : Type u} [BEq α] (a b : α) : Bool :=
  !(a == b)

infix:50 " != " => bne

/- Logical connectives an equality -/

def implies (a b : Prop) := a → b

theorem implies.trans {p q r : Prop} (h₁ : implies p q) (h₂ : implies q r) : implies p r :=
  fun hp => h₂ (h₁ hp)

def trivial : True := ⟨⟩

theorem mt {a b : Prop} (h₁ : a → b) (h₂ : ¬b) : ¬a :=
  fun ha => h₂ (h₁ ha)

theorem notFalse : ¬False := id

-- proof irrelevance is built in
theorem proofIrrel {a : Prop} (h₁ h₂ : a) : h₁ = h₂ := rfl

theorem id.def {α : Sort u} (a : α) : id a = a := rfl

@[macroInline] def Eq.mp {α β : Sort u} (h : α = β) (a : α) : β :=
  h ▸ a

@[macroInline] def Eq.mpr {α β : Sort u} (h : α = β) (b : β) : α :=
  h ▸ b

theorem Eq.substr {α : Sort u} {p : α → Prop} {a b : α} (h₁ : b = a) (h₂ : p a) : p b :=
  h₁ ▸ h₂

theorem castEq {α : Sort u} (h : α = α) (a : α) : cast h a = a :=
  rfl

@[reducible] def Ne {α : Sort u} (a b : α) :=
  ¬(a = b)

infix:50 " ≠ "  => Ne

section Ne
variable {α : Sort u}
variable {a b : α} {p : Prop}

theorem Ne.intro (h : a = b → False) : a ≠ b := h

theorem Ne.elim (h : a ≠ b) : a = b → False := h

theorem Ne.irrefl (h : a ≠ a) : False := h rfl

theorem Ne.symm (h : a ≠ b) : b ≠ a :=
  fun h₁ => h (h₁.symm)

theorem falseOfNe : a ≠ a → False := Ne.irrefl

theorem neFalseOfSelf : p → p ≠ False :=
  fun (hp : p) (h : p = False) => h ▸ hp

theorem neTrueOfNot : ¬p → p ≠ True :=
  fun (hnp : ¬p) (h : p = True) =>
    have : ¬True := h ▸ hnp
    this trivial

theorem trueNeFalse : ¬True = False :=
  neFalseOfSelf trivial

end Ne

section
variable {α β φ : Sort u} {a a' : α} {b b' : β} {c : φ}

theorem HEq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : a ≅ b) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} {β : Sort u2} {b : β} (h : a ≅ b) (m : motive a) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : a ≅ b) (h₂ : p a) : p b :=
  eqOfHEq h₁ ▸ h₂

theorem HEq.subst {p : (T : Sort u) → T → Prop} (h₁ : a ≅ b) (h₂ : p α a) : p β b :=
  HEq.ndrecOn h₁ h₂

theorem HEq.symm (h : a ≅ b) : b ≅ a :=
  HEq.ndrecOn (motive := fun x => x ≅ a) h (HEq.refl a)

theorem heqOfEq (h : a = a') : a ≅ a' :=
  Eq.subst h (HEq.refl a)

theorem HEq.trans (h₁ : a ≅ b) (h₂ : b ≅ c) : a ≅ c :=
  HEq.subst h₂ h₁

theorem heqOfHEqOfEq (h₁ : a ≅ b) (h₂ : b = b') : a ≅ b' :=
  HEq.trans h₁ (heqOfEq h₂)

theorem heqOfEqOfHEq (h₁ : a = a') (h₂ : a' ≅ b) : a ≅ b :=
  HEq.trans (heqOfEq h₁) h₂

def typeEqOfHEq (h : a ≅ b) : α = β :=
  HEq.ndrecOn (motive := @fun (x : Sort u) _ => α = x) h (Eq.refl α)

end

theorem eqRecHEq {α : Sort u} {φ : α → Sort v} {a a' : α} : (h : a = a') → (p : φ a) → (Eq.recOn (motive := fun x _ => φ x) h p) ≅ p
  | rfl, p => HEq.refl p

theorem heqOfEqRecEq {α β : Sort u} {a : α} {b : β} (h₁ : α = β) (h₂ : Eq.rec (motive := fun α _ => α) a h₁ = b) : a ≅ b := by
  subst h₁
  apply heqOfEq
  exact h₂

theorem castHEq {α β : Sort u} : (h : α = β) → (a : α) → cast h a ≅ a
  | rfl, a => HEq.refl a

variable {a b c d : Prop}

theorem iffIffImpliesAndImplies (a b : Prop) : (a ↔ b) ↔ (a → b) ∧ (b → a) :=
  Iff.intro (fun h => And.intro h.mp h.mpr) (fun h => Iff.intro h.left h.right)

theorem Iff.refl (a : Prop) : a ↔ a :=
  Iff.intro (fun h => h) (fun h => h)

theorem Iff.rfl {a : Prop} : a ↔ a :=
  Iff.refl a

theorem Iff.trans (h₁ : a ↔ b) (h₂ : b ↔ c) : a ↔ c :=
  Iff.intro
    (fun ha => Iff.mp h₂ (Iff.mp h₁ ha))
    (fun hc => Iff.mpr h₁ (Iff.mpr h₂ hc))

theorem Iff.symm (h : a ↔ b) : b ↔ a :=
  Iff.intro (Iff.mpr h) (Iff.mp h)

theorem Iff.comm : (a ↔ b) ↔ (b ↔ a) :=
  Iff.intro Iff.symm Iff.symm

/- Exists -/

theorem Exists.elim {α : Sort u} {p : α → Prop} {b : Prop}
   (h₁ : Exists (fun x => p x)) (h₂ : ∀ (a : α), p a → b) : b :=
  h₂ h₁.1 h₁.2

/- Decidable -/

theorem decideTrueEqTrue (h : Decidable True) : @decide True h = true :=
  match h with
  | isTrue h  => rfl
  | isFalse h => False.elim <| h ⟨⟩

theorem decideFalseEqFalse (h : Decidable False) : @decide False h = false :=
  match h with
  | isFalse h => rfl
  | isTrue h  => False.elim h

/-- Similar to `decide`, but uses an explicit instance -/
@[inline] def toBoolUsing {p : Prop} (d : Decidable p) : Bool :=
  decide p (h := d)

theorem toBoolUsingEqTrue {p : Prop} (d : Decidable p) (h : p) : toBoolUsing d = true :=
  decideEqTrue (s := d) h

theorem ofBoolUsingEqTrue {p : Prop} {d : Decidable p} (h : toBoolUsing d = true) : p :=
  ofDecideEqTrue (s := d) h

theorem ofBoolUsingEqFalse {p : Prop} {d : Decidable p} (h : toBoolUsing d = false) : ¬ p :=
  ofDecideEqFalse (s := d) h

instance : Decidable True :=
  isTrue trivial

instance : Decidable False :=
  isFalse notFalse

namespace Decidable
variable {p q : Prop}

@[macroInline] def byCases {q : Sort u} [dec : Decidable p] (h1 : p → q) (h2 : ¬p → q) : q :=
  match dec with
  | isTrue h  => h1 h
  | isFalse h => h2 h

theorem em (p : Prop) [Decidable p] : p ∨ ¬p :=
  byCases Or.inl Or.inr

theorem byContradiction [dec : Decidable p] (h : ¬p → False) : p :=
  byCases id (fun np => False.elim (h np))

theorem ofNotNot [Decidable p] : ¬ ¬ p → p :=
  fun hnn => byContradiction (fun hn => absurd hn hnn)

theorem notAndIffOrNot (p q : Prop) [d₁ : Decidable p] [d₂ : Decidable q] : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q :=
  Iff.intro
    (fun h => match d₁, d₂ with
      | isTrue h₁,  isTrue h₂   => absurd (And.intro h₁ h₂) h
      | _,           isFalse h₂ => Or.inr h₂
      | isFalse h₁, _           => Or.inl h₁)
    (fun (h) ⟨hp, hq⟩ => match h with
      | Or.inl h => h hp
      | Or.inr h => h hq)

end Decidable

section
variable {p q : Prop}
@[inline] def  decidableOfDecidableOfIff (hp : Decidable p) (h : p ↔ q) : Decidable q :=
  if hp : p then
    isTrue (Iff.mp h hp)
  else
    isFalse fun hq => absurd (Iff.mpr h hq) hp

@[inline] def  decidableOfDecidableOfEq (hp : Decidable p) (h : p = q) : Decidable q :=
  h ▸ hp
end

@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (p → q) :=
  if hp : p then
    if hq : q then isTrue (fun h => hq)
    else isFalse (fun h => absurd (h hp) hq)
  else isTrue (fun h => absurd h hp)

instance {p q} [Decidable p] [Decidable q] : Decidable (p ↔ q) :=
  if hp : p then
    if hq : q then
      isTrue ⟨fun _ => hq, fun _ => hp⟩
    else
      isFalse fun h => hq (h.1 hp)
  else
    if hq : q then
      isFalse fun h => hp (h.2 hq)
    else
      isTrue ⟨fun h => absurd h hp, fun h => absurd h hq⟩

/- if-then-else expression theorems -/

theorem ifPos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t e : α} : (ite c t e) = t :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem ifNeg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t e : α} : (ite c t e) = e :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

theorem difPos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = t hc :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem difNeg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = e hnc :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

-- Remark: dite and ite are "defally equal" when we ignore the proofs.
theorem difEqIf (c : Prop) [h : Decidable c] {α : Sort u} (t : α) (e : α) : dite c (fun h => t) (fun h => e) = ite c t e :=
  match h with
  | isTrue hc   => rfl
  | isFalse hnc => rfl

instance {c t e : Prop} [dC : Decidable c] [dT : Decidable t] [dE : Decidable e] : Decidable (if c then t else e)  :=
  match dC with
  | isTrue hc  => dT
  | isFalse hc => dE

instance {c : Prop} {t : c → Prop} {e : ¬c → Prop} [dC : Decidable c] [dT : ∀ h, Decidable (t h)] [dE : ∀ h, Decidable (e h)] : Decidable (if h : c then t h else e h)  :=
  match dC with
  | isTrue hc  => dT hc
  | isFalse hc => dE hc

/- Inhabited -/

instance : Inhabited Prop where
  default := True

deriving instance Inhabited for NonScalar, PNonScalar, True, ForInStep

class inductive Nonempty (α : Sort u) : Prop where
  | intro (val : α) : Nonempty α

protected def Nonempty.elim {α : Sort u} {p : Prop} (h₁ : Nonempty α) (h₂ : α → p) : p :=
  h₂ h₁.1

instance {α : Sort u} [Inhabited α] : Nonempty α where
  val := arbitrary

theorem nonemptyOfExists {α : Sort u} {p : α → Prop} : Exists (fun x => p x) → Nonempty α
  | ⟨w, h⟩ => ⟨w⟩

/- Subsingleton -/

class Subsingleton (α : Sort u) : Prop where
  intro :: allEq : (a b : α) → a = b

protected def Subsingleton.elim {α : Sort u} [h : Subsingleton α] : (a b : α) → a = b :=
  h.allEq

protected def Subsingleton.helim {α β : Sort u} [h₁ : Subsingleton α] (h₂ : α = β) (a : α) (b : β) : a ≅ b := by
  subst h₂
  apply heqOfEq
  apply Subsingleton.elim

instance (p : Prop) : Subsingleton p :=
  ⟨fun a b => proofIrrel a b⟩

instance (p : Prop) : Subsingleton (Decidable p) :=
  Subsingleton.intro fun
    | isTrue t₁ => fun
      | isTrue t₂  => rfl
      | isFalse f₂ => absurd t₁ f₂
    | isFalse f₁ => fun
      | isTrue t₂  => absurd t₂ f₁
      | isFalse f₂ => rfl

theorem recSubsingleton
     {p : Prop} [h : Decidable p]
     {h₁ : p → Sort u}
     {h₂ : ¬p → Sort u}
     [h₃ : ∀ (h : p), Subsingleton (h₁ h)]
     [h₄ : ∀ (h : ¬p), Subsingleton (h₂ h)]
     : Subsingleton (Decidable.casesOn (motive := fun _ => Sort u) h h₂ h₁) :=
  match h with
  | isTrue h  => h₃ h
  | isFalse h => h₄ h

structure Equivalence {α : Sort u} (r : α → α → Prop) : Prop where
  refl  : ∀ x, r x x
  symm  : ∀ {x y}, r x y → r y x
  trans : ∀ {x y z}, r x y → r y z → r x z

def emptyRelation {α : Sort u} (a₁ a₂ : α) : Prop :=
  False

def Subrelation {α : Sort u} (q r : α → α → Prop) :=
  ∀ {x y}, q x y → r x y

def InvImage {α : Sort u} {β : Sort v} (r : β → β → Prop) (f : α → β) : α → α → Prop :=
  fun a₁ a₂ => r (f a₁) (f a₂)

inductive TC {α : Sort u} (r : α → α → Prop) : α → α → Prop where
  | base  : ∀ a b, r a b → TC r a b
  | trans : ∀ a b c, TC r a b → TC r b c → TC r a c

/- Subtype -/

namespace Subtype
def existsOfSubtype {α : Type u} {p : α → Prop} : { x // p x } → Exists (fun x => p x)
  | ⟨a, h⟩ => ⟨a, h⟩

variable {α : Type u} {p : α → Prop}

protected theorem eq : ∀ {a1 a2 : {x // p x}}, val a1 = val a2 → a1 = a2
  | ⟨x, h1⟩, ⟨_, _⟩, rfl => rfl

theorem eta (a : {x // p x}) (h : p (val a)) : mk (val a) h = a := by
  cases a
  exact rfl

instance {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited {x // p x} where
  default := ⟨a, h⟩

instance {α : Type u} {p : α → Prop} [DecidableEq α] : DecidableEq {x : α // p x} :=
  fun ⟨a, h₁⟩ ⟨b, h₂⟩ =>
    if h : a = b then isTrue (by subst h; exact rfl)
    else isFalse (fun h' => Subtype.noConfusion h' (fun h' => absurd h' h))

end Subtype

/- Sum -/

section
variable {α : Type u} {β : Type v}

instance Sum.inhabitedLeft [h : Inhabited α] : Inhabited (Sum α β) where
  default := Sum.inl arbitrary

instance Sum.inhabitedRight [h : Inhabited β] : Inhabited (Sum α β) where
  default := Sum.inr arbitrary

instance {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] : DecidableEq (Sum α β) := fun a b =>
  match a, b with
  | Sum.inl a, Sum.inl b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inr b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inl b => isFalse fun h => Sum.noConfusion h
  | Sum.inl a, Sum.inr b => isFalse fun h => Sum.noConfusion h

end

/- Product -/

instance [Inhabited α] [Inhabited β] : Inhabited (α × β) where
  default := (arbitrary, arbitrary)

instance [DecidableEq α] [DecidableEq β] : DecidableEq (α × β) :=
  fun (a, b) (a', b') =>
    match decEq a a' with
    | isTrue e₁ =>
      match decEq b b' with
      | isTrue e₂  => isTrue (e₁ ▸ e₂ ▸ rfl)
      | isFalse n₂ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₂' n₂
    | isFalse n₁ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₁' n₁

instance [BEq α] [BEq β] : BEq (α × β) where
  beq := fun (a₁, b₁) (a₂, b₂) => a₁ == a₂ && b₁ == b₂

instance [LT α] [LT β] : LT (α × β) where
  lt s t := s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)

instance prodHasDecidableLt
    [LT α] [LT β] [DecidableEq α] [DecidableEq β]
    [(a b : α) → Decidable (a < b)] [(a b : β) → Decidable (a < b)]
    : (s t : α × β) → Decidable (s < t) :=
  fun t s => inferInstanceAs (Decidable (_ ∨ _))

theorem Prod.ltDef [LT α] [LT β] (s t : α × β) : (s < t) = (s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)) :=
  rfl

theorem Prod.ext (p : α × β) : (p.1, p.2) = p := by
  cases p; rfl

def Prod.map {α₁ : Type u₁} {α₂ : Type u₂} {β₁ : Type v₁} {β₂ : Type v₂}
    (f : α₁ → α₂) (g : β₁ → β₂) : α₁ × β₁ → α₂ × β₂
  | (a, b) => (f a, g b)

/- Dependent products -/

theorem exOfPsig {α : Type u} {p : α → Prop} : (PSigma (fun x => p x)) → Exists (fun x => p x)
  | ⟨x, hx⟩ => ⟨x, hx⟩

protected theorem PSigma.eta {α : Sort u} {β : α → Sort v} {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂}
    (h₁ : a₁ = a₂) (h₂ : Eq.ndrec b₁ h₁ = b₂) : PSigma.mk a₁ b₁ = PSigma.mk a₂ b₂ := by
  subst h₁
  subst h₂
  exact rfl

/- Universe polymorphic unit -/

theorem PUnit.subsingleton (a b : PUnit) : a = b := by
  cases a; cases b; exact rfl

@[simp] theorem PUnit.eq_punit (a : PUnit) : a = ⟨⟩ :=
  PUnit.subsingleton a ⟨⟩

instance : Subsingleton PUnit :=
  Subsingleton.intro PUnit.subsingleton

instance : Inhabited PUnit where
  default := ⟨⟩

instance : DecidableEq PUnit :=
  fun a b => isTrue (PUnit.subsingleton a b)

/- Setoid -/

class Setoid (α : Sort u) where
  r : α → α → Prop
  iseqv {} : Equivalence r

instance {α : Sort u} [Setoid α] : HasEquiv α :=
  ⟨Setoid.r⟩

namespace Setoid

variable {α : Sort u} [Setoid α]

theorem refl (a : α) : a ≈ a :=
  (Setoid.iseqv α).refl a

theorem symm {a b : α} (hab : a ≈ b) : b ≈ a :=
  (Setoid.iseqv α).symm hab

theorem trans {a b c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c :=
  (Setoid.iseqv α).trans hab hbc

end Setoid

/- Propositional extensionality -/

axiom propext {a b : Prop} : (a ↔ b) → a = b

theorem Eq.propIntro {a b : Prop} (h₁ : a → b) (h₂ : b → a) : a = b :=
  propext <| Iff.intro h₁ h₂

gen_injective_theorems% Prod
gen_injective_theorems% PProd
gen_injective_theorems% MProd
gen_injective_theorems% Subtype
gen_injective_theorems% Fin
gen_injective_theorems% Array
gen_injective_theorems% Sum
gen_injective_theorems% PSum
gen_injective_theorems% Nat
gen_injective_theorems% Option
gen_injective_theorems% List
gen_injective_theorems% Except
gen_injective_theorems% EStateM.Result
gen_injective_theorems% Lean.Name
gen_injective_theorems% Lean.Syntax

/- Quotients -/

-- Iff can now be used to do substitutions in a calculation
theorem iffSubst {a b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  Eq.subst (propext h₁) h₂

namespace Quot
axiom sound : ∀ {α : Sort u} {r : α → α → Prop} {a b : α}, r a b → Quot.mk r a = Quot.mk r b

protected theorem liftBeta {α : Sort u} {r : α → α → Prop} {β : Sort v}
    (f : α → β)
    (c : (a b : α) → r a b → f a = f b)
    (a : α)
    : lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem indBeta {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (p : (a : α) → motive (Quot.mk r a))
    (a : α)
    : (ind p (Quot.mk r a) : motive (Quot.mk r a)) = p a :=
  rfl

protected abbrev liftOn {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : (a b : α) → r a b → f a = f b) : β :=
  lift f c q

protected theorem inductionOn {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (q : Quot r)
    (h : (a : α) → motive (Quot.mk r a))
    : motive q :=
  ind h q

theorem existsRep {α : Sort u} {r : α → α → Prop} (q : Quot r) : Exists (fun a => (Quot.mk r a) = q) :=
  Quot.inductionOn (motive := fun q => Exists (fun a => (Quot.mk r a) = q)) q (fun a => ⟨a, rfl⟩)

section
variable {α : Sort u}
variable {r : α → α → Prop}
variable {motive : Quot r → Sort v}

@[reducible, macroInline]
protected def indep (f : (a : α) → motive (Quot.mk r a)) (a : α) : PSigma motive :=
  ⟨Quot.mk r a, f a⟩

protected theorem indepCoherent
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : (a b : α) → r a b → Quot.indep f a = Quot.indep f b  :=
  fun a b e => PSigma.eta (sound e) (h a b e)

protected theorem liftIndepPr1
    (f : (a : α) → motive (Quot.mk r a))
    (h : ∀ (a b : α) (p : r a b), Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r)
    : (lift (Quot.indep f) (Quot.indepCoherent f h) q).1 = q := by
 induction q using Quot.ind
 exact rfl

protected abbrev rec
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r) : motive q :=
  Eq.ndrecOn (Quot.liftIndepPr1 f h q) ((lift (Quot.indep f) (Quot.indepCoherent f h) q).2)

protected abbrev recOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : motive q :=
 Quot.rec f h q

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quot.mk r a))]
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    : motive q := by
  induction q using Quot.rec
  apply f
  apply Subsingleton.elim

protected abbrev hrecOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (c : (a b : α) → (p : r a b) → f a ≅ f b)
    : motive q :=
  Quot.recOn q f fun a b p => eqOfHEq <|
    have p₁ : Eq.ndrec (f a) (sound p) ≅ f a := eqRecHEq (sound p) (f a)
    HEq.trans p₁ (c a b p)

end
end Quot

def Quotient {α : Sort u} (s : Setoid α) :=
  @Quot α Setoid.r

namespace Quotient

@[inline]
protected def mk {α : Sort u} [s : Setoid α] (a : α) : Quotient s :=
  Quot.mk Setoid.r a

def sound {α : Sort u} [s : Setoid α] {a b : α} : a ≈ b → Quotient.mk a = Quotient.mk b :=
  Quot.sound

protected abbrev lift {α : Sort u} {β : Sort v} [s : Setoid α] (f : α → β) : ((a b : α) → a ≈ b → f a = f b) → Quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : Setoid α] {motive : Quotient s → Prop} : ((a : α) → motive (Quotient.mk a)) → (q : Quot Setoid.r) → motive q :=
  Quot.ind

protected abbrev liftOn {α : Sort u} {β : Sort v} [s : Setoid α] (q : Quotient s) (f : α → β) (c : (a b : α) → a ≈ b → f a = f b) : β :=
  Quot.liftOn q f c

protected theorem inductionOn {α : Sort u} [s : Setoid α] {motive : Quotient s → Prop}
    (q : Quotient s)
    (h : (a : α) → motive (Quotient.mk a))
    : motive q :=
  Quot.inductionOn q h

theorem existsRep {α : Sort u} [s : Setoid α] (q : Quotient s) : Exists (fun (a : α) => Quotient.mk a = q) :=
  Quot.existsRep q

section
variable {α : Sort u}
variable [s : Setoid α]
variable {motive : Quotient s → Sort v}

@[inline]
protected def rec
    (f : (a : α) → motive (Quotient.mk a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    (q : Quotient s)
    : motive q :=
  Quot.rec f h q

protected abbrev recOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    : motive q :=
  Quot.recOn q f h

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quotient.mk a))]
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    : motive q :=
  Quot.recOnSubsingleton (h := h) q f

protected abbrev hrecOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    (c : (a b : α) → (p : a ≈ b) → f a ≅ f b)
    : motive q :=
  Quot.hrecOn q f c
end

section
universe uA uB uC
variable {α : Sort uA} {β : Sort uB} {φ : Sort uC}
variable [s₁ : Setoid α] [s₂ : Setoid β]

protected abbrev lift₂
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    (q₁ : Quotient s₁) (q₂ : Quotient s₂)
    : φ := by
  apply Quotient.lift (fun (a₁ : α) => Quotient.lift (f a₁) (fun (a b : β) => c a₁ a a₁ b (Setoid.refl a₁)) q₂) _ q₁
  intros
  induction q₂ using Quotient.ind
  apply c; assumption; apply Setoid.refl

protected abbrev liftOn₂
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    : φ :=
  Quotient.lift₂ f c q₁ q₂

protected theorem ind₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (h : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (h : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₃
    [s₃ : Setoid φ]
    {motive : Quotient s₁ → Quotient s₂ → Quotient s₃ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (q₃ : Quotient s₃)
    (h : (a : α) → (b : β) → (c : φ) → motive (Quotient.mk a) (Quotient.mk b) (Quotient.mk c))
    : motive q₁ q₂ q₃ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  induction q₃ using Quotient.ind
  apply h

end

section Exact

variable   {α : Sort u}

private def rel [s : Setoid α] (q₁ q₂ : Quotient s) : Prop :=
  Quotient.liftOn₂ q₁ q₂
    (fun a₁ a₂ => a₁ ≈ a₂)
    (fun a₁ a₂ b₁ b₂ a₁b₁ a₂b₂ =>
      propext (Iff.intro
        (fun a₁a₂ => Setoid.trans (Setoid.symm a₁b₁) (Setoid.trans a₁a₂ a₂b₂))
        (fun b₁b₂ => Setoid.trans a₁b₁ (Setoid.trans b₁b₂ (Setoid.symm a₂b₂)))))

private theorem rel.refl [s : Setoid α] (q : Quotient s) : rel q q :=
  Quot.inductionOn (motive := fun q => rel q q) q (fun a => Setoid.refl a)

private theorem eqImpRel [s : Setoid α] {q₁ q₂ : Quotient s} : q₁ = q₂ → rel q₁ q₂ :=
  fun h => Eq.ndrecOn h (rel.refl q₁)

theorem exact [s : Setoid α] {a b : α} : Quotient.mk a = Quotient.mk b → a ≈ b :=
  fun h => eqImpRel h

end Exact

section
universe uA uB uC
variable {α : Sort uA} {β : Sort uB}
variable [s₁ : Setoid α] [s₂ : Setoid β]

protected abbrev recOnSubsingleton₂
    {motive : Quotient s₁ → Quotient s₂ → Sort uC}
    [s : (a : α) → (b : β) → Subsingleton (motive (Quotient.mk a) (Quotient.mk b))]
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (g : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    : motive q₁ q₂ := by
  induction q₁ using Quot.recOnSubsingleton
  induction q₂ using Quot.recOnSubsingleton
  apply g
  intro a; apply s
  induction q₂ using Quot.recOnSubsingleton
  intro a; apply s
  inferInstance

end
end Quotient

section
variable {α : Type u}
variable (r : α → α → Prop)

instance {α : Sort u} {s : Setoid α} [d : ∀ (a b : α), Decidable (a ≈ b)] : DecidableEq (Quotient s) :=
  fun (q₁ q₂ : Quotient s) =>
    Quotient.recOnSubsingleton₂ (motive := fun a b => Decidable (a = b)) q₁ q₂
      fun a₁ a₂ =>
        match d a₁ a₂ with
        | isTrue h₁  => isTrue (Quotient.sound h₁)
        | isFalse h₂ => isFalse fun h => absurd (Quotient.exact h) h₂

/- Function extensionality -/

namespace Function
variable {α : Sort u} {β : α → Sort v}

protected def Equiv (f₁ f₂ : ∀ (x : α), β x) : Prop := ∀ x, f₁ x = f₂ x

protected theorem Equiv.refl (f : ∀ (x : α), β x) : Function.Equiv f f :=
  fun x => rfl

protected theorem Equiv.symm {f₁ f₂ : ∀ (x : α), β x} : Function.Equiv f₁ f₂ → Function.Equiv f₂ f₁ :=
  fun h x => Eq.symm (h x)

protected theorem Equiv.trans {f₁ f₂ f₃ : ∀ (x : α), β x} : Function.Equiv f₁ f₂ → Function.Equiv f₂ f₃ → Function.Equiv f₁ f₃ :=
  fun h₁ h₂ x => Eq.trans (h₁ x) (h₂ x)

protected theorem Equiv.isEquivalence (α : Sort u) (β : α → Sort v) : Equivalence (@Function.Equiv α β) := {
  refl := Equiv.refl
  symm := Equiv.symm
  trans := Equiv.trans
}

end Function

section
open Quotient
variable {α : Sort u} {β : α → Sort v}

@[instance]
private def funSetoid (α : Sort u) (β : α → Sort v) : Setoid (∀ (x : α), β x) :=
  Setoid.mk (@Function.Equiv α β) (Function.Equiv.isEquivalence α β)

private def extfunApp (f : Quotient <| funSetoid α β) (x : α) : β x :=
  Quot.liftOn f
    (fun (f : ∀ (x : α), β x) => f x)
    (fun f₁ f₂ h => h x)

theorem funext {f₁ f₂ : ∀ (x : α), β x} (h : ∀ x, f₁ x = f₂ x) : f₁ = f₂ := by
  show extfunApp (Quotient.mk f₁) = extfunApp (Quotient.mk f₂)
  apply congrArg
  apply Quotient.sound
  exact h

end

instance {α : Sort u} {β : α → Sort v} [∀ a, Subsingleton (β a)] : Subsingleton (∀ a, β a) where
  allEq f₁ f₂ :=
    funext (fun a => Subsingleton.elim (f₁ a) (f₂ a))

/- Squash -/

def Squash (α : Type u) := Quot (fun (a b : α) => True)

def Squash.mk {α : Type u} (x : α) : Squash α := Quot.mk _ x

theorem Squash.ind {α : Type u} {motive : Squash α → Prop} (h : ∀ (a : α), motive (Squash.mk a)) : ∀ (q : Squash α), motive q :=
  Quot.ind h

@[inline] def Squash.lift {α β} [Subsingleton β] (s : Squash α) (f : α → β) : β :=
  Quot.lift f (fun a b _ => Subsingleton.elim _ _) s

instance : Subsingleton (Squash α) where
  allEq a b := by
    induction a using Squash.ind
    induction b using Squash.ind
    apply Quot.sound
    trivial

namespace Lean
/- Kernel reduction hints -/

/--
  When the kernel tries to reduce a term `Lean.reduceBool c`, it will invoke the Lean interpreter to evaluate `c`.
  The kernel will not use the interpreter if `c` is not a constant.
  This feature is useful for performing proofs by reflection.

  Remark: the Lean frontend allows terms of the from `Lean.reduceBool t` where `t` is a term not containing
  free variables. The frontend automatically declares a fresh auxiliary constant `c` and replaces the term with
  `Lean.reduceBool c`. The main motivation is that the code for `t` will be pre-compiled.

  Warning: by using this feature, the Lean compiler and interpreter become part of your trusted code base.
  This is extra 30k lines of code. More importantly, you will probably not be able to check your developement using
  external type checkers (e.g., Trepplein) that do not implement this feature.
  Keep in mind that if you are using Lean as programming language, you are already trusting the Lean compiler and interpreter.
  So, you are mainly losing the capability of type checking your developement using external checkers.

  Recall that the compiler trusts the correctness of all `[implementedBy ...]` and `[extern ...]` annotations.
  If an extern function is executed, then the trusted code base will also include the implementation of the associated
  foreign function.
-/
constant reduceBool (b : Bool) : Bool := b

/--
  Similar to `Lean.reduceBool` for closed `Nat` terms.

  Remark: we do not have plans for supporting a generic `reduceValue {α} (a : α) : α := a`.
  The main issue is that it is non-trivial to convert an arbitrary runtime object back into a Lean expression.
  We believe `Lean.reduceBool` enables most interesting applications (e.g., proof by reflection). -/
constant reduceNat (n : Nat) : Nat := n

axiom ofReduceBool (a b : Bool) (h : reduceBool a = b) : a = b
axiom ofReduceNat (a b : Nat) (h : reduceNat a = b)    : a = b

end Lean


import tactic
import tactic.induction

import .base .lemma_2_4

noncomputable theory
open_locale classical

lemma A_pw_2_hws : A_hws 2 :=
begin
  sorry
end


import its reducibility

open encodable denumerable

attribute [simp] set.set_of_app_iff

variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*} {τ : Type*} {μ : Type*}
  [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] [primcodable τ] [primcodable μ]
  {o : σ →. τ}
variables {n : ℕ} (S : strategy n) {k : ℕ}

open strategy encodable

def ancestor.equiv_fin {k : ℕ} (η : Tree k) :
ancestor η ≃ fin η.length :=
{ to_fun := (λ μ, ⟨μ.val.length, list.is_initial_length μ.property⟩),
  inv_fun := (λ n, ⟨η↾*n.val, list.is_initial_initial η n.val n.property⟩),
  left_inv := (λ ⟨μ, ⟨l, x, p⟩⟩,
    by { simp[←p],  simp only [show l ++ x :: μ = (l ++ [x]) ++ μ, by simp, list.initial_append] }),
  right_inv := (λ ⟨n, lt⟩, by { simp, exact list.initial_length lt }) }

instance primcodable.ancestor_arrow {α : Type*} [primcodable α] {k} (η : Tree k) : primcodable (ancestor η → α) :=
primcodable.of_equiv (fin η.length → α) (equiv.arrow_congr (ancestor.equiv_fin η) (by refl))

@[rcomputability]
lemma rcomputable.is_pi {k} : @Tree'.is_pi k computable_in o :=
begin
  induction k with k IH,
  { exact rcomputable.id.of_eq (λ b, by cases b; simp) },
  { let F : Tree' (k + 1) → bool := λ μ, list.cases_on μ ff (λ η _, !@Tree'.is_pi k η),
    have : F computable_in o,
    { refine (rcomputable.list_rec (rcomputable.id') (rcomputable.const ff)
      ((rcomputable.dom_fintype bnot).comp (IH.comp (rcomputable.fst.comp rcomputable.snd)))) },
    exact this.of_eq (λ μ, by { induction μ with ν μ IH; simp[F, Tree'.is_sigma] }) }
end

@[rcomputability]
lemma rcomputable.is_sigma {k} : @Tree'.is_sigma k computable_in o :=
(rcomputable.dom_fintype bnot).comp rcomputable.is_pi

def ancestor.extend_fn'_enc (α : Type*) [inhabited α] [primcodable α] (η : Tree k) (x : Tree' k) (n : ℕ) : ℕ :=
  let f := (decode (ancestor (x :: η) → α) n).iget in
encode (ancestor.extend_fn f η (list.suffix_cons x η))

namespace strategy

namespace approx_enc

def derivative (η : Tree (k + 1)) (μ : Tree k) (υ : list (Tree (k + 1))) : list ℕ :=
(list.range_r μ.length).filter (λ i, υ.nth i = η)

def pi_derivative
  (η : Tree (k + 1)) (μ : Tree k) (υ : list (Tree (k + 1))) : list ℕ :=
(derivative η μ υ).filter (λ i, @Tree'.is_sigma (k + 1) (μ↾*(i + 1)))

def lambda : Π (μ : Tree k) (υ : list (Tree (k + 1))), Tree (k + 1)
| []       _ := []
| (x :: μ) υ := let ih := lambda μ υ in
    option.cases_on (υ.nth μ.length) []
    (λ uμ, if uμ = ih ∨ (x.is_pi ∧ pi_derivative uμ μ υ = [])
    then (x :: μ) :: uμ else ih)

def assignment (μ : Tree k) (υ : list (Tree (k + 1))) : Tree (k + 1) × ℕ :=
(S.priority (k + 1)).Min_le
  ((lambda μ υ, 0) :: ((list.range_r (lambda μ υ).length).filter
    (λ i, @Tree'.is_sigma (k + 2) (lambda μ υ↾*(i + 1)))).map
  (λ i, ((lambda μ υ)↾*i, (derivative (lambda μ υ↾*i) μ υ).length))) (by simp)

def up (μ : Tree k) (υ : list (Tree (k + 1))) : Tree (k + 1) :=
(assignment S μ υ).1

lemma ancestors_eq_range (μ : Tree k) : μ.ancestors.map ancestor.index = list.range_r μ.length :=
by { induction μ with ν μ IH; simp[ancestor.index, (∘)], exact IH }

lemma derivative_eq {μ : Tree k} {υ : ancestor μ → Tree (k + 1)} {υ' : list (Tree (k + 1))}
  (h : ∀ ν : ancestor μ, υ'.nth ν.index = some (υ ν)) (η : Tree (k + 1)) :
  derivative η μ υ' = (approx.derivative η υ).map ancestor.index :=
by { simp[derivative, approx.derivative, ←ancestors_eq_range, list.map_filter, (∘)],
     congr, funext ν, simp [h] }

lemma pi_derivative_eq {μ : Tree k} {υ : ancestor μ → Tree (k + 1)} {υ' : list (Tree (k + 1))}
  (h : ∀ ν : ancestor μ, υ'.nth ν.index = some (υ ν)) (η : Tree (k + 1)) :
  pi_derivative η μ υ' = (approx.pi_derivative η υ).map ancestor.index :=
by { simp[pi_derivative, approx.pi_derivative, derivative_eq h, list.map_filter, (∘)],
     congr, funext ν, simp[ancestor_initial_index_succ] }

lemma lambda_eq {μ : Tree k} {υ : ancestor μ → Tree (k + 1)} {υ' : list (Tree (k + 1))}
  (h : ∀ ν : ancestor μ, υ'.nth ν.index = some (υ ν)) :
  lambda μ υ' = approx.lambda υ :=
begin
  induction μ with ν μ IH; simp[lambda, approx.lambda],
  rw [show υ'.nth μ.length = some (υ ⟨μ, by simp⟩), from h ⟨μ, by simp⟩], simp,
  have la_eq : lambda μ υ' = approx.lambda (ancestor.extend_fn υ μ _),
    from @IH (ancestor.extend_fn υ μ (by simp)) (λ σ, h (σ.extend (by simp))),
  have pider_eq : ∀ η,
    pi_derivative η μ υ' = list.map ancestor.index (approx.pi_derivative η (ancestor.extend_fn υ μ _)),
    from @pi_derivative_eq _ _ (ancestor.extend_fn υ μ (by simp)) υ'
    (λ σ, h (σ.extend (by simp))),
  simp[la_eq, pider_eq]
end

lemma assignment_eq {μ : Tree k} {υ : ancestor μ → Tree (k + 1)} {υ' : list (Tree (k + 1))}
  (h : ∀ ν : ancestor μ, υ'.nth ν.index = some (υ ν)) :
  assignment S μ υ' = approx.assignment S υ :=
begin
  simp[assignment, approx.assignment, lambda_eq h],
  refine omega_ordering.Min_le_eq _ _ _ _,
  simp,
  rw [←ancestors_eq_range],
  simp[list.map_filter, (∘)],
  congr,
  { funext ν, simp[ancestor_initial_index, derivative_eq h] },
  { ext ν, simp[ancestor_initial_index_succ] }
end

lemma up_eq {μ : Tree k} {υ : ancestor μ → Tree (k + 1)} {υ' : list (Tree (k + 1))}
  (h : ∀ ν : ancestor μ, υ'.nth ν.index = some (υ ν)) :
  up S μ υ' = approx.up S υ :=
congr_arg prod.fst (assignment_eq S h)

variables {S}
open rcomputable computable₂

lemma rcomputable.derivative :
  (prod.unpaired3 (derivative : Tree (k + 1) → Tree k → list (Tree (k + 1)) → list ℕ)) computable_in o :=
begin
  refine rcomputable.list_filter _ _,
  { refine (rcomputable₂.to_bool_eq (option (Tree (k + 1)))).comp₂ _ _,
    { exact rcomputable₂.list_nth.comp₂ (rcomputable.to_unary₁ rcomputable.snd.to_unary₂) rcomputable.id'.to_unary₂ },
    { exact rcomputable.to_unary₁ rcomputable.option_some.to_unary₁ } },
  { exact rcomputable.list_range_r.comp (rcomputable.list_length.comp rcomputable.fst.to_unary₂) }
end

lemma rcomputable.pi_derivative :
  (prod.unpaired3 (pi_derivative : Tree (k + 1) → Tree k → list (Tree (k + 1)) → list ℕ)) computable_in o :=
begin
  refine rcomputable.list_filter _ rcomputable.derivative,
  { simp, exact rcomputable.is_sigma.comp₂
    (rcomputable.rcomputable.list_initial.comp₂ (rcomputable.to_unary₁ rcomputable.fst.to_unary₂)
    rcomputable.succ.to_unary₂) }
end

lemma rcomputable.lambda :
  (lambda : Tree k → list (Tree (k + 1)) → Tree (k + 1)) computable₂_in o :=
begin
  let F : Tree k → list (Tree (k + 1)) → Tree (k + 1) :=
    λ μ υ, list.rec_on μ []
      (λ x μ ih, option.cases_on (υ.nth μ.length) []
        (λ uμ, if uμ = ih ∨ (x.is_pi ∧ pi_derivative uμ μ υ = []) then (x :: μ) :: uμ else ih)),
  have : F computable₂_in o,
  { simp[F],
    refine rcomputable.list_rec (rpartrec.some.to_unary₁) (rcomputable.const list.nil)
      (rcomputable.option_rec
        (rcomputable₂.list_nth.comp snd.to_unary₁
          (rcomputable.list_length.comp (fst.comp snd.to_unary₂)))
        (rcomputable.const list.nil)
      (rcomputable.ite _ _ _)),
    { simp, refine rcomputable.bor.comp _
        (rcomputable.band.comp (rcomputable.is_pi.comp (fst.comp snd.to_unary₁)) _),
      { refine (rcomputable₂.to_bool_eq _).comp snd
        (snd.comp (snd.comp snd.to_unary₁)) },
      { refine (rcomputable₂.to_bool_eq _).comp
          (rcomputable.pi_derivative.unpaired3 snd
            (fst.comp (snd.comp snd.to_unary₁))
            (snd.comp fst.to_unary₁)) (rcomputable.const []) } },
    { exact rcomputable₂.list_cons.comp
        (rcomputable₂.list_cons.comp (fst.comp snd.to_unary₁)
        (fst.comp (snd.comp snd.to_unary₁)))
        snd },
    { exact snd.comp (snd.comp snd.to_unary₁) } },
  exact this.of_eq (λ μ υ, by {
    induction μ with x μ IH; simp[F, lambda],
    { cases C : υ.nth μ.length with ν; simp[C],
      { simp[F, lambda] at IH, simp[IH] } } })
end

lemma rcomputable.assignment_enc :
  (assignment S : Tree k → list (Tree (k + 1)) → Tree (k + 1) × ℕ) computable₂_in o :=
(omega_ordering_Min_le (S.priority (k + 1)) _ _ (S.effective _).to_rcomp
  (rcomputable₂.list_cons.comp (pair (rcomputable.lambda.comp fst snd) (const 0))
    (list_map
      (pair (rcomputable.list_initial.comp (rcomputable.lambda.comp fst.to_unary₁ snd.to_unary₁) snd)
        (list_length.comp (rcomputable.derivative.unpaired3
          (rcomputable.list_initial.comp (rcomputable.lambda.comp fst.to_unary₁ snd.to_unary₁) snd)
          (fst.to_unary₁) (snd.to_unary₁))))
      (list_filter
        (by {simp, exact is_sigma.comp₂
          (rcomputable.list_initial.comp₂ (rcomputable.lambda.comp fst snd).to_unary₁ succ.to_unary₂) })
        (list_range_r.comp (list_length.comp (rcomputable.lambda.comp fst snd)))))))

lemma rcomputable.up_enc :
  (up S : Tree k → list (Tree (k + 1)) → Tree (k + 1)) computable₂_in o :=
fst.comp rcomputable.assignment_enc

end approx_enc

def up'_enc : Tree k → list (Tree (k + 1))
| []       := []
| (_ :: η) := up'_enc η ++ [approx_enc.up S η (up'_enc η)]

@[simp] lemma up'_enc_length (μ : Tree k) : (up'_enc S μ).length = μ.length :=
by induction μ with ν μ IH; simp[up'_enc]; exact IH

variables {S}
open rcomputable rcomputable₂

lemma rcomputable.up'_enc : (up'_enc S : Tree k → list (Tree (k + 1))) computable_in o :=
begin
  let F : Tree k → list (Tree (k + 1)) := λ μ, list.rec_on μ [] (λ _ η IH, IH ++ [approx_enc.up S η IH]),
  have : F computable_in o,
  { simp[F],
    refine rcomputable.list_rec rcomputable.id' (const []) _,
    exact list_append.comp (snd.comp snd.to_unary₂)
      (list_cons.comp (approx_enc.rcomputable.up_enc.comp (fst.comp snd.to_unary₂) (snd.comp snd.to_unary₂))
      (const [])) },
  exact this.of_eq (λ μ, by {
    induction μ with ν μ IH; simp[F, up'_enc],
    { simp[F] at IH, simp[IH] }  })
end

lemma up_enc_eq_up {μ : Tree k} : ∀ ν : ancestor μ, (S.up'_enc μ).nth ν.index = some (S.up' μ ν) :=
begin
  induction μ with ν μ IH; simp[up'_enc, up' S, -up'_up_consistent],
    {  rintros ⟨σ, lt⟩,simp at lt, contradiction },
    { rintros ⟨σ, lt⟩, simp[up', -up'_up_consistent],
      have : σ = μ ∨ σ ⊂ᵢ μ, from list.is_initial_cons_iff.mp lt,
      rcases this with (rfl | lt),
      { simp[ancestor.index],
        rw [show σ.length = (S.up'_enc σ).length, by simp, list.nth_concat_length],
        simp, refine approx_enc.up_eq S IH },
      { simp[lt, ancestor.index],
        rw [list.nth_append (show list.length σ < (S.up'_enc μ).length, by simp[list.is_initial_length lt])],
        have := IH ⟨σ, lt⟩, simp[ancestor.index] at this, exact this } }
end

@[rcomputability]
theorem rcomputable.up : (up[S] : Tree k → Tree (k + 1)) computable_in o :=
(approx_enc.rcomputable.up_enc.comp id' rcomputable.up'_enc).of_eq
(λ μ, approx_enc.up_eq S up_enc_eq_up)

@[rcomputability]
theorem rcomputable.lambda : (λ[S] : Tree k → Tree (k + 1)) computable_in o :=
by { have : (λ μ : Tree k, approx_enc.lambda μ (S.up'_enc μ)) computable_in o,
       from approx_enc.rcomputable.lambda.comp id' rcomputable.up'_enc,
     exact this.of_eq (λ μ, approx_enc.lambda_eq up_enc_eq_up) }

lemma rcomputable.Tree'_weight_aux {k : ℕ} :
  (Tree'.weight_aux : Tree' k → ℕ) computable_in o :=
begin
  induction k with k IH,
  { exact (id'.cond (const 1) (const 0)).of_eq (λ μ, by cases μ; simp[Tree'.weight_aux]) },
  { exact list_weight_of IH }
end

@[rcomputability]
lemma rcomputable.Tree_weight {k : ℕ} :
  (Tree.weight : Tree k → ℕ) computable_in o :=
begin
  induction k with k IH,
  { exact rcomputable.Tree'_weight_aux },
  { let F : Tree (k + 1) → ℕ := λ μ, list.rec_on μ 0 (λ ν _ _, ν.weight_aux + 1),
    have : F computable_in o,
    { simp[F], refine rcomputable.list_rec id (const 0)
      (nat_add.comp (rcomputable.Tree'_weight_aux.comp fst.to_unary₂) (const 1)) },
    exact this.of_eq (λ μ, by cases μ; simp[F, Tree.weight]) }
end

end strategy


example : Id Nat := do
  let x ← if true then
    pure 1
  else
    pure 2
  pure x


import Lean
import Crypto.Util

open Lean Elab Tactic Meta

namespace Crypto

/-- Return true iff `constName` is the a non-recursive inductive datatype without indices
  that has only one constructor. If `includeProp` is false, we also check that the datatype is
  not `Prop` or `Sort*` -/
def isVeryStructureLike (env : Environment) (constName : Name) (includeProp := true) : Bool :=
  match env.find? constName with
  | some d@(ConstantInfo.inductInfo { isRec := false, ctors := [ctor], numIndices := 0, .. }) =>
    includeProp || d.toConstantVal.type.getForallBody.level!.isASucc
  | _ => false

/-- Good names for new hypotheses when casing on a variable with name `nm` and type `constName`. -/
def giveNames (env : Environment) (constName nm : Name) : Array Name :=
  match getStructureInfo? env constName with
  | some p => p.fieldNames.map λ s => nm.appendAfter ("_" ++ s.toString)
  | _ => if constName == `Exists then #[nm.appendAfter "_val", nm.appendAfter "_prop"] else #[]

/- the data we record for each field -/
structure FieldData where
(decl : LocalDecl)
(fvar : Expr)
(type : Expr)
(depends : NameSet)
(isProp : Bool)
deriving Inhabited

/- additionally an expression that gives us the translation to another field -/
structure FieldMapping extends FieldData where
(tgt : Option Expr)
deriving Inhabited

structure Context where
(target : Array FieldData)
deriving Inhabited

structure State where
(mapping : Array FieldMapping)
deriving Inhabited

open Std.Format

instance : ToFormat NameSet :=
⟨λ x => format x.toList⟩

instance : ToFormat FieldData :=
⟨λ ⟨a, b, c, d, e⟩ => group (nest 1 (format "⟨"  ++ format a ++ format "," ++ line ++ format b ++
format "," ++ line ++ format c ++ format "," ++ line ++ format d ++ format "," ++ line ++ format e
++ format "⟩"))⟩

namespace FieldData

def name (fields : FieldData) : Name :=
fields.decl.userName.head!

def toFieldMapping (fields : FieldData) : FieldMapping :=
{ toFieldData := fields, tgt := none }

end FieldData

namespace FieldMapping
def update (field : FieldMapping) (newM : Option Expr) : FieldMapping :=
if field.tgt.isNone then { field with tgt := newM } else field

def updateM (field : FieldMapping) (tac : MetaM (Option Expr)) : MetaM FieldMapping :=
if field.tgt.isNone then do
  let tgt ← tac
  return { field with tgt := tgt }
else
  return field

end FieldMapping

def ppFieldData (x : FieldData) : MetaM Format :=
do return group (nest 1 (format "⟨"  ++
format x.name ++ format "," ++ line ++
format (← Meta.ppExpr x.fvar) ++ format "," ++ line ++
format (← Meta.ppExpr x.type) ++ format "," ++ line ++
format (← x.depends.toList.mapM λ e => Meta.ppExpr (mkFVar ⟨e⟩)) ++ format "," ++ line ++
format x.isProp ++ format "⟩"))

/-- make a field mapping with no connections. -/
def mkState (fields1 : Array FieldData) : State :=
{ mapping := fields1.map (·.toFieldMapping) }

namespace State

def done (st : State) : Bool :=
st.mapping.all (·.tgt.isSome)

def update (st : State) (f : FieldData → Option Expr) : State :=
{ mapping := st.mapping.map λ info => info.update (f info.toFieldData) }

def updateM (st : State) (f : FieldData → MetaM (Option Expr)) : MetaM State := do
  let fieldMapping ← st.mapping.mapM λ info => info.updateM (f info.toFieldData)
  return { mapping := fieldMapping }

def getDataMapping (st : State) : Array (Expr × Expr) :=
st.mapping.filterMap λ map => match map.tgt with
  | none => none
  | some e => if map.isProp then none else some (map.fvar, e)

def getMapping (st : State) : Array (Expr × Expr) :=
st.mapping.filterMap λ map => match map.tgt with
  | none => none
  | some e => some (map.fvar, e)

def missing (st : State) : Array FieldData :=
st.mapping.filterMap λ info => if info.tgt.isNone then some info.toFieldData else none

def missingData (st : State) : Array FieldData :=
st.mapping.filterMap λ info =>
  if info.tgt.isNone && !info.isProp then some info.toFieldData else none

def traceMapping (st : State) : MetaM (Array Format) :=
st.mapping.mapM λ info : FieldMapping =>
  if info.tgt.isSome then Meta.ppExpr info.tgt.get! else return Format.nil

end State

namespace Meta

def fieldDataofCaseGoals (l : Array CasesSubgoal) : MetaM (MVarId × Array FieldData) := do
  let casegoal := l.get! 0
  let mvarId := casegoal.mvarId
  withMVarContext mvarId do
  let lctx ← getLCtx
  let fieldExprs := casegoal.fields
  let fields := fieldExprs.map Expr.fvarId!
  let ldecls := fields.map λ e => lctx.fvarIdToDecl.find! e
  let axiom_fields ← fieldExprs.mapM isProof
  let types ← fieldExprs.mapM inferType
  let depends := types.map λ tp => tp.ListFvarIds
  let fieldData := ldecls.zipWith5 FieldData.mk fieldExprs types depends axiom_fields
  return (mvarId, fieldData)

def updateFieldData (l : Array CasesSubgoal) (fields : Array FieldData) :
  MetaM (Array FieldData) := do
  let casegoal := l.get! 0
  let mvarId := casegoal.mvarId
  let fieldData ← withMVarContext mvarId $ fields.mapM λ info =>
    match casegoal.subst.find? info.fvar.fvarId! with
    | (some e) => do
      let lctx ← getLCtx
      let id := e.fvarId!
      let ldecl := lctx.fvarIdToDecl.find! id
      let t ← inferType e
      let depends := NameSet.empty -- todo
      return ⟨ldecl, e, t, depends, info.isProp⟩
    | none => return info
  return fieldData

def AddFieldsToContext (mvarId : MVarId) (nm : Name) (us : List Level) (args : Array Expr) :
  MetaM (MVarId × MVarId × Array FieldData) := do
  let env ← getEnv
  let d ← env.find? nm
  let true ← isStructureLike env nm
  let eStr ← mkAppN (mkConst nm us) args
  let (h, mvarId, m2) ← assertm mvarId `h eStr
  let l ← cases mvarId h
  let (mvarId, fieldData) ← fieldDataofCaseGoals l
  return (mvarId, m2, fieldData)

/-- map the data fields to data fields of the same name. -/
def trivialMapping (st : State) (ctx : Context) : State :=
st.update $ λ info =>
  if info.isProp then none else
    ctx.target.findSome? λ info' => if info.name == info'.name then some info'.fvar else none

/-- map the data fields to data fields with the same type, if a unique such data field exists. -/
def uniqueMapping (st : State) (ctx : Context) : MetaM State :=
st.updateM $ λ info => if info.isProp then return none else do
  let sources ← st.mapping.filterM λ info' => isDefEq info.type info'.type
  let targets ← ctx.target.filterM λ info' => isDefEq info.type info'.type
  return (if sources.size = 1 ∧ targets.size = 1 then some (targets.get! 0).fvar else none)

set_option pp.all true
partial def caseOnStructures (mvarId : MVarId) (st : Array FieldData) (ctx : Context)
  (includeProp := true) :
  MetaM (MVarId × Array FieldData) := do
  let env ← getEnv
  let info? := st.find? λ info =>
    info.type.getAppFn.constName?.any (isVeryStructureLike env · includeProp)
  match info? with
  | some info => do
    let rest := st.filter λ info' => info'.fvar.fvarId! != info.fvar.fvarId!
    let str := info.type.getAppFn.constName!
    -- todo: there seems to be a bug with the given names when transitively extending structures. Do we need to skip fields?
    -- IO.println (giveNames env str info.name)
    let l ← cases mvarId info.fvar.fvarId! #[⟨false, (giveNames env str info.name).toList⟩]
    let (mvarId, fieldData) ← fieldDataofCaseGoals l
    let rest ← updateFieldData l rest
    caseOnStructures mvarId (rest ++ fieldData) ctx includeProp
  | none =>
    return (mvarId, st)

/-- Find which axioms of the first structure that occur in the second structure. -/
def matchingAxioms (st : State) (ctx : Context) : MetaM State := do
  let targetTypes : Array (Expr × Expr) := ctx.target.filterMap λ info =>
    if info.isProp then (info.fvar, info.type) else none
  st.updateM λ info => do
    let e := info.type.instantiateFVars st.getDataMapping
    match (← targetTypes.findM? λ (e', t) => isDefEq e t) with
    | some (e, t) => return (some e)
    | none => return none

/-- some copy-pasted simp code -/
def getPropHyps : MetaM (Array FVarId) := do
  let mut result := #[]
  for localDecl in (← getLCtx) do
    unless localDecl.isAuxDecl do
      if (← isProp localDecl.type) then
        result := result.push localDecl.fvarId
  return result

/-- some mostly copy-pasted simp code -/
def mkSimpContext (simpOnly := false) (starArg := true) : MetaM Simp.Context := do
  let ctx : Simp.Context :=
  { config      := {}
    simpLemmas  := if simpOnly then {} else (← getSimpLemmas)
    congrLemmas := (← getCongrLemmas) }
  if !starArg then
    return ctx
  else
    let hs ← getPropHyps
    let mut ctx := ctx
    for h in hs do
      let localDecl ← getLocalDecl h
      let fvarId := localDecl.fvarId
      let proof  := localDecl.toExpr
      let id     ← mkFreshUserName `h
      let simpLemmas ← ctx.simpLemmas.add #[] proof (name? := id)
      ctx := { ctx with simpLemmas }
    return ctx

/-- The tactic we use to automatically prove axioms. -/
def currentAutomation (mvarId : MVarId) : MetaM Unit := do
let newgoal ← simpTarget mvarId (← mkSimpContext false)

-- match (← simpTarget mvarId (← mkSimpContext false)) with
-- | some x => IO.println "failure!"
-- | none => IO.println "success!"

/-- Tries to prove `e` in the local context, returns the proof if successful. -/
def tryToProve (mvarId : MVarId) (tac : MVarId → MetaM Unit) (e : Expr) : MetaM (Option Expr) :=
withoutModifyingState do
  let (fvar, mvarId, m2) ← assertm mvarId `h e
  try
    tac m2
    -- IO.println s!"is assigned: {← isExprMVarAssigned m2}"
    let some e ← getExprMVarAssignment? m2 | return none
    let e ← instantiateMVars e
    if (← e.hasExprMVar) then return none else return some e
  catch err =>
    return none

/-- Tests whether nm1 is a subclass of nm1. Currently the data fields must have the same Name for
this tactic to work. -/
def isSubclass (mvarId : MVarId) (nm1 nm2 : Name) (trace := false) :
  MetaM (MVarId × MVarId × MVarId × State) := do
  let u := mkLevelParam `u
  let (M, mvarId) ← asserti mvarId `M (mkSort (mkLevelSucc u)) (mkConst `PUnit [mkLevelSucc u])
  let (mvarId, m2, fields2) ← AddFieldsToContext mvarId nm2 [u] #[mkFVar M]
  let (mvarId, fields2) ← caseOnStructures mvarId fields2 ⟨#[]⟩ false
  let ctx : Context := ⟨fields2⟩
  if trace then IO.println s!"cases on fields class 2: {← ctx.target.map (·.name)}"
  let (mvarId, m1, fields1) ← AddFieldsToContext mvarId nm1 [u] #[mkFVar M]
  let (mvarId, fields1) ← caseOnStructures mvarId fields1 ctx
  let st := mkState fields1
  withMVarContext mvarId do
  let st ← uniqueMapping st ctx
  let st := trivialMapping st ctx
  if trace then IO.println s!"map of data: {← st.traceMapping}"
  let (mvarId, fields2) ← caseOnStructures mvarId fields2 ⟨#[]⟩ -- is this dangerous?
  let ctx : Context := ⟨fields2⟩
  withMVarContext mvarId do
  let ctx : Context := ⟨fields2⟩
  let st ← matchingAxioms st ctx
  let st ← st.updateM λ info => if !info.isProp then return none else
    tryToProve mvarId currentAutomation (info.type.instantiateFVars st.getDataMapping)
  if trace then IO.println s!"map: {← st.traceMapping}"
  return (mvarId, m1, m2, st)

end Meta

syntax (name := guardHyp) "guardHyp " (" : " term)? : tactic
@[tactic guardHyp] def evalGuardHyp : Lean.Elab.Tactic.Tactic := fun stx =>
  match stx with
  | `(tactic| guardHyp $[: $ty]?) => do
    return ()
  | _ => throwUnsupportedSyntax

def isSubclassTac (nm1 nm2 : Name) (trace := false) : TacticM Unit := withMainContext do
let mvarId ← getMainGoal
let (mvarId, m1, m2, st) ← Meta.isSubclass mvarId nm1 nm2 trace
if st.done then IO.println s!"{nm1} is a subclass of {nm2}"
else IO.println s!"Cannot construct the following fields of {nm1} from {nm2}:
{st.missing.map (·.name)}."
let l ← getUnsolvedGoals
setGoals (mvarId::m1::m2::l)

def cryptomorphicTac (nm1 nm2 : Name) (trace := false) : TacticM Unit := withMainContext do
let mvarId ← getMainGoal
let (mvarId, m1, m2, st1) ← Meta.isSubclass mvarId nm1 nm2 trace
let (mvarId, m3, m4, st2) ← Meta.isSubclass mvarId nm2 nm1 trace
if st1.done && st2.done then IO.println s!"{nm1} and {nm2} are cryptomorphic"
else do
  IO.println s!"Cannot prove that {nm1} and {nm2} are cryptomorphic"
  if !st1.done then
    IO.println s!"{nm2} → {nm1}: cannot construct {st1.missing.map (·.name)}"
  if !st2.done then
    IO.println s!"{nm1} → {nm2}: Cannot construct {st2.missing.map (·.name)}"
let l ← getUnsolvedGoals
setGoals (mvarId::m1::m2::m3::m4::l)

syntax (name := isSubclass) "isSubclass " ident ident : tactic
syntax (name := isSubclassE) "isSubclass! " ident ident : tactic
@[tactic «isSubclass»] def evalIsSubclass : Tactic := fun stx =>
  match stx with
  | `(tactic| isSubclass $nm1 $nm2) => withoutModifyingState $ isSubclassTac nm1.getId nm2.getId
  | _ => throwUnsupportedSyntax
@[tactic «isSubclassE»] def evalIsSubclassE : Tactic := fun stx =>
  match stx with
  | `(tactic| isSubclass! $nm1 $nm2) => isSubclassTac nm1.getId nm2.getId true
  | _ => throwUnsupportedSyntax

syntax (name := cryptomorphic) "cryptomorphic " ident ident : tactic
@[tactic «cryptomorphic»] def evalCryptomorphic : Tactic := fun stx =>
  match stx with
  | `(tactic| cryptomorphic $nm1 $nm2) => withoutModifyingState $ cryptomorphicTac nm1.getId nm2.getId
  | _ => throwUnsupportedSyntax

end Crypto
open Crypto

/-!
## Demo and tests

We define some notions of commutative Monoids,
(1) right-unital
(2) right-unital, and then has a superfluous axiom `1 * 1 = 1`
(3) both left-unital and right-unital.
(4) denoted additively
(5) with a unit given by an existential quantifier (`∃ one, ...`)
(6) by extending a `Monoid` structure.
-/

class Zero (α : Type u) where
  zero : α

instance [Zero α] : OfNat α (nat_lit 0) where
  ofNat := Zero.zero

class One (α : Type u) where
  one : α

instance [One α] : OfNat α (nat_lit 1) where
  ofNat := One.one

class CommMonoid1 (M : Type _) extends Mul M, One M :=
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_comm : ∀ x y : M, x * y = y * x)
(mul_one : ∀ x : M, x * 1 = x)

class CommMonoid2 (M : Type _) extends Mul M, One M :=
(mul_one : ∀ x : M, x * 1 = x)
(one_mul_one : 1 * 1 = 1)
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_comm : ∀ x y : M, x * y = y * x)

class CommMonoid3 (M : Type _) extends Mul M, One M :=
(one_mul : ∀ x : M, 1 * x = x)
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_comm : ∀ x y : M, x * y = y * x)

class CommMonoid4 (M : Type _) extends Add M, Zero M :=
(add_assoc : ∀ x y z : M, (x + y) + z = x + (y + z))
(add_comm : ∀ x y : M, x + y = y + x)
(add_zero : ∀ x : M, x + 0 = x)

class CommMonoid5 (M : Type _) extends Mul M :=
(mul_axioms : (∀ x y z : M, (x * y) * z = x * (y * z)) ∧ (∀ x y : M, x * y = y * x))
(exists_one : ∃ one : M, ∀ x : M, x * one = x)

class Monoid (M : Type _) extends Mul M, One M :=
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_one : ∀ x : M, x * 1 = x)

class CommMonoid6 (M : Type _) extends Monoid M :=
(mul_comm : ∀ x y : M, x * y = y * x)

open CommMonoid1

-- example (M : Type _) [CommMonoid1 M] (x : M) : 1 * x = 1 := by
--   simp [mul_comm]

example : True := by
  cryptomorphic CommMonoid1 CommMonoid2 -- yes
  cryptomorphic CommMonoid1 CommMonoid3 -- mul_one, one_mul [need better automation]
  cryptomorphic CommMonoid1 CommMonoid4 -- yes
  cryptomorphic CommMonoid1 CommMonoid5 -- one, mul_one [need support for existentials]
  cryptomorphic CommMonoid1 CommMonoid6 -- yes
  trivial

/-! As a sanity check: we cannot prove commutativity on an arbitrary Monoid. -/

class MyMonoid (M : Type _) extends Mul M :=
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(one : M)
(mul_one : ∀ x : M, x * one = x)

example : True := by
  cryptomorphic MyMonoid CommMonoid1 -- missing (expected): mul_comm
  trivial

/-!
If two data fields have the same type, we try to get the one with the same name.
In the future we could look at which choice will make more axioms overlap.
-/

class MyAlmostRing (M : Type _) extends Mul M :=
(add : M → M → M)
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_comm : ∀ x y : M, x * y = y * x)
(one : M)
(mul_one : ∀ x : M, x * one = x)

example : True := by
  cryptomorphic CommMonoid1 MyAlmostRing -- missing (expected): add
  trivial

/-! Test which "fields" are missing when inside nested structures. -/

class CommMonoidBundled1 (M : Type _) extends Mul M :=
(mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z))
(mul_comm : ∀ x y : M, x * y = y * x)
(one_axioms : ∃ one : M, (∀ x : M, x * one = x) ∧ (∀ x : M, x * x = one))

class CommMonoidBundled2 (M : Type _) :=
(data : (M → M → M) × M)
(mul_assoc : ∀ x y z : M, data.1 (data.1 x y) z = data.1 x (data.1 y z))
(mul_comm : ∀ x y : M, data.1 x y = data.1 y x)
(mul_one : ∀ x : M, data.1 x data.2 = x)

example : True := by
  cryptomorphic CommMonoidBundled1 CommMonoid1 -- missing (expected): one_axioms_prop_right
  -- missing: one, one_mul [need support for existentials]
  cryptomorphic CommMonoidBundled2 CommMonoid1 -- yesss
  trivial


import Mathlib.Tactic.Spread

class Foo (α : Type) where
  bar : True

class Something where
  bar : True

instance : Something where
  bar := by trivial

instance : Foo α where
  __ := instSomething -- include fields from `instSomething`

example : Foo α := {
  __ := instSomething -- include fields from `instSomething`
}