/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis

! This file was ported from Lean 3 source module tactic.norm_cast
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Converter.Interactive
import Mathbin.Tactic.Hint

/-!
# A tactic for normalizing casts inside expressions

This tactic normalizes casts inside expressions.
It can be thought of as a call to the simplifier with a specific set of lemmas to
move casts upwards in the expression.
It has special handling of numerals and a simple heuristic to help moving
casts "past" binary operators.
Contrary to simp, it should be safe to use as a non-terminating tactic.

The algorithm implemented here is described in the paper
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.

## Important definitions
* `tactic.interactive.norm_cast`
* `tactic.interactive.push_cast`
* `tactic.interactive.exact_mod_cast`
* `tactic.interactive.apply_mod_cast`
* `tactic.interactive.rw_mod_cast`
* `tactic.interactive.assumption_mod_cast`
-/

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
namespace Tactic

/-- Runs `mk_instance` with a time limit.

This is a work around to the fact that in some cases
mk_instance times out instead of failing,
for example: `has_lift_t ℤ ℕ`

`mk_instance_fast` is used when we assume the type class search
should end instantly.
-/
unsafe def mk_instance_fast (e : expr) (timeout := 1000) : tactic expr :=
  try_for timeout (mk_instance e)
#align tactic.mk_instance_fast tactic.mk_instance_fast

end Tactic

namespace NormCast

open Tactic Expr

initialize
  registerTraceClass.1 `norm_cast

/-- Output a trace message if `trace.norm_cast` is enabled.
-/
unsafe def trace_norm_cast {α} [has_to_tactic_format α] (msg : String) (a : α) : tactic Unit :=
  when_tracing `norm_cast do
    let a ← pp a
    trace ("[norm_cast] " ++ msg ++ a : format)
#align norm_cast.trace_norm_cast norm_cast.trace_norm_cast

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment
       "/--"
       "The `push_cast` simp attribute uses `norm_cast` lemmas\nto move casts toward the leaf nodes of the expression. -/")]
     "register_simp_attr"
     `push_cast)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/--
    The `push_cast` simp attribute uses `norm_cast` lemmas
    to move casts toward the leaf nodes of the expression. -/
  register_simp_attr
  push_cast

/-- `label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
inductive Label
  | elim : label
  | move : label
  | squash : label
  deriving DecidableEq, has_reflect, Inhabited
#align norm_cast.label NormCast.Label

namespace Label

/-- Convert `label` into `string`. -/
protected def toString : Label → String
  | elim => "elim"
  | move => "move"
  | squash => "squash"
#align norm_cast.label.to_string NormCast.Label.toString

instance : ToString Label :=
  ⟨Label.toString⟩

instance : Repr Label :=
  ⟨Label.toString⟩

unsafe instance : has_to_format Label :=
  ⟨fun l => l.toString⟩

/-- Convert `string` into `label`. -/
def ofString : String → Option Label
  | "elim" => some elim
  | "move" => some move
  | "squash" => some squash
  | _ => none
#align norm_cast.label.of_string NormCast.Label.ofString

end Label

open Label

/-- Count how many coercions are at the top of the expression. -/
unsafe def count_head_coes : expr → ℕ
  | q(coe $(e)) => count_head_coes e + 1
  | q(coeSort $(e)) => count_head_coes e + 1
  | q(coeFn $(e)) => count_head_coes e + 1
  | _ => 0
#align norm_cast.count_head_coes norm_cast.count_head_coes

/-- Count how many coercions are inside the expression, including the top ones. -/
unsafe def count_coes : expr → tactic ℕ
  | q(coe $(e)) => (· + 1) <$> count_coes e
  | q(coeSort $(e)) => (· + 1) <$> count_coes e
  | q(coeFn $(e)) => (· + 1) <$> count_coes e
  | app q(coeFn $(e)) x => (· + ·) <$> count_coes x <*> (· + 1) <$> count_coes e
  | expr.lam n bi t e => do
    let l ← mk_local' n bi t
    count_coes <| e l
  | e => do
    let as ← e.get_simp_args
    List.sum <$> as count_coes
#align norm_cast.count_coes norm_cast.count_coes

/-- Count how many coercions are inside the expression, excluding the top ones. -/
private unsafe def count_internal_coes (e : expr) : tactic ℕ := do
  let ncoes ← count_coes e
  pure <| ncoes - count_head_coes e
#align norm_cast.count_internal_coes norm_cast.count_internal_coes

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Classifies a declaration of type `ty` as a `norm_cast` rule.
      -/
    unsafe
  def
    classify_type
    ( ty : expr ) : tactic Label
    :=
      do
        let ( _ , ty ) ← open_pis ty
          let
            ( lhs , rhs )
              ←
              match
                ty
                with
                | q( $ ( lhs ) = $ ( rhs ) ) => pure ( lhs , rhs )
                  | q( $ ( lhs ) ↔ $ ( rhs ) ) => pure ( lhs , rhs )
                  | _ => fail "norm_cast: lemma must be = or ↔"
          let lhs_coes ← count_coes lhs
          when ( lhs_coes = 0 )
            <|
            fail "norm_cast: badly shaped lemma, lhs must contain at least one coe"
          let lhs_head_coes := count_head_coes lhs
          let lhs_internal_coes ← count_internal_coes lhs
          let rhs_head_coes := count_head_coes rhs
          let rhs_internal_coes ← count_internal_coes rhs
          if
            lhs_head_coes = 0
            then
            return elim
            else
            if
              lhs_head_coes = 1
              then
              do
                when ( rhs_head_coes ≠ 0 )
                    <|
                    fail "norm_cast: badly shaped lemma, rhs can't start with coe"
                  if rhs_internal_coes = 0 then return squash else return move
              else
              if
                rhs_head_coes < lhs_head_coes
                then
                do return squash
                else
                do
                  fail
                    "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs"
#align norm_cast.classify_type norm_cast.classify_type

/-- The cache for `norm_cast` attribute stores three `simp_lemma` objects. -/
unsafe structure norm_cast_cache where
  up : simp_lemmas
  down : simp_lemmas
  squash : simp_lemmas
#align norm_cast.norm_cast_cache norm_cast.norm_cast_cache

/-- Empty `norm_cast_cache`. -/
unsafe def empty_cache : norm_cast_cache
    where
  up := simp_lemmas.mk
  down := simp_lemmas.mk
  squash := simp_lemmas.mk
#align norm_cast.empty_cache norm_cast.empty_cache

unsafe instance : Inhabited norm_cast_cache :=
  ⟨empty_cache⟩

/-- `add_elim cache e` adds `e` as an `elim` lemma to `cache`. -/
unsafe def add_elim (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_up ← cache.up.add e
  return
      { up := new_up
        down := cache
        squash := cache }
#align norm_cast.add_elim norm_cast.add_elim

/-- `add_move cache e` adds `e` as a `move` lemma to `cache`. -/
unsafe def add_move (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_up ← cache.up.add e true
  let new_down ← cache.down.add e
  return
      { up := new_up
        down := new_down
        squash := cache }
#align norm_cast.add_move norm_cast.add_move

/-- `add_squash cache e` adds `e` as an `squash` lemma to `cache`. -/
unsafe def add_squash (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_squash ← cache.squash.add e
  let new_down ← cache.down.add e
  return
      { up := cache
        down := new_down
        squash := new_squash }
#align norm_cast.add_squash norm_cast.add_squash

/-- The type of the `norm_cast` attribute.
The optional label is used to overwrite the classifier.
-/
unsafe def norm_cast_attr_ty : Type :=
  user_attribute norm_cast_cache (Option Label)
#align norm_cast.norm_cast_attr_ty norm_cast.norm_cast_attr_ty

/-- Efficient getter for the `@[norm_cast]` attribute parameter that does not call `eval_expr`.

See Note [user attribute parameters].
-/
unsafe def get_label_param (attr : norm_cast_attr_ty) (decl : Name) : tactic (Option Label) := do
  let p ← attr.get_param_untyped decl
  match p with
    | q(none) => pure none
    | q(some Label.elim) => pure label.elim
    | q(some Label.move) => pure label.move
    | q(some Label.squash) => pure label.squash
    | _ => fail p
#align norm_cast.get_label_param norm_cast.get_label_param

/--
`add_lemma cache decl` infers the proper `norm_cast` attribute for `decl` and adds it to `cache`.
-/
unsafe def add_lemma (attr : norm_cast_attr_ty) (cache : norm_cast_cache) (decl : Name) :
    tactic norm_cast_cache := do
  let e ← mk_const decl
  let param ← get_label_param attr decl
  let l ← param <|> infer_type e >>= classify_type
  match l with
    | elim => add_elim cache e
    | move => add_move cache e
    | squash => add_squash cache e
#align norm_cast.add_lemma norm_cast.add_lemma

-- special lemmas to handle the ≥, > and ≠ operators
private theorem ge_from_le {α} [LE α] : ∀ x y : α, x ≥ y ↔ y ≤ x := fun _ _ => Iff.rfl
#align norm_cast.ge_from_le norm_cast.ge_from_le

private theorem gt_from_lt {α} [LT α] : ∀ x y : α, x > y ↔ y < x := fun _ _ => Iff.rfl
#align norm_cast.gt_from_lt norm_cast.gt_from_lt

private theorem ne_from_not_eq {α} : ∀ x y : α, x ≠ y ↔ ¬x = y := fun _ _ => Iff.rfl
#align norm_cast.ne_from_not_eq norm_cast.ne_from_not_eq

/-- `mk_cache names` creates a `norm_cast_cache`. It infers the proper `norm_cast` attributes
for names in `names`, and collects the lemmas attributed with specific `norm_cast` attributes.
-/
unsafe def mk_cache (attr : Thunk norm_cast_attr_ty) (names : List Name) : tactic norm_cast_cache :=
  do
  let cache
    ←-- names has the declarations in reverse order
          names.foldrM
        (fun name cache => add_lemma (attr ()) cache Name) empty_cache
  let--some special lemmas to handle binary relations
  up := cache.up
  let up ← up.add_simp `` ge_from_le
  let up ← up.add_simp `` gt_from_lt
  let up ← up.add_simp `` ne_from_not_eq
  let down := cache.down
  let down ← down.add_simp `` coe_coe
  pure {
        up
        down
        squash := cache }
#align norm_cast.mk_cache norm_cast.mk_cache

/-- The `norm_cast` attribute.
-/
@[user_attribute]
unsafe def norm_cast_attr : user_attribute norm_cast_cache (Option Label)
    where
  Name := `norm_cast
  descr := "attribute for norm_cast"
  parser :=
    (do
        let some l ← (Label.ofString ∘ toString) <$> ident
        return l) <|>
      return none
  after_set :=
    some fun decl prio persistent => do
      let param ← get_label_param norm_cast_attr decl
      match param with
        | some l => when (l ≠ elim) <| simp_attr.push_cast decl () tt prio
        | none => do
          let e ← mk_const decl
          let ty ← infer_type e
          let l ← classify_type ty
          norm_cast_attr decl l persistent prio
  before_unset := some fun _ _ => tactic.skip
  cache_cfg :=
    { mk_cache := mk_cache norm_cast_attr
      dependencies := [] }
#align norm_cast.norm_cast_attr norm_cast.norm_cast_attr

/-- Classify a declaration as a `norm_cast` rule. -/
unsafe def make_guess (decl : Name) : tactic Label := do
  let e ← mk_const decl
  let ty ← infer_type e
  classify_type ty
#align norm_cast.make_guess norm_cast.make_guess

/-- Gets the `norm_cast` classification label for a declaration. Applies the
override specified on the attribute, if necessary.
-/
unsafe def get_label (decl : Name) : tactic Label := do
  let param ← get_label_param norm_cast_attr decl
  param <|> make_guess decl
#align norm_cast.get_label norm_cast.get_label

end NormCast

namespace Tactic.Interactive

open NormCast

/-- `push_cast` rewrites the expression to move casts toward the leaf nodes.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
Equivalent to `simp only with push_cast`.
Can also be used at hypotheses.

`push_cast` can also be used at hypotheses and with extra simp rules.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```
-/
unsafe def push_cast (hs : parse tactic.simp_arg_list) (l : parse location) : tactic Unit :=
  tactic.interactive.simp none none true hs [`push_cast] l { discharger := tactic.assumption }
#align tactic.interactive.push_cast tactic.interactive.push_cast

end Tactic.Interactive

namespace NormCast

open Tactic Expr

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Prove `a = b` using the given simp set. -/ unsafe
  def
    prove_eq_using
    ( s : simp_lemmas ) ( a b : expr ) : tactic expr
    :=
      do
        let ( a' , a_a' , _ ) ← simplify s [ ] a { failIfUnchanged := false }
          let ( b' , b_b' , _ ) ← simplify s [ ] b { failIfUnchanged := false }
          on_exception ( trace_norm_cast "failed: " ( to_expr ` `( $ ( a' ) = $ ( b' ) ) >>= pp ) )
            <|
            is_def_eq a' b' reducible
          let b'_b ← mk_eq_symm b_b'
          mk_eq_trans a_a' b'_b
#align norm_cast.prove_eq_using norm_cast.prove_eq_using

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Prove `a = b` by simplifying using move and squash lemmas. -/ unsafe
  def
    prove_eq_using_down
    ( a b : expr ) : tactic expr
    :=
      do
        let cache ← norm_cast_attr . get_cache
          trace_norm_cast "proving: " ( to_expr ` `( $ ( a ) = $ ( b ) ) >>= pp )
          prove_eq_using cache a b
#align norm_cast.prove_eq_using_down norm_cast.prove_eq_using_down

/-- This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
unsafe def splitting_procedure : expr → tactic (expr × expr)
  | app (app op x) y =>
    (do
        let q(@coe $(α) $(δ) $(coe1) $(xx)) ← return x
        let q(@coe $(β) $(γ) $(coe2) $(yy)) ← return y
        success_if_fail <| is_def_eq α β
        is_def_eq δ γ
        (do
              let coe3 ← mk_app `has_lift_t [α, β] >>= mk_instance_fast
              let new_x ← to_expr ``(@coe $(β) $(δ) $(coe2) (@coe $(α) $(β) $(coe3) $(xx)))
              let new_e := app (app op new_x) y
              let eq_x ← prove_eq_using_down x new_x
              let pr ← mk_congr_arg op eq_x
              let pr ← mk_congr_fun pr y
              return (new_e, pr)) <|>
            do
            let coe3 ← mk_app `has_lift_t [β, α] >>= mk_instance_fast
            let new_y ← to_expr ``(@coe $(α) $(δ) $(coe1) (@coe $(β) $(α) $(coe3) $(yy)))
            let new_e := app (app op x) new_y
            let eq_y ← prove_eq_using_down y new_y
            let pr ← mk_congr_arg (app op x) eq_y
            return (new_e, pr)) <|>
      (do
          let q(@coe $(α) $(β) $(coe1) $(xx)) ← return x
          let q(@One.one $(β) $(h1)) ← return y
          let h2 ← to_expr ``(One $(α)) >>= mk_instance_fast
          let new_y ← to_expr ``(@coe $(α) $(β) $(coe1) (@One.one $(α) $(h2)))
          let eq_y ← prove_eq_using_down y new_y
          let new_e := app (app op x) new_y
          let pr ← mk_congr_arg (app op x) eq_y
          return (new_e, pr)) <|>
        (do
            let q(@coe $(α) $(β) $(coe1) $(xx)) ← return x
            let q(@Zero.zero $(β) $(h1)) ← return y
            let h2 ← to_expr ``(Zero $(α)) >>= mk_instance_fast
            let new_y ← to_expr ``(@coe $(α) $(β) $(coe1) (@Zero.zero $(α) $(h2)))
            let eq_y ← prove_eq_using_down y new_y
            let new_e := app (app op x) new_y
            let pr ← mk_congr_arg (app op x) eq_y
            return (new_e, pr)) <|>
          (do
              let q(@One.one $(β) $(h1)) ← return x
              let q(@coe $(α) $(β) $(coe1) $(xx)) ← return y
              let h1 ← to_expr ``(One $(α)) >>= mk_instance_fast
              let new_x ← to_expr ``(@coe $(α) $(β) $(coe1) (@One.one $(α) $(h1)))
              let eq_x ← prove_eq_using_down x new_x
              let new_e := app (app op new_x) y
              let pr ← mk_congr_arg (lam `x BinderInfo.default β (app (app op (var 0)) y)) eq_x
              return (new_e, pr)) <|>
            do
            let q(@Zero.zero $(β) $(h1)) ← return x
            let q(@coe $(α) $(β) $(coe1) $(xx)) ← return y
            let h1 ← to_expr ``(Zero $(α)) >>= mk_instance_fast
            let new_x ← to_expr ``(@coe $(α) $(β) $(coe1) (@Zero.zero $(α) $(h1)))
            let eq_x ← prove_eq_using_down x new_x
            let new_e := app (app op new_x) y
            let pr ← mk_congr_arg (lam `x BinderInfo.default β (app (app op (var 0)) y)) eq_x
            return (new_e, pr)
  | _ => failed
#align norm_cast.splitting_procedure norm_cast.splitting_procedure

/-- Discharging function used during simplification in the "squash" step.

TODO: norm_cast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
private unsafe def prove : tactic Unit :=
  assumption
#align norm_cast.prove norm_cast.prove

/-- Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
unsafe def upward_and_elim (s : simp_lemmas) (e : expr) : tactic (expr × expr) :=
  (do
      let r ← condM (is_prop e) (return `iff) (return `eq)
      let (new_e, pr) ← s.rewrite e prove r
      let pr ←
        match r with
          | `iff => mk_app `propext [pr]
          | _ => return pr
      return (new_e, pr)) <|>
    splitting_procedure e
#align norm_cast.upward_and_elim norm_cast.upward_and_elim

/-!
The following auxiliary functions are used to handle numerals.
-/

/-- If possible, rewrite `(n : α)` to `((n : ℕ) : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
unsafe def numeral_to_coe (e : expr) : tactic (expr × expr) := do
  let α ← infer_type e
  success_if_fail <| is_def_eq α q(ℕ)
  let n ← e.toNat
  let h1 ← mk_app `has_lift_t [q(ℕ), α] >>= mk_instance_fast
  let new_e : expr := reflect n
  let new_e ← to_expr ``(@coe ℕ $(α) $(h1) $(new_e))
  let pr ← prove_eq_using_down e new_e
  return (new_e, pr)
#align norm_cast.numeral_to_coe norm_cast.numeral_to_coe

/-- If possible, rewrite `((n : ℕ) : α)` to `(n : α)` where `n` is a numeral.
Returns a pair of the new expression and proof that they are equal.
-/
unsafe def coe_to_numeral (e : expr) : tactic (expr × expr) := do
  let q(@coe ℕ $(α) $(h1) $(e')) ← return e
  let n ← e'.toNat
  -- replace e' by normalized numeral
      is_def_eq
      (reflect n) e' reducible
  let e := e.app_fn (reflect n)
  let new_e ← expr.of_nat α n
  let pr ← prove_eq_using_down e new_e
  return (new_e, pr)
#align norm_cast.coe_to_numeral norm_cast.coe_to_numeral

/-- A local variant on `simplify_top_down`. -/
private unsafe def simplify_top_down' {α} (a : α) (pre : α → expr → tactic (α × expr × expr))
    (e : expr) (cfg : SimpConfig := { }) : tactic (α × expr × expr) :=
  ext_simplify_core a cfg simp_lemmas.mk (fun _ => failed)
    (fun a _ _ _ e => do
      let (new_a, new_e, pr) ← pre a e
      guard ¬new_e == e
      return (new_a, new_e, some pr, ff))
    (fun _ _ _ _ _ => failed) `eq e
#align norm_cast.simplify_top_down' norm_cast.simplify_top_down'

/-- The core simplification routine of `norm_cast`.
-/
unsafe def derive (e : expr) : tactic (expr × expr) := do
  let cache ← norm_cast_attr.get_cache
  let e ← instantiate_mvars e
  let cfg : SimpConfig :=
    { zeta := false
      beta := false
      eta := false
      proj := false
      iota := false
      iotaEqn := false
      failIfUnchanged := false }
  let e0 := e
  let-- step 1: pre-processing of numerals
    ((), e1, pr1)
    ← simplify_top_down' () (fun _ e => Prod.mk () <$> numeral_to_coe e) e0 cfg
  trace_norm_cast "after numeral_to_coe: " e1
  let-- step 2: casts are moved upwards and eliminated
    ((), e2, pr2)
    ← simplify_bottom_up () (fun _ e => Prod.mk () <$> upward_and_elim cache.up e) e1 cfg
  trace_norm_cast "after upward_and_elim: " e2
  let-- step 3: casts are squashed
    (e3, pr3, _)
    ← simplify cache.squash [] e2 cfg
  trace_norm_cast "after squashing: " e3
  let-- step 4: post-processing of numerals
    ((), e4, pr4)
    ← simplify_top_down' () (fun _ e => Prod.mk () <$> coe_to_numeral e) e3 cfg
  trace_norm_cast "after coe_to_numeral: " e4
  let new_e := e4
  guard ¬new_e == e
  let pr ← mk_eq_trans pr1 pr2
  let pr ← mk_eq_trans pr pr3
  let pr ← mk_eq_trans pr pr4
  return (new_e, pr)
#align norm_cast.derive norm_cast.derive

/-- A small variant of `push_cast` suited for non-interactive use.

`derive_push_cast extra_lems e` returns an expression `e'` and a proof that `e = e'`.
-/
unsafe def derive_push_cast (extra_lems : List simp_arg_type) (e : expr) : tactic (expr × expr) :=
  do
  let (s, _) ← mk_simp_set true [`push_cast] extra_lems
  let (e, prf, _) ←
    simplify (s.eraseₓ [`nat.cast_succ]) [] e { failIfUnchanged := false } `eq tactic.assumption
  return (e, prf)
#align norm_cast.derive_push_cast norm_cast.derive_push_cast

end NormCast

namespace Tactic

open Expr NormCast

/-- `aux_mod_cast e` runs `norm_cast` on `e` and returns the result. If `include_goal` is true, it
also normalizes the goal. -/
unsafe def aux_mod_cast (e : expr) (include_goal : Bool := true) : tactic expr :=
  match e with
  | local_const _ lc _ _ => do
    let e ← get_local lc
    replace_at derive [e] include_goal
    get_local lc
  | e => do
    let t ← infer_type e
    let e ← assertv `this t e
    replace_at derive [e] include_goal
    get_local `this
#align tactic.aux_mod_cast tactic.aux_mod_cast

/-- `exact_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to use `e` to close the
goal. -/
unsafe def exact_mod_cast (e : expr) : tactic Unit :=
  decorate_error "exact_mod_cast failed:" do
    let new_e ← aux_mod_cast e
    exact new_e
#align tactic.exact_mod_cast tactic.exact_mod_cast

/-- `apply_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to apply `e`. -/
unsafe def apply_mod_cast (e : expr) : tactic (List (Name × expr)) :=
  decorate_error "apply_mod_cast failed:" do
    let new_e ← aux_mod_cast e
    apply new_e
#align tactic.apply_mod_cast tactic.apply_mod_cast

/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
unsafe def assumption_mod_cast : tactic Unit :=
  decorate_error "assumption_mod_cast failed:" do
    let cfg : SimpConfig :=
      { failIfUnchanged := false
        canonizeInstances := false
        canonizeProofs := false
        proj := false }
    replace_at derive [] tt
    let ctx ← local_context
    ctx fun h => aux_mod_cast h ff >>= tactic.exact
#align tactic.assumption_mod_cast tactic.assumption_mod_cast

end Tactic

namespace Tactic.Interactive

open Tactic NormCast

/-- Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily closing the goal.
-/
unsafe def norm_cast (loc : parse location) : tactic Unit := do
  let ns ← loc.get_locals
  let tt ← replace_at derive ns loc.include_goal |
    fail "norm_cast failed to simplify"
  when loc <| try tactic.reflexivity
  when loc <| try tactic.triv
  when ¬ns <| try tactic.contradiction
#align tactic.interactive.norm_cast tactic.interactive.norm_cast

/-- Rewrite with the given rules and normalize casts between steps.
-/
unsafe def rw_mod_cast (rs : parse rw_rules) (loc : parse location) : tactic Unit :=
  decorate_error "rw_mod_cast failed:" do
    let cfg_norm : SimpConfig := { }
    let cfg_rw : RewriteCfg := { }
    let ns ← loc.get_locals
    Monad.mapM'
        (fun r : rw_rule => do
          save_info r
          replace_at derive ns loc
          rw ⟨[r], none⟩ loc { })
        rs
    replace_at derive ns loc
    skip
#align tactic.interactive.rw_mod_cast tactic.interactive.rw_mod_cast

/-- Normalize the goal and the given expression, then close the goal with exact.
-/
unsafe def exact_mod_cast (e : parse texpr) : tactic Unit := do
  let e ←
    i_to_expr e <|> do
        let ty ← target
        let e ← i_to_expr_strict ``(($(e) : $(ty)))
        let pty ← pp ty
        let ptgt ← pp e
        fail
            ("exact_mod_cast failed, expression type not directly " ++
                      "inferrable. Try:\n\nexact_mod_cast ...\nshow " ++
                    to_fmt pty ++
                  ",\nfrom " ++
                ptgt :
              format)
  tactic.exact_mod_cast e
#align tactic.interactive.exact_mod_cast tactic.interactive.exact_mod_cast

/-- Normalize the goal and the given expression, then apply the expression to the goal.
-/
unsafe def apply_mod_cast (e : parse texpr) : tactic Unit := do
  let e ← i_to_expr_for_apply e
  concat_tags <| tactic.apply_mod_cast e
#align tactic.interactive.apply_mod_cast tactic.interactive.apply_mod_cast

/--
Normalize the goal and every expression in the local context, then close the goal with assumption.
-/
unsafe def assumption_mod_cast : tactic Unit :=
  tactic.assumption_mod_cast
#align tactic.interactive.assumption_mod_cast tactic.interactive.assumption_mod_cast

end Tactic.Interactive

namespace Conv.Interactive

open Conv

open NormCast (derive)

/-- the converter version of `norm_cast' -/
unsafe def norm_cast : conv Unit :=
  replace_lhs derive
#align conv.interactive.norm_cast conv.interactive.norm_cast

end Conv.Interactive

-- TODO: move this elsewhere?
@[norm_cast]
theorem ite_cast {α β} [HasLiftT α β] {c : Prop} [Decidable c] {a b : α} :
    ↑(ite c a b) = ite c (↑a : β) (↑b : β) := by by_cases h : c <;> simp [h]
#align ite_cast ite_cast

@[norm_cast]
theorem dite_cast {α β} [HasLiftT α β] {c : Prop} [Decidable c] {a : c → α} {b : ¬c → α} :
    ↑(dite c a b) = dite c (fun h => (↑(a h) : β)) fun h => (↑(b h) : β) := by
  by_cases h : c <;> simp [h]
#align dite_cast dite_cast

add_hint_tactic norm_cast  at *

/-- The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
  { Name := "norm_cast"
    category := DocCategory.tactic
    declNames :=
      [`` tactic.interactive.norm_cast, `` tactic.interactive.rw_mod_cast,
        `` tactic.interactive.apply_mod_cast, `` tactic.interactive.assumption_mod_cast,
        `` tactic.interactive.exact_mod_cast, `` tactic.interactive.push_cast]
    tags := ["coercions", "simplification"] }

/-- The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) :
  ((n - m : ℕ) : α) = n - m

@[norm_cast] theorem coe_nat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n :=
by rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
  { Name := "norm_cast attributes"
    category := DocCategory.attr
    declNames := [`` norm_cast.norm_cast_attr]
    tags := ["coercions", "simplification"] }


import Lean

structure A :=
(x : Nat := 10)

def f : A :=
{ }

theorem ex : f = { x := 10 } :=
rfl

#check f

syntax (name := emptyS) "⟨" "⟩"  : term -- overload `⟨ ⟩` notation

open Lean
open Lean.Elab
open Lean.Elab.Term

@[termElab emptyS] def elabEmptyS : TermElab :=
fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  let stxNew ← `(Nat.zero)
  withMacroExpansion stx stxNew $
    elabTerm stxNew expectedType?

def foo (x : Unit) := x

def f1 : Unit :=
let x := ⟨ ⟩
foo x

def f2 : Unit :=
let x := ⟨ ⟩
x

def f3 : Nat :=
let x := ⟨ ⟩
x

theorem ex2 : f3 = 0 :=
rfl


example (h : {a b : α} → a = b) : a = b := _


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.powerset
import Mathlib.data.multiset.range
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# The `nodup` predicate for multisets without duplicate elements.
-/

namespace multiset

/- nodup -/

/-- `nodup s` means that `s` has no duplicates, i.e. the multiplicity of
  any element is at most 1. -/
def nodup {α : Type u_1} (s : multiset α) :=
  quot.lift_on s list.nodup sorry

@[simp] theorem coe_nodup {α : Type u_1} {l : List α} : nodup ↑l ↔ list.nodup l :=
  iff.rfl

@[simp] theorem nodup_zero {α : Type u_1} : nodup 0 :=
  list.pairwise.nil

@[simp] theorem nodup_cons {α : Type u_1} {a : α} {s : multiset α} : nodup (a ::ₘ s) ↔ ¬a ∈ s ∧ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_cons

theorem nodup_cons_of_nodup {α : Type u_1} {a : α} {s : multiset α} (m : ¬a ∈ s) (n : nodup s) : nodup (a ::ₘ s) :=
  iff.mpr nodup_cons { left := m, right := n }

theorem nodup_singleton {α : Type u_1} (a : α) : nodup (a ::ₘ 0) :=
  list.nodup_singleton

theorem nodup_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) : nodup s :=
  and.right (iff.mp nodup_cons h)

theorem not_mem_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) : ¬a ∈ s :=
  and.left (iff.mp nodup_cons h)

theorem nodup_of_le {α : Type u_1} {s : multiset α} {t : multiset α} (h : s ≤ t) : nodup t → nodup s :=
  le_induction_on h fun (l₁ l₂ : List α) => list.nodup_of_sublist

theorem not_nodup_pair {α : Type u_1} (a : α) : ¬nodup (a ::ₘ a ::ₘ 0) :=
  list.not_nodup_pair

theorem nodup_iff_le {α : Type u_1} {s : multiset α} : nodup s ↔ ∀ (a : α), ¬a ::ₘ a ::ₘ 0 ≤ s :=
  quot.induction_on s
    fun (l : List α) => iff.trans list.nodup_iff_sublist (forall_congr fun (a : α) => not_congr (iff.symm repeat_le_coe))

theorem nodup_iff_ne_cons_cons {α : Type u_1} {s : multiset α} : nodup s ↔ ∀ (a : α) (t : multiset α), s ≠ a ::ₘ a ::ₘ t := sorry

theorem nodup_iff_count_le_one {α : Type u_1} [DecidableEq α] {s : multiset α} : nodup s ↔ ∀ (a : α), count a s ≤ 1 :=
  quot.induction_on s fun (l : List α) => list.nodup_iff_count_le_one

@[simp] theorem count_eq_one_of_mem {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} (d : nodup s) (h : a ∈ s) : count a s = 1 :=
  le_antisymm (iff.mp nodup_iff_count_le_one d a) (iff.mpr count_pos h)

theorem nodup_iff_pairwise {α : Type u_1} {s : multiset α} : nodup s ↔ pairwise ne s :=
  quotient.induction_on s fun (l : List α) => iff.symm (pairwise_coe_iff_pairwise fun (a b : α) => ne.symm)

theorem pairwise_of_nodup {α : Type u_1} {r : α → α → Prop} {s : multiset α} : (∀ (a : α), a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b) → nodup s → pairwise r s := sorry

theorem forall_of_pairwise {α : Type u_1} {r : α → α → Prop} (H : symmetric r) {s : multiset α} (hs : pairwise r s) (a : α) : a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b := sorry

theorem nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} : nodup (s + t) ↔ nodup s ∧ nodup t ∧ disjoint s t :=
  quotient.induction_on₂ s t fun (l₁ l₂ : List α) => list.nodup_append

theorem disjoint_of_nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} (d : nodup (s + t)) : disjoint s t :=
  and.right (and.right (iff.mp nodup_add d))

theorem nodup_add_of_nodup {α : Type u_1} {s : multiset α} {t : multiset α} (d₁ : nodup s) (d₂ : nodup t) : nodup (s + t) ↔ disjoint s t := sorry

theorem nodup_of_nodup_map {α : Type u_1} {β : Type u_2} (f : α → β) {s : multiset α} : nodup (map f s) → nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_of_nodup_map f

theorem nodup_map_on {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α} : (∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → f x = f y → x = y) → nodup s → nodup (map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_map_on

theorem nodup_map {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α} (hf : function.injective f) : nodup s → nodup (map f s) :=
  nodup_map_on fun (x : α) (_x : x ∈ s) (y : α) (_x : y ∈ s) (h : f x = f y) => hf h

theorem nodup_filter {α : Type u_1} (p : α → Prop) [decidable_pred p] {s : multiset α} : nodup s → nodup (filter p s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter p

@[simp] theorem nodup_attach {α : Type u_1} {s : multiset α} : nodup (attach s) ↔ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_attach

theorem nodup_pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β} {s : multiset α} {H : ∀ (a : α), a ∈ s → p a} (hf : ∀ (a : α) (ha : p a) (b : α) (hb : p b), f a ha = f b hb → a = b) : nodup s → nodup (pmap f s H) :=
  quot.induction_on s (fun (l : List α) (H : ∀ (a : α), a ∈ Quot.mk setoid.r l → p a) => list.nodup_pmap hf) H

protected instance nodup_decidable {α : Type u_1} [DecidableEq α] (s : multiset α) : Decidable (nodup s) :=
  quotient.rec_on_subsingleton s fun (l : List α) => list.nodup_decidable l

theorem nodup_erase_eq_filter {α : Type u_1} [DecidableEq α] (a : α) {s : multiset α} : nodup s → erase s a = filter (fun (_x : α) => _x ≠ a) s :=
  quot.induction_on s fun (l : List α) (d : nodup (Quot.mk setoid.r l)) => congr_arg coe (list.nodup_erase_eq_filter a d)

theorem nodup_erase_of_nodup {α : Type u_1} [DecidableEq α] (a : α) {l : multiset α} : nodup l → nodup (erase l a) :=
  nodup_of_le (erase_le a l)

theorem mem_erase_iff_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {b : α} {l : multiset α} (d : nodup l) : a ∈ erase l b ↔ a ≠ b ∧ a ∈ l := sorry

theorem mem_erase_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {l : multiset α} (h : nodup l) : ¬a ∈ erase l a := sorry

theorem nodup_product {α : Type u_1} {β : Type u_2} {s : multiset α} {t : multiset β} : nodup s → nodup t → nodup (product s t) := sorry

theorem nodup_sigma {α : Type u_1} {σ : α → Type u_2} {s : multiset α} {t : (a : α) → multiset (σ a)} : nodup s → (∀ (a : α), nodup (t a)) → nodup (multiset.sigma s t) := sorry

theorem nodup_filter_map {α : Type u_1} {β : Type u_2} (f : α → Option β) {s : multiset α} (H : ∀ (a a' : α) (b : β), b ∈ f a → b ∈ f a' → a = a') : nodup s → nodup (filter_map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter_map H

theorem nodup_range (n : ℕ) : nodup (range n) :=
  list.nodup_range n

theorem nodup_inter_left {α : Type u_1} [DecidableEq α] {s : multiset α} (t : multiset α) : nodup s → nodup (s ∩ t) :=
  nodup_of_le (inter_le_left s t)

theorem nodup_inter_right {α : Type u_1} [DecidableEq α] (s : multiset α) {t : multiset α} : nodup t → nodup (s ∩ t) :=
  nodup_of_le (inter_le_right s t)

@[simp] theorem nodup_union {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : nodup (s ∪ t) ↔ nodup s ∧ nodup t := sorry

@[simp] theorem nodup_powerset {α : Type u_1} {s : multiset α} : nodup (powerset s) ↔ nodup s := sorry

theorem nodup_powerset_len {α : Type u_1} {n : ℕ} {s : multiset α} (h : nodup s) : nodup (powerset_len n s) :=
  nodup_of_le (powerset_len_le_powerset n s) (iff.mpr nodup_powerset h)

@[simp] theorem nodup_bind {α : Type u_1} {β : Type u_2} {s : multiset α} {t : α → multiset β} : nodup (bind s t) ↔ (∀ (a : α), a ∈ s → nodup (t a)) ∧ pairwise (fun (a b : α) => disjoint (t a) (t b)) s := sorry

theorem nodup_ext {α : Type u_1} {s : multiset α} {t : multiset α} : nodup s → nodup t → (s = t ↔ ∀ (a : α), a ∈ s ↔ a ∈ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d₁ : nodup (quotient.mk l₁)) (d₂ : nodup (quotient.mk l₂)) =>
      iff.trans quotient.eq (list.perm_ext d₁ d₂)

theorem le_iff_subset {α : Type u_1} {s : multiset α} {t : multiset α} : nodup s → (s ≤ t ↔ s ⊆ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d : nodup (quotient.mk l₁)) => { mp := subset_of_le, mpr := list.subperm_of_subset_nodup d }

theorem range_le {m : ℕ} {n : ℕ} : range m ≤ range n ↔ m ≤ n :=
  iff.trans (le_iff_subset (nodup_range m)) range_subset

theorem mem_sub_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} {t : multiset α} (d : nodup s) : a ∈ s - t ↔ a ∈ s ∧ ¬a ∈ t := sorry

theorem map_eq_map_of_bij_of_nodup {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → γ) (g : β → γ) {s : multiset α} {t : multiset β} (hs : nodup s) (ht : nodup t) (i : (a : α) → a ∈ s → β) (hi : ∀ (a : α) (ha : a ∈ s), i a ha ∈ t) (h : ∀ (a : α) (ha : a ∈ s), f a = g (i a ha)) (i_inj : ∀ (a₁ a₂ : α) (ha₁ : a₁ ∈ s) (ha₂ : a₂ ∈ s), i a₁ ha₁ = i a₂ ha₂ → a₁ = a₂) (i_surj : ∀ (b : β), b ∈ t → ∃ (a : α), ∃ (ha : a ∈ s), b = i a ha) : map f s = map g t := sorry


def ex1 : IO Unit := do
IO.println "example 1"
for x in [:100:10] do
  IO.println s!"x: {x}"

#eval ex1

def ex2 : IO Unit := do
IO.println "example 2"
for x in [:10] do
  IO.println s!"x: {x}"

#eval ex2

def ex3 : IO Unit := do
IO.println "example 3"
for x in [1:10] do
  IO.println s!"x: {x}"

#eval ex3

def ex4 : IO Unit := do
IO.println "example 4"
for x in [1:10:3] do
  IO.println s!"x: {x}"

#eval ex4


import o_minimal.sheaf.tactic

namespace o_minimal

variables {R : Type*} {S : struc R}
variables {X Y Z : Type*} [definable_sheaf S X] [definable_sheaf S Y] [definable_sheaf S Z]

-- TODO: consistent naming

lemma definable.const : definable S (@function.const X Y) :=
begin [defin]
  intro x,
  intro y,
  var
end

lemma definable_comp : definable S (@function.comp X Y Z) :=
begin [defin]
  intro f,
  intro g,
  intro x,
  app, var,
  app, var, var
end

lemma definable.app {f : X → Y} (hf : definable S f) {x : X} (hx : definable S x) :
  definable S (f x) :=
begin [defin]
  app,
  exact hf.definable _,
  exact hx.definable _
end

lemma definable.comp {g : Y → Z} (hg : definable S g) {f : X → Y} (hf : definable S f) :
  definable S (g ∘ f) :=
(definable_comp.app hg).app hf

lemma definable.prod_mk : definable S (@prod.mk X Y) :=
begin [defin]
  intro x,
  intro y,
  exact ⟨x.definable, y.definable⟩
end

lemma definable.fst : definable S (prod.fst : X × Y → X) :=
begin [defin]
  intro p,
  exact p.definable.1
end

lemma definable.snd : definable S (prod.snd : X × Y → Y) :=
begin [defin]
  intro p,
  exact p.definable.2
end

lemma definable.curry : definable S (@function.curry X Y Z) :=
begin [defin]
  intro f,
  intro x,
  intro y,
  app, var,
  app, app, exact definable.prod_mk.definable _, var, var
end

lemma definable.uncurry : definable S (@function.uncurry X Y Z) :=
begin [defin]
  intro f,
  intro p,
  app, app, var,
  app, exact definable.fst.definable _, var,
  app, exact definable.snd.definable _, var
end

instance punit.definable_sheaf : definable_sheaf S punit :=
{ definable := λ K f, true,
  definable_precomp := λ L K φ f hf, trivial,
  definable_cover := λ K f 𝓛 h, trivial }

lemma definable.star : definable S punit.star :=
begin [defin]
  exact trivial
end

instance Prop.definable_sheaf : definable_sheaf S Prop :=
{ definable := λ K f, def_set S f,
  definable_precomp := λ L K φ f hf, φ.is_definable.preimage hf,
  definable_cover := λ K f 𝓛 h, Def.set_subcanonical 𝓛 f h }

lemma definable.and : definable S and :=
begin [defin]
  intro p,
  intro q,
  exact def_set.inter p.definable q.definable
end

lemma definable.or : definable S or :=
begin [defin]
  intro p,
  intro q,
  exact def_set.union p.definable q.definable
end

lemma definable.imp : definable S ((→) : Prop → Prop → Prop) :=
begin [defin]
  intro p,
  intro q,
  exact def_set.imp p.definable q.definable
end

lemma definable.not : definable S not :=
begin [defin]
  intro p,
  exact def_set.compl p.definable
end

lemma definable.iff : definable S iff :=
begin [defin]
  intro p,
  intro q,
  exact def_set.iff p.definable q.definable
end

instance set.definable_sheaf : definable_sheaf S (set X) :=
show definable_sheaf S (X → Prop), by apply_instance

lemma definable.mem : definable S ((∈) : X → set X → Prop) :=
begin [defin]
  intro x,
  intro s,
  app, var, var
end

lemma definable.inter : definable S ((∩) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app,
  app,
  exact definable.and.definable _,
  app, app, exact definable.mem.definable _, var, var,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.union : definable S ((∪) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app,
  app,
  exact definable.or.definable _,
  app, app, exact definable.mem.definable _, var, var,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.compl : definable S (set.compl : set X → set X) :=
begin [defin]
  intro s,
  intro x,
  app, exact definable.not.definable _,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.diff : definable S ((\) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app, app, exact definable.and.definable _,
  app, app, exact definable.mem.definable _, var, var,
  -- unnecessarily complicated, but hey why not
  -- TODO: `change`
  app,
  intro a,
  app, exact definable.not.definable _,
  app, app, exact definable.mem.definable _, var, var,
  var
end

-- Quantification over X is not definable in general.
-- Needs a special property of X: "quasicompactness"?
-- See `quantifiers` (for now, just over representables)

instance set.coe.definable_sheaf {s : set X} : definable_sheaf S s :=
{ definable := λ K f, definable_sheaf.definable (subtype.val ∘ f),
  definable_precomp := λ L K φ f hf,
    definable_sheaf.definable_precomp φ (subtype.val ∘ f) hf,
  definable_cover := λ K f 𝓛 hf,
    definable_sheaf.definable_cover (subtype.val ∘ f) 𝓛 hf }

instance subtype.definable_sheaf {p : X → Prop} : definable_sheaf S {x // p x} :=
show definable_sheaf S (set_of p), by apply_instance

-- instance prop.definable_sheaf {p : Prop} : definable_sheaf S p := sorry

-- TODO: With an instance for Pi types, can we state the definable dependence on `s`?
lemma definable.subtype.val {s : set X} : definable S (subtype.val : s → X) :=
begin [defin]
  intro v,
  exact v.definable
end

lemma definable_of_subtype_val {s : set Y} {f : X → s}
  (hf : definable S (subtype.val ∘ f)) : definable S f :=
begin
  cases hf with hf,
  exact ⟨λ K, hf K⟩
end

-- How to state definable subtype.mk?
/-
lemma definable.subtype.mk {s : set X} :
  definable S (subtype.mk : Π (x : X), x ∈ s → s) :=
begin
end
-/

lemma definable_subtype.map {s : set X} {t : set Y} {f : X → Y} (hf : definable S f)
  (h : ∀ x ∈ s, f x ∈ t) : definable S (subtype.map f h : s → t) :=
definable_of_subtype_val $ hf.comp definable.subtype.val

end o_minimal


import Lean

structure A :=
(x : Nat := 10)

def f : A :=
{ }

theorem ex : f = { x := 10 } :=
rfl

#check f

syntax (name := emptyS) "⟨" "⟩"  : term -- overload `⟨ ⟩` notation

open Lean
open Lean.Elab
open Lean.Elab.Term

@[term_elab emptyS] def elabEmptyS : TermElab :=
fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  let stxNew ← `(Nat.zero)
  withMacroExpansion stx stxNew $
    elabTerm stxNew expectedType?

def foo (x : Unit) := x

def f1 : Unit :=
let x := ⟨ ⟩
foo x

def f2 : Unit :=
let x := ⟨ ⟩
x

def f3 : Nat :=
let x := ⟨ ⟩
x

theorem ex2 : f3 = 0 :=
rfl


import C0deine.Utils.Symbol

namespace C0deine

inductive Typ.Primitive
| int
| bool
deriving DecidableEq, Inhabited, Hashable

mutual
inductive Typ
| prim (p : Typ.Primitive)
| mem (m : Typ.Memory)
deriving Inhabited, Hashable

inductive Typ.Memory
| pointer (typ : Typ)
| array (typ : Typ)
| struct (sym : Symbol)
deriving Inhabited, Hashable
end

inductive Typ.Check
| type : Typ → Typ.Check
| void
| any
deriving Inhabited

namespace Typ

def Primitive.toString : Typ.Primitive → String
  | .int  => "int"
  | .bool => "bool"
instance : ToString Primitive where toString := Primitive.toString

mutual
def Memory.toString : Typ.Memory → String
  | .pointer (typ : Typ)   => s!"{toString typ}*"
  | .array (typ : Typ)     => s!"{toString typ}[]"
  | .struct (sym : Symbol) => s!"struct {sym}"

def toString : Typ → String
  | .prim (p : Primitive) => Primitive.toString p
  | .mem (m : Typ.Memory) => Memory.toString m
end

def Check.toString : Check → String
  | .type t => s!"{Typ.toString t}"
  | .void => "`void"
  | .any => "`any"

instance : ToString Memory where toString := Memory.toString
instance : ToString Typ where toString := Typ.toString
instance : ToString Typ.Check where toString := Typ.Check.toString
instance : ToString (Option Typ) where
  toString | none => "void" | some t => s!"{t}"

mutual
-- encoding structural equality
def structEq (a b : Typ) : Bool :=
  match a, b with
  | .prim p1, .prim p2 => p1 = p2
  | .mem m1, .mem m2 => Memory.structEq m1 m2
  | _, _ => false

def Memory.structEq (a b : Memory) : Bool :=
  match a, b with
  | .struct s1, .struct s2 => s1 = s2
  | .pointer t1, .pointer t2 => Typ.structEq t1 t2
  | .array t1, .array t2 => Typ.structEq t1 t2
  | _, _ => false
end

mutual
theorem deq {a b : Typ} : structEq a b = true ↔ a = b := by
  cases a <;> cases b <;>
  ( unfold structEq
    simp
    try apply Memory.deq
  )

theorem Memory.deq {a b : Memory} : Memory.structEq a b = true ↔ a = b := by
  cases a <;> cases b <;>
  ( unfold Memory.structEq
    simp
    try apply Typ.deq
  )
end

instance : DecidableEq Typ := fun a b =>
  match Bool.decEq (Typ.structEq a b) true with
  | .isTrue h  => .isTrue (Typ.deq.mp h)
  | .isFalse h => .isFalse (h ∘ Typ.deq.mpr)
instance : DecidableEq Memory := fun a b =>
  match Bool.decEq (Memory.structEq a b) true with
  | .isTrue h  => .isTrue (Memory.deq.mp h)
  | .isFalse h => .isFalse (h ∘ Memory.deq.mpr)

deriving instance DecidableEq for Typ.Check

mutual
  def equiv (a b : Typ) : Bool :=
    match a, b with
    | .prim p1  , .prim p2    => p1 == p2
    | .mem m1   , .mem m2     => Memory.equiv m1 m2
    | _, _                    => false

  def Memory.equiv (a b : Memory) : Bool :=
    match a, b with
    | .pointer t1, .pointer t2 => equiv t1 t2
    | .array t1  , .array t2   => equiv t1 t2
    | .struct s1 , .struct s2  => s1 == s2
    | _, _                     => false
end

def Check.equiv (a b : Check) : Bool :=
  match a, b with
  | .type t1, .type t2                          => Typ.equiv t1 t2
  | .void, .void                                => true
  | .any, .type (.mem (.array _))
  | .type (.mem (.array _)), .any               => false
  | .any, .type (.mem _) | .type (.mem _), .any => true
  | .any, .any => true
  | _, _       => false

def isScalar : Typ → Bool
  | .prim .int => true
  | .prim .bool => true
  | _ => false
def Check.isScalar : Typ.Check → Bool
  | .type t => t.isScalar
  | _ => false

def isSmall : Typ → Bool
  | .mem (.struct _) => false
  | _ => true
def Check.isSmall : Typ.Check → Bool
  | .type t => t.isSmall
  | _ => true

def sizeof : Typ → Option Nat
  | .prim .int => some 4
  | .prim .bool => some 1
  | .mem (.pointer _) => some 8
  | .mem (.array _) => some 8
  | .mem (.struct _) => none
def Check.sizeof : Typ.Check → Option Nat
  | .type t => t.sizeof
  | _ => none
end Typ


/- Basic theorems about bool -/

@[simp]
lemma coe_sort_bool_to_equality (b:bool) : @coe_sort _ coe_sort_bool b = (b = tt) :=
begin
  cases b,
  all_goals { simp [coe_sort, has_coe_to_sort.coe]},
end


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

namespace Lean.Elab.Tactic
open Meta
open TSyntax.Compat
open Simp (UsedSimps)

declare_config_elab elabSimpConfigCore    Meta.Simp.Config
declare_config_elab elabSimpConfigCtxCore Meta.Simp.ConfigCtx
declare_config_elab elabDSimpConfigCore   Meta.DSimp.Config

inductive SimpKind where
  | simp
  | simpAll
  | dsimp
  deriving Inhabited, BEq

/--
  Implement a `simp` discharge function using the given tactic syntax code.
  Recall that `simp` dischargers are in `SimpM` which does not have access to `Term.State`.
  We need access to `Term.State` to store messages and update the info tree.
  Thus, we create an `IO.ref` to track these changes at `Term.State` when we execute `tacticCode`.
  We must set this reference with the current `Term.State` before we execute `simp` using the
  generated `Simp.Discharge`. -/
def tacticToDischarge (tacticCode : Syntax) : TacticM (IO.Ref Term.State × Simp.Discharge) := do
  let tacticCode ← `(tactic| try ($tacticCode:tacticSeq))
  let ref ← IO.mkRef (← getThe Term.State)
  let ctx ← readThe Term.Context
  let disch : Simp.Discharge := fun e => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar e `simp.discharger
    let s ← ref.get
    let runTac? : TermElabM (Option Expr) :=
      try
        /- We must only save messages and info tree changes. Recall that `simp` uses temporary metavariables (`withNewMCtxDepth`).
           So, we must not save references to them at `Term.State`. -/
        withoutModifyingStateWithInfoAndMessages do
          Term.withSynthesize (mayPostpone := false) <| Term.runTactic mvar.mvarId! tacticCode
          let result ← instantiateMVars mvar
          if result.hasExprMVar then
            return none
          else
            return some result
      catch _ =>
        return none
    let (result?, s) ← liftM (m := MetaM) <| Term.TermElabM.run runTac? ctx s
    ref.set s
    return result?
  return (ref, disch)

inductive Simp.DischargeWrapper where
  | default
  | custom (ref : IO.Ref Term.State) (discharge : Simp.Discharge)

def Simp.DischargeWrapper.with (w : Simp.DischargeWrapper) (x : Option Simp.Discharge → TacticM α) : TacticM α := do
  match w with
  | default => x none
  | custom ref d =>
    ref.set (← getThe Term.State)
    try
      x d
    finally
      set (← ref.get)

private def mkDischargeWrapper (optDischargeSyntax : Syntax) : TacticM Simp.DischargeWrapper := do
  if optDischargeSyntax.isNone then
    return Simp.DischargeWrapper.default
  else
    let (ref, d) ← tacticToDischarge optDischargeSyntax[0][3]
    return Simp.DischargeWrapper.custom ref d

/-
  `optConfig` is of the form `("(" "config" ":=" term ")")?`
-/
def elabSimpConfig (optConfig : Syntax) (kind : SimpKind) : TermElabM Meta.Simp.Config := do
  match kind with
  | .simp    => elabSimpConfigCore optConfig
  | .simpAll => return (← elabSimpConfigCtxCore optConfig).toConfig
  | .dsimp   => return { (← elabDSimpConfigCore optConfig) with }

private def addDeclToUnfoldOrTheorem (thms : Meta.SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM Meta.SimpTheorems := do
  if e.isConst then
    let declName := e.constName!
    let info ← getConstInfo declName
    if (← isProp info.type) then
      thms.addConst declName (post := post) (inv := inv)
    else
      if inv then
        throwError "invalid '←' modifier, '{declName}' is a declaration name to be unfolded"
      if kind == .dsimp then
        return thms.addDeclToUnfoldCore declName
      else
        thms.addDeclToUnfold declName
  else
    thms.add id #[] e (post := post) (inv := inv)

private def addSimpTheorem (thms : Meta.SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM Meta.SimpTheorems := do
  let (levelParams, proof) ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx <| Term.withoutErrToSorry do
    let e ← Term.elabTerm stx none
    Term.synthesizeSyntheticMVars (mayPostpone := false) (ignoreStuckTC := true)
    let e ← instantiateMVars e
    let e := e.eta
    if e.hasMVar then
      let r ← abstractMVars e
      return (r.paramNames, r.expr)
    else
      return (#[], e)
  thms.add id levelParams proof (post := post) (inv := inv)

structure ElabSimpArgsResult where
  ctx     : Simp.Context
  starArg : Bool := false

inductive ResolveSimpIdResult where
  | none
  | expr (e : Expr)
  | ext  (ext : SimpExtension)

/--
  Elaborate extra simp theorems provided to `simp`. `stx` is of the form `"[" simpTheorem,* "]"`
  If `eraseLocal == true`, then we consider local declarations when resolving names for erased theorems (`- id`),
  this option only makes sense for `simp_all` or `*` is used.
-/
def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (eraseLocal : Bool) (kind : SimpKind) : TacticM ElabSimpArgsResult := do
  if stx.isNone then
    return { ctx }
  else
    /-
    syntax simpPre := "↓"
    syntax simpPost := "↑"
    syntax simpLemma := (simpPre <|> simpPost)? term

    syntax simpErase := "-" ident
    -/
    withMainContext do
      let mut thmsArray := ctx.simpTheorems
      let mut thms      := thmsArray[0]!
      let mut starArg   := false
      for arg in stx[1].getSepArgs do
        if arg.getKind == ``Lean.Parser.Tactic.simpErase then
          let fvar ← if eraseLocal || starArg then Term.isLocalIdent? arg[1] else pure none
          if let some fvar := fvar then
            -- We use `eraseCore` because the simp theorem for the hypothesis was not added yet
            thms := thms.eraseCore (.fvar fvar.fvarId!)
          else
            let declName ← resolveGlobalConstNoOverloadWithInfo arg[1]
            if ctx.config.autoUnfold then
              thms := thms.eraseCore (.decl declName)
            else
              thms ← thms.erase (.decl declName)
        else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
          let post :=
            if arg[0].isNone then
              true
            else
              arg[0][0].getKind == ``Parser.Tactic.simpPost
          let inv  := !arg[1].isNone
          let term := arg[2]

          match (← resolveSimpIdTheorem? term) with
          | .expr e  =>
            let name ← mkFreshId
            thms ← addDeclToUnfoldOrTheorem thms (.stx name arg) e post inv kind
          | .ext ext =>
            thmsArray := thmsArray.push (← ext.getTheorems)
          | .none    =>
            let name ← mkFreshId
            thms ← addSimpTheorem thms (.stx name arg) term post inv
        else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
          starArg := true
        else
          throwUnsupportedSyntax
      return { ctx := { ctx with simpTheorems := thmsArray.set! 0 thms }, starArg }
where
  resolveSimpIdTheorem? (simpArgTerm : Term) : TacticM ResolveSimpIdResult := do
    let resolveExt (n : Name) : TacticM ResolveSimpIdResult := do
      if let some ext ← getSimpExtension? n then
        return .ext ext
      else
        return .none
    match simpArgTerm with
    | `($id:ident) =>
      try
        if let some e ← Term.resolveId? simpArgTerm (withInfo := true) then
          return .expr e
        else
          resolveExt id.getId.eraseMacroScopes
      catch _ =>
        resolveExt id.getId.eraseMacroScopes
    | _ =>
      if let some e ← Term.elabCDotFunctionAlias? simpArgTerm then
        return .expr e
      else
        return .none

@[inline] def simpOnlyBuiltins : List Name := [``eq_self, ``iff_self]

structure MkSimpContextResult where
  ctx              : Simp.Context
  dischargeWrapper : Simp.DischargeWrapper

/--
   Create the `Simp.Context` for the `simp`, `dsimp`, and `simp_all` tactics.
   If `kind != SimpKind.simp`, the `discharge` option must be `none`

   TODO: generate error message if non `rfl` theorems are provided as arguments to `dsimp`.
-/
def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp) (ignoreStarArg : Bool := false) : TacticM MkSimpContextResult := do
  if !stx[2].isNone then
    if kind == SimpKind.simpAll then
      throwError "'simp_all' tactic does not support 'discharger' option"
    if kind == SimpKind.dsimp then
      throwError "'dsimp' tactic does not support 'discharger' option"
  let dischargeWrapper ← mkDischargeWrapper stx[2]
  let simpOnly := !stx[3].isNone
  let simpTheorems ← if simpOnly then
    simpOnlyBuiltins.foldlM (·.addConst ·) ({} : SimpTheorems)
  else
    getSimpTheorems
  let congrTheorems ← getSimpCongrTheorems
  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) {
    config      := (← elabSimpConfig stx[1] (kind := kind))
    simpTheorems := #[simpTheorems], congrTheorems
  }
  if !r.starArg || ignoreStarArg then
    return { r with dischargeWrapper }
  else
    let ctx := r.ctx
    let mut simpTheorems := ctx.simpTheorems
    let hs ← getPropHyps
    for h in hs do
      unless simpTheorems.isErased (.fvar h) do
        simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr
    let ctx := { ctx with simpTheorems }
    return { ctx, dischargeWrapper }

register_builtin_option tactic.simp.trace : Bool := {
  defValue := false
  descr    := "When tracing is enabled, calls to `simp` or `dsimp` will print an equivalent `simp only` call."
}

def traceSimpCall (stx : Syntax) (usedSimps : UsedSimps) : MetaM Unit := do
  let mut stx := stx
  if stx[3].isNone then
    stx := stx.setArg 3 (mkNullNode #[mkAtom "only"])
  let mut args := #[]
  let mut localsOrStar := some #[]
  let lctx ← getLCtx
  let env ← getEnv
  for (thm, _) in usedSimps.toArray.qsort (·.2 < ·.2) do
    match thm with
    | .decl declName => -- global definitions in the environment
      if env.contains declName && !simpOnlyBuiltins.contains declName then
        args := args.push (← `(Parser.Tactic.simpLemma| $(mkIdent (← unresolveNameGlobal declName)):ident))
    | .fvar fvarId => -- local hypotheses in the context
      if let some ldecl := lctx.find? fvarId then
        localsOrStar := localsOrStar.bind fun locals =>
          if !ldecl.userName.isInaccessibleUserName &&
              (lctx.findFromUserName? ldecl.userName).get!.fvarId == ldecl.fvarId then
            some (locals.push ldecl.userName)
          else
            none
      -- Note: the `if let` can fail for `simp (config := {contextual := true})` when
      -- rewriting with a variable that was introduced in a scope. In that case we just ignore.
    | .stx _ thmStx => -- simp theorems provided in the local invocation
      args := args.push thmStx
    | .other _ => -- Ignore "special" simp lemmas such as constructed by `simp_all`.
      pure ()     -- We can't display them anyway.
  if let some locals := localsOrStar then
    args := args ++ (← locals.mapM fun id => `(Parser.Tactic.simpLemma| $(mkIdent id):ident))
  else
    args := args.push (← `(Parser.Tactic.simpStar| *))
  let argsStx := if args.isEmpty then #[] else #[mkAtom "[", (mkAtom ",").mkSep args, mkAtom "]"]
  stx := stx.setArg 4 (mkNullNode argsStx)
  logInfoAt stx[0] m!"Try this: {stx}"

/--
`simpLocation ctx discharge? varIdToLemmaId loc`
runs the simplifier at locations specified by `loc`,
using the simp theorems collected in `ctx`
optionally running a discharger specified in `discharge?` on generated subgoals.

Its primary use is as the implementation of the
`simp [...] at ...` and `simp only [...] at ...` syntaxes,
but can also be used by other tactics when a `Syntax` is not available.

For many tactics other than the simplifier,
one should use the `withLocation` tactic combinator
when working with a `location`.
-/
def simpLocation (ctx : Simp.Context) (discharge? : Option Simp.Discharge := none) (loc : Location) : TacticM UsedSimps := do
  match loc with
  | Location.targets hyps simplifyTarget =>
    withMainContext do
      let fvarIds ← getFVarIds hyps
      go fvarIds simplifyTarget
  | Location.wildcard =>
    withMainContext do
      go (← (← getMainGoal).getNondepPropHyps) (simplifyTarget := true)
where
  go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM UsedSimps := do
    let mvarId ← getMainGoal
    let (result?, usedSimps) ← simpGoal mvarId ctx (simplifyTarget := simplifyTarget) (discharge? := discharge?) (fvarIdsToSimp := fvarIdsToSimp)
    match result? with
    | none => replaceMainGoal []
    | some (_, mvarId) => replaceMainGoal [mvarId]
    return usedSimps

/-
  "simp " (config)? (discharger)? ("only ")? ("[" simpLemma,* "]")? (location)?
-/
@[builtin_tactic Lean.Parser.Tactic.simp] def evalSimp : Tactic := fun stx => do
  let { ctx, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  let usedSimps ← dischargeWrapper.with fun discharge? =>
    simpLocation ctx discharge? (expandOptLocation stx[5])
  if tactic.simp.trace.get (← getOptions) then
    traceSimpCall stx usedSimps

@[builtin_tactic Lean.Parser.Tactic.simpAll] def evalSimpAll : Tactic := fun stx => do
  let { ctx, .. } ← mkSimpContext stx (eraseLocal := true) (kind := .simpAll) (ignoreStarArg := true)
  let (result?, usedSimps) ← simpAll (← getMainGoal) ctx
  match result? with
  | none => replaceMainGoal []
  | some mvarId => replaceMainGoal [mvarId]
  if tactic.simp.trace.get (← getOptions) then
    traceSimpCall stx usedSimps

def dsimpLocation (ctx : Simp.Context) (loc : Location) : TacticM Unit := do
  match loc with
  | Location.targets hyps simplifyTarget =>
    withMainContext do
      let fvarIds ← getFVarIds hyps
      go fvarIds simplifyTarget
  | Location.wildcard =>
    withMainContext do
      go (← (← getMainGoal).getNondepPropHyps) (simplifyTarget := true)
where
  go (fvarIdsToSimp : Array FVarId) (simplifyTarget : Bool) : TacticM Unit := do
    let mvarId ← getMainGoal
    let (result?, usedSimps) ← dsimpGoal mvarId ctx (simplifyTarget := simplifyTarget) (fvarIdsToSimp := fvarIdsToSimp)
    match result? with
    | none => replaceMainGoal []
    | some mvarId => replaceMainGoal [mvarId]
    if tactic.simp.trace.get (← getOptions) then
      traceSimpCall (← getRef) usedSimps

@[builtin_tactic Lean.Parser.Tactic.dsimp] def evalDSimp : Tactic := fun stx => do
  let { ctx, .. } ← withMainContext <| mkSimpContext stx (eraseLocal := false) (kind := .dsimp)
  dsimpLocation ctx (expandOptLocation stx[5])

end Lean.Elab.Tactic


import Lean

open Lean

/-- `lemma` means the same as `theorem`. It is used to denote "less important" theorems -/
syntax (name := lemma)
  declModifiers group("lemma" declId declSig declVal Parser.Command.terminationSuffix) : command
/-- Implementation of the `lemma` command, by macro expansion to `theorem`. -/
@[macro «lemma»] def expandLemma : Macro := fun stx =>
  -- FIXME: this should be a macro match, but terminationSuffix is not easy to bind correctly.
  -- This implementation ensures that any future changes to `theorem` are reflected in `lemma`
  let stx := stx.modifyArg 1 fun stx =>
    let stx := stx.modifyArg 0 (mkAtomFrom · "theorem")
    stx.setKind ``Parser.Command.theorem
  pure <| stx.setKind ``Parser.Command.declaration

lemma l (x : Nat) : x  = x := rfl


import data.set

namespace probability_theory

-- TODO subtype.restrict?
def pi_subtype {α : Type*} {β : α → Type*} (mv : set α) := λ (g : Π i, β i) (i : mv), g i

@[reducible]
def pi_subtype_img {α : Type*} {β : α → Type*} (mv : set α) :=
  λ (g : set (Π i, β i)) , pi_subtype mv '' g

@[reducible]
def pi_unsubtype_img {α : Type*} {β : α → Type*} (mv : set α) :=
  λ (g : set (Π i : mv, β i)), pi_subtype mv ⁻¹' g

notation  `<[`S`]` := pi_subtype_img S
notation  `>[`S`]` := pi_unsubtype_img S

notation  `<[]` := pi_subtype_img _
notation  `>[]` := pi_unsubtype_img _

def set_to_subtype {α : Type*} (A : set α) (B : set α) : set A := λ x : A, ↑x ∈ B

def pi_set_to_subtype {α : Type*} {β : α → Type*} (A : set α) (B : set α)
  (f : Π i : B, β i) : Π i : set_to_subtype A B, β i := λ ⟨i, hi⟩, f ⟨i, hi⟩

lemma pi_set_to_subtype_def {α : Type*} {β : α → Type*} (A : set α) (B : set α)
  (f : Π i : B, β i) (i : α) (hi : i ∈ A) (hi' : i ∈ B) :
  pi_set_to_subtype A B f ⟨⟨i, hi⟩, hi'⟩ = f ⟨↑(⟨i, hi⟩ : A), hi'⟩ := rfl

lemma pi_set_to_subtype_def' {α : Type*} {β : α → Type*} (A : set α) (B : set α)
  (f : Π i : B, β i) (i : set_to_subtype A B) :
  pi_set_to_subtype A B f i = f ⟨↑(⟨i.val.val, i.val.property⟩ : A), i.property⟩ :=
begin
  obtain ⟨⟨_, _⟩, _⟩ := i,
  rw pi_set_to_subtype_def,
end

lemma pi_set_to_subtype_bijective {α : Type*} {β : α → Type*} {A : set α} {B : set α} (hAB : B ⊆ A)
  : function.bijective (@pi_set_to_subtype _ β A B) :=
begin
  constructor,
  { intros f f' hff',
    have h := congr_fun hff',
    simp_rw pi_set_to_subtype_def' at h,
    ext i,
    specialize h ⟨⟨i, hAB i.property⟩, i.property⟩,
    convert h; exact subtype.eq rfl },
  { intro f,
    refine ⟨(λ i, f ⟨⟨i, hAB i.property⟩, i.property⟩), _⟩,
    ext i,
    rw pi_set_to_subtype_def',
    congr,
    refine subtype.eq _, refine subtype.eq rfl },
end

lemma pi_set_to_subtype_img_preimage_idx {α : Type*} {β : α → Type*} {A : set α} {B : set α} (hAB : B ⊆ A) {b : B} (bs : set (β b)) :
pi_set_to_subtype A B '' ((λ (g : Π (i : B), β i), g b) ⁻¹' bs)
= (λ (g : Π (i : set_to_subtype A B), β i), g ⟨⟨b, hAB b.property⟩, b.property⟩) ⁻¹' bs :=
begin
  ext1 x,
  split,
  rintro ⟨bs', hbs', hbsx'⟩,
  change bs' _ ∈ bs at hbs',
  change _ ∈ bs,
  subst hbsx',
  change bs' ⟨_, _⟩ ∈ _,
  convert hbs',
  exact subtype.eq rfl,
  intro hx,
  refine ⟨λ b : B, x ⟨⟨b, hAB b.property⟩, b.property⟩, hx, _⟩, ext ⟨⟨_, _⟩, _⟩, refl
end

@[reducible]
def pi_unsubtype_set {α : Type*} {β : α → Type*} (A : set α) (B : set α) :
  set (Π i : B, β i) → set (Π i : A, β i)
  := λ g, >[set_to_subtype A B] (pi_set_to_subtype A B '' g)

notation `>>[`A`]` := pi_unsubtype_set A _
notation `>>[]` := pi_unsubtype_set _ _

def pi_unsubtype_set_same {α : Type*} {β : α → Type*} (A : set α) (a : set (Π i : A, β i)) :
  >>[A] a = a :=
begin
  rw pi_unsubtype_set,
  rw pi_unsubtype_img,
  change (_ ⁻¹' (_ '' a)) = a,
  -- TODO extract
  convert @set.preimage_image_eq _ _ (@pi_set_to_subtype _ β A A) a (pi_set_to_subtype_bijective rfl.subset).injective,
  ext f i,
  rw pi_set_to_subtype_def',
  change f _ = _,
  congr, refine subtype.eq rfl
end

lemma pi_subtype_ext {α : Type*} {β : α → Type*} {A : set α}
{f : Π i, β i} {g : Π i : A, β i} : pi_subtype A f = g ↔ ∀ i : A, f i = g i :=
by rw function.funext_iff; refl

--lemma pi_subtype_ext' {α : Type*} {β : α → Type*} {A : set α} {f g : Π i, β i} :
--pi_subtype A f = pi_subtype A g ↔ ∀ i ∈ A, f i = g i := sorry

lemma pi_subtype_subtype {α : Type*} {β : α → Type*} (A : set α) (B : set α)
  (x : Π i : α, β i) :
  pi_subtype (set_to_subtype A B) (pi_subtype A x) = λ (i : set_to_subtype A B), x i := rfl

lemma pi_unsubtype_union_img_def {α : Type*} {β : α → Type*} [∀ i : α, inhabited (β i)]
  (A : set α) (B : set α) (sb : set (Π i : B, β i)) : >>[A] sb = <[A] (>[B] sb) :=
begin
  simp_rw [pi_unsubtype_img, pi_subtype_img],
  refine set.subset.antisymm _ _; intros x h,
  { obtain ⟨x', h', h⟩ := h,
    classical,
    let y : Π i, β i := λ i, if h : i ∈ B then x' ⟨i, h⟩
      else if h : i ∈ A then x ⟨i, h⟩ else default,
    refine ⟨y, _, _⟩,
    change pi_subtype B y ∈ sb,
    convert h',
    all_goals {refine pi_subtype_ext.mpr _, rintro ⟨i, hi⟩},
      exact dif_pos hi,
    by_cases hi' : i ∈ B,
      convert dif_pos hi',
      exact (congr_fun h ⟨⟨_, hi⟩, hi'⟩).symm,
    exact (dif_neg hi').trans (dif_pos hi) },
  { obtain ⟨_, h', rfl⟩ := h,
    refine ⟨pi_subtype B _, h', _⟩,
    ext ⟨⟨_, _⟩, _⟩, refl }
end

def pi_subtype_subtype_subset {α : Type*} {β : α → Type*} {A : set α} {B : set α}
  (hba : B ⊆ A) (sb : set (Π i : B, β i)) :
  >[B] sb = >[A] (>[set_to_subtype A B] (pi_set_to_subtype A B '' sb)) :=
begin
  simp_rw [pi_unsubtype_img, set.preimage_preimage],
  refine set.subset.antisymm _ _; intros x h,
  { refine ⟨pi_subtype B x, h, _⟩, ext ⟨⟨_, _⟩, _⟩, refl },
  { obtain ⟨_, h', h⟩ := h,
    change pi_subtype B x ∈ sb,
    convert h',
    refine pi_subtype_ext.mpr _,
    rintro ⟨_, hi⟩,
    exact (congr_fun h ⟨⟨_, hba hi⟩, _⟩).symm }
end

lemma pi_unsubtype_union_img_inter {α : Type*} {β : α → Type*} (A : set α) (B : set α)
  (a : set (Π i : A, β i)) (b : set (Π i : B, β i)) :
  >[] (>>[A ∪ B] a ∩ >>[A ∪ B] b) = >[] a ∩ >[] b :=
begin
  simp_rw pi_unsubtype_img,
  rw set.preimage_inter,
  refine congr (congr_arg has_inter.inter _) _,
  exact (pi_subtype_subtype_subset (set.subset_union_left A B) _).symm,
  exact (pi_subtype_subtype_subset (set.subset_union_right A B) _).symm
end

end probability_theory


namespace ForIn

inductive Step.{u} (α : Type u)
| done  : α → Step α
| yield : α → Step α

class Fold.{u, v, w, z} (m : Type w → Type z) [Monad m] (α : outParam (Type u)) (s : Type v) : Type (max v u z (w+1)):=
(fold {β : Type w} (as : s) (init : β) (f : α → β → m (Step β)) : m β)

export Fold (fold)

class FoldMap.{u, w} (m : Type u → Type w) [Monad m] (s : Type u → Type u) : Type (max (u+1) w):=
(foldMap {α β : Type u} (as : s α) (init : β) (f : α → β → m (Step (α × β))) : m (s α × β))

export FoldMap (foldMap)

@[inline] instance {m} {α} [Monad m] : Fold m α (List α) :=
{ fold := fun as init f =>
    let rec @[specialize] loop
      | [], b    => pure b
      | a::as, b => do
        let s ← f a b
        (match s with
         | Step.done b     => pure b
         | Step.yield b => loop as b)
    loop as init }

@[inline] instance {m} [Monad m] : FoldMap m List :=
{ foldMap := fun as init f =>
    let rec @[specialize] loop
      | [], rs, b => pure (rs.reverse, b)
      | a::as, rs, b => do
        let s ← f a b
        (match s with
         | Step.done (a, b)     => pure ((a :: rs).reverse ++ as, b)
         | Step.yield (a, b) => loop as (a::rs) b)
    loop as [] init }

def tst1 : IO Nat :=
fold [1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 14] 0 fun a b =>
  if a % 2 == 0 then do
    IO.println (">> " ++ toString a ++ " " ++ toString b)
    (if b > 20 then return Step.done b
     else return Step.yield (a+b))
  else
    return Step.yield b

#eval tst1

def tst1' : IO Unit := do
let (as, b) ← foldMap [1, 2, 3, 4, 5, 7, 8, 9, 10, 11, 12, 14] 0 fun a b =>
  if a % 2 == 0 then do
    IO.println (">> " ++ toString a ++ " " ++ toString b)
    (if b > 20 then return Step.done (a, b)
     else return Step.yield (a/2, a+b))
  else
    return Step.yield (a, b)
IO.println as
IO.println b
pure ()

#eval tst1'

instance Prod.fold {m α β γ δ} [Monad m] [i₁ : Fold m α γ] [i₂ : Fold m β δ] : Fold m (α × β) (γ × δ) :=
{ fold := fun s init f =>
   Fold.fold s.1 init fun a x => do
     Fold.fold s.2 (Step.yield x) fun b x =>
        match x with
        | Step.done _ => return Step.done x
        | Step.yield x => do
          let s ← f (a, b) x
          (match s with
           | Step.done _     => return Step.done s
           | Step.yield _ => return Step.yield s) }

def tst2 (threshold : Nat) : IO Nat :=
fold ([1, 2, 3, 4, 5, 10], [10, 20, 30, 40, 50]) 0 fun (a, b) s => do
  IO.println (">> " ++ toString a ++ ", " ++ toString b ++ ", " ++ toString s)
  (if s > threshold then return Step.done s
   else return Step.yield (s+a+b))

#eval tst2 170
#eval tst2 800

structure Range :=
(lower upper : Nat)

@[inline] instance Range.fold {m} [Monad m] : Fold m Nat Range :=
{ fold := fun s init f =>
  let base := s.lower + s.upper - 2
  let rec @[specialize] loop : Nat → _ → _
    | 0,   b => pure b
    | i+1, b =>
      let j := base - i
      if j >= s.upper then return b
      else do
        let s ← f j b
        (match s with
         | Step.done b     => return b
         | Step.yield b => loop i b)
  loop (s.upper - 1) init }

@[inline] def range (a : Nat) (b : Option Nat := none) : Range :=
match b with
| none      => ⟨0, a⟩
| some b    => ⟨a, b⟩

instance : OfNat (Option Nat) :=
⟨fun n => some n⟩

def tst3 : IO Nat :=
fold (range 5 10) 0 fun i s => do
  IO.println (">> " ++ toString i)
  return Step.yield (s+i)

#eval tst3

theorem zeroLtOfLt : {a b : Nat} → a < b → 0 < b
| 0,   _, h => h
| a+1, b, h =>
  have a < b from Nat.ltTrans (Nat.ltSuccSelf _) h
  zeroLtOfLt this

@[inline] instance {m} {α} [Monad m] : Fold m α (Array α) :=
{ fold := fun as init f =>
    let rec @[specialize] loop : (i : Nat) → i ≤ as.size → _
      | 0, h, b   => pure b
      | i+1, h, b =>
        have h' : i < as.size          from Nat.ltOfLtOfLe (Nat.ltSuccSelf i) h
        have as.size - 1 < as.size     from Nat.subLt (zeroLtOfLt h') (decide! (0 < 1))
        have as.size - 1 - i < as.size from Nat.ltOfLeOfLt (Nat.subLe (as.size - 1) i) this; do
        let s ← f (as.get ⟨as.size - 1 - i, this⟩) b
        (match s with
         | Step.done b     => pure b
         | Step.yield b => loop i (Nat.leOfLt h') b)
    loop as.size (Nat.leRefl _) init }

-- set_option trace.compiler.ir.result true

def tst4 : IO Nat :=
fold (#[1, 2, 3, 4, 5] : Array Nat) 0 fun a b => do
  IO.println (">> " ++ toString a ++ " " ++ toString b)
  return Step.yield (a+b)

#eval tst4

end ForIn


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

namespace Option

/-!
# Bootstrapping theorems for Option

These are theorems used in the definitions of `Std.Data.List.Basic`.
New theorems should be added to `Std.Data.Option.Lemmas` if they are not needed by the bootstrap.
-/

@[simp] theorem getD_none : getD none a = a := rfl
@[simp] theorem getD_some : getD (some a) b = a := rfl

@[simp] theorem map_none' (f : α → β) : none.map f = none := rfl
@[simp] theorem map_some' (a) (f : α → β) : (some a).map f = some (f a) := rfl

@[simp] theorem none_bind (f : α → Option β) : none.bind f = none := rfl
@[simp] theorem some_bind (a) (f : α → Option β) : (some a).bind f = f a := rfl


/-
BinaryTools: Utilities for displaying and manipulating Binary data.
-/

/-
Simplification rules for ensuring type safety of Blake3Hash
-/
@[simp] theorem ByteArray.size_empty : ByteArray.empty.size = 0 :=
rfl

@[simp] theorem ByteArray.size_push (B : ByteArray) (a : UInt8) : (B.push a).size = B.size + 1 :=
by { cases B; simp only [ByteArray.push, ByteArray.size, Array.size_push] }

@[simp] theorem List.to_ByteArray_size : (L : List UInt8) → L.toByteArray.size = L.length
| [] => rfl
| a::l => by simp [List.toByteArray, to_ByteArray_loop_size]
where to_ByteArray_loop_size :
  (L : List UInt8) → (B : ByteArray) → (List.toByteArray.loop L B).size = L.length + B.size
| [], B => by simp [List.toByteArray.loop]
| a::l, B => by
    simp [List.toByteArray.loop, to_ByteArray_loop_size]
    rw [Nat.add_succ, Nat.succ_add]

universe u
universe v

/-
Type class for default conversion between two types.
-/
class Into (Target: Type v) (Source: Type u) :=
  (into: Source → Target)

export Into (into)

instance (A: Type u) : Into A A := ⟨id⟩

def String.toByteArray (s : String) : ByteArray :=
  (List.map
    (fun c : Char => c.toNat.toUInt8) s.toList).toByteArray

instance : Into ByteArray String := {
  into := String.toByteArray
}

namespace Alphabet
def base2: String := "01"
def base8: String := "01234567"
def base10: String := "0123456789"
def base16: String := "0123456789abcdef"
def base16upper: String := "0123456789ABCDEF"
def base32: String := "abcdefghijklmnopqrstuvwxyz234567"
def base32upper: String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
def base32hex : String := "0123456789abcdefghijklmnopqrstuv"
def base32hexupper : String := "0123456789ABCDEFGHIJKLMNOPQRSTUV"
def base32z : String := "ybndrfg8ejkmcpqxot1uwisza345h769"
def base36 : String := "0123456789abcdefghijklmnopqrstuvwxyz"
def base36upper : String := "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
def base58flickr : String :=
  "123456789abcdefghijkmnopqrstuvwxyzABCDEFGHJKLMNPQRSTUVWXYZ"
def base58btc : String :=
  "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
def base64 : String :=
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
def base64url : String :=
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"

end Alphabet

/-
Encode a ByteArray as a base64 String
-/
def toBase64 {I: Type u} [Into ByteArray I] (input : I) (pad: Bool := true) : String := do
  let input : ByteArray := Into.into input
  let x := ByteArray.size input % 3
  let mut bytes := input
  let mut str := ""
  if x == 1 then bytes := bytes.append [0x00, 0x00].toByteArray
  if x == 2 then bytes := bytes.append [0x00].toByteArray
  for i in [:(bytes.size / 3)] do
    let b0 := bytes.data[3 * i]
    let b1 := bytes.data[3 * i + 1]
    let b2 := bytes.data[3 * i + 2]
    let s0 := b0.shiftRight 2
    let s1 := UInt8.xor
      ((b0.land 0b00000011).shiftLeft 4)
      ((b1.land 0b11110000).shiftRight 4)
    let s2 := UInt8.xor
      ((b1.land 0b00001111).shiftLeft 2)
      ((b2.land 0b11000000).shiftRight 6)
    let s3 := b2.land 0b00111111
    str := str.push (Alphabet.base64.get s0.toNat)
    str := str.push (Alphabet.base64.get s1.toNat)
    str := str.push (Alphabet.base64.get s2.toNat)
    str := str.push (Alphabet.base64.get s3.toNat)
  if pad then do
    if x == 1 then
      str := str.set (str.length - 1) '='
      str := str.set (str.length - 2) '='
    if x == 2 then
      str := str.set (str.length - 1) '='
    return str
  else
    if x == 1 then str := str.dropRight 2
    if x == 2 then str := str.dropRight 1
    return str