import Days
import Days.Common
import Std
import Lean.Data.Parsec

namespace Days.Day05
open Days
open Common
open Std (RBMap)

open Lean.Parsec
open Lean (Parsec)

/--
The expedition can depart as soon as the final supplies have been unloaded from the ships. Supplies are stored in stacks of marked crates, but because the needed supplies are buried under many other crates, the crates need to be rearranged.

The ship has a giant cargo crane capable of moving crates between stacks. To ensure none of the crates get crushed or fall over, the crane operator will rearrange them in a series of carefully-planned steps. After the crates are rearranged, the desired crates will be at the top of each stack.

The Elves don't want to interrupt the crane operator during this delicate procedure, but they forgot to ask her which crate will end up where, and they want to be ready to unload them as soon as possible so they can embark.

They do, however, have a drawing of the starting stacks of crates and the rearrangement procedure (your puzzle input). For example:

    [D]
[N] [C]
[Z] [M] [P]
 1   2   3

move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2
In this example, there are three stacks of crates. Stack 1 contains two crates: crate Z is on the bottom, and crate N is on top. Stack 2 contains three crates; from bottom to top, they are crates M, C, and D. Finally, stack 3 contains a single crate, P.

Then, the rearrangement procedure is given. In each step of the procedure, a quantity of crates is moved from one stack to a different stack. In the first step of the above rearrangement procedure, one crate is moved from stack 2 to stack 1, resulting in this configuration:

[D]
[N] [C]
[Z] [M] [P]
 1   2   3
In the second step, three crates are moved from stack 1 to stack 3. Crates are moved one at a time, so the first crate to be moved (D) ends up below the second and third crates:

        [Z]
        [N]
    [C] [D]
    [M] [P]
 1   2   3
Then, both crates are moved from stack 2 to stack 1. Again, because crates are moved one at a time, crate C ends up below crate M:

        [Z]
        [N]
[M]     [D]
[C]     [P]
 1   2   3
Finally, one crate is moved from stack 1 to stack 2:

        [Z]
        [N]
        [D]
[C] [M] [P]
 1   2   3
The Elves just need to know which crate will end up on top of each stack; in this example, the top crates are C in stack 1, M in stack 2, and Z in stack 3, so you should combine these together and give the Elves the message CMZ.

After the rearrangement procedure completes, what crate ends up on top of each stack?
-/
structure Stacks where
  stacks: RBMap Nat (List Char) compare
  deriving Repr

def stackItem : Parsec $ Option Char := do
  _ ← pchar '['
  let c ← asciiLetter
  _ ← pchar ']'
  if (← peek?) = ' '
  then skip
  return some c

#eval stackItem "[A]".iter

def Stacks.parseLine: Parsec $ List $ Option Char :=
  parse
  where
    noItem : Parsec $ Option Char := do
      _ ← pstring "   "
      if (← peek?) = some ' '
      then skip
      return none

    parse : Parsec $ List $ Option Char := do
      let array ← many (stackItem <|> noItem)
      return array.toList

#eval Stacks.parseLine "        [Z]".iter

def Stacks.parseLines (i: Input) : List $ List $ Option Char :=
  i.lines
  |>.map (·.iter)
  |>.map Stacks.parseLine
  |>.filterMap (λ
  | .success _ res => some res
  | .error _ _ => none)

#eval Input.mk "        [Z]
        [N]
        [D]
[C] [M] [P]
 1   2   3" |> Stacks.parseLines

def Stacks.parse (input: Input) : Stacks :=
  input
  |> Stacks.parseLines
  |>.map (λ l =>
    l.enumFrom 1
    |>.foldl (init:=Std.mkRBMap Nat (List Char) compare) (λ (state: RBMap Nat (List Char) compare) (pair: Nat × Option Char) =>
      state.insert pair.fst (match pair.snd with
      | some c => [c]
      | none => [])
    )
  )
  |>.foldl (init:=Stacks.mk (Std.mkRBMap Nat (List Char) compare)) (λ (stacks: Stacks) (map: RBMap Nat (List Char) compare) =>
    stacks.stacks.mergeWith (λ _ l₁ l₂ => l₁ ++ l₂)  map
    |> Stacks.mk
  )

#eval Input.mk "        [Z]
        [N]
        [D]
[C] [M] [P]
 1   2   3" |> Stacks.parse

structure Operation where
  count: Nat
  fromStack: Nat
  toStack: Nat
  deriving Repr, DecidableEq, Inhabited

def problemSeperator := "\n\n"

def toOp (countStr fromStackStr toStackStr: String) : Option Operation := do
  let count ← String.toNat? countStr
  let fromStack ← String.toNat? fromStackStr
  let toStack ← String.toNat? toStackStr
  return Operation.mk count fromStack toStack

-- move 1 from 2 to 1
def opParser := do
  let _ ← pstring "move "
  let countStr ← many1Chars digit
  let _ ← pstring " from "
  let fromStackStr ← many1Chars digit
  let _ ← pstring " to "
  let toStackStr ← many1Chars digit
  return toOp countStr fromStackStr toStackStr

#eval opParser "move 1 from 2 to 1".iter

def Operation.parse [ToString α] (i: α) : Option Operation :=
  match opParser (ToString.toString i).iter with
  | .success _ res => res
  | .error _ _ => none

#eval Operation.parse "move 1 from 2 to 1"

def Operation.parseMany (i: Input) : List Operation :=
  i.lines
  |>.map Operation.parse
  |>.filterMap id

#eval Operation.parseMany ⟨ "move 1 from 2 to 1
move 1 from 2 to 3" ⟩ = [Operation.mk 1 2 1, Operation.mk 1 2 3]

def stacker (mover: List Char -> List Char) (input: Input): Stacks :=
  runOps
  where
    problemParts := input.splitOn problemSeperator
    startingStacksText := problemParts.get! 0
    operationsText := problemParts.get! 1
    stacks : Stacks := Stacks.parse startingStacksText
    ops : List Operation := Operation.parseMany operationsText
    runOps :=
      ops.foldl (init:=stacks) (λ
      | state, Operation.mk count fromStack toStack =>
        let source: List Char := state.stacks.find? fromStack |>.get!
        let target: List Char := state.stacks.find? toStack |>.get!
        let newSource := source.drop count
        let moved := source.take count |> mover
        let newTarget: List Char := moved.foldr (init:=target) (λ (el: Char) t => el::t)
        state.stacks.insert fromStack newSource
        |>.insert toStack newTarget
        |> Stacks.mk
      )

def stacker₉₀₀₀ : Input → Stacks := stacker (·.reverse)

#eval "    [D]
[N] [C]
[Z] [M] [P]
 1   2   3

move 1 from 2 to 1" |> Input.mk |> stacker₉₀₀₀

#eval "    [D]
[N] [C]
[Z] [M] [P]
 1   2   3

move 1 from 2 to 1
move 3 from 1 to 3" |> Input.mk |> stacker₉₀₀₀

def part₁ (input: Input) : String :=
  stacker₉₀₀₀ input
  |>.stacks
  |>.valuesList
  |>.map List.head!
  |> String.mk

/--
As you watch the crane operator expertly rearrange the crates, you notice the process isn't following your prediction.

Some mud was covering the writing on the side of the crane, and you quickly wipe it away. The crane isn't a CrateMover 9000 - it's a CrateMover 9001.

The CrateMover 9001 is notable for many new and exciting features: air conditioning, leather seats, an extra cup holder, and the ability to pick up and move multiple crates at once.

Again considering the example above, the crates begin in the same configuration:

    [D]
[N] [C]
[Z] [M] [P]
 1   2   3
Moving a single crate from stack 2 to stack 1 behaves the same as before:

[D]
[N] [C]
[Z] [M] [P]
 1   2   3
However, the action of moving three crates from stack 1 to stack 3 means that those three moved crates stay in the same order, resulting in this new configuration:

        [D]
        [N]
    [C] [Z]
    [M] [P]
 1   2   3
Next, as both crates are moved from stack 2 to stack 1, they retain their order as well:

        [D]
        [N]
[C]     [Z]
[M]     [P]
 1   2   3
Finally, a single crate is still moved from stack 1 to stack 2, but now it's crate C that gets moved:

        [D]
        [N]
        [Z]
[M] [C] [P]
 1   2   3
In this example, the CrateMover 9001 has put the crates in a totally different order: MCD.

Before the rearrangement process finishes, update your simulation so that the Elves know where they should stand to be ready to unload the final supplies. After the rearrangement procedure completes, what crate ends up on top of each stack?
-/
def stacker₉₀₀₁ : Input → Stacks := stacker id

def part₂ (input: Input) : String :=
  stacker₉₀₀₁ input
  |>.stacks
  |>.valuesList
  |>.map List.head!
  |> String.mk

def solution : Problem String := ⟨ 5, part₁, part₂ ⟩

def sample := "    [D]
[N] [C]
[Z] [M] [P]
 1   2   3

move 1 from 2 to 1
move 3 from 1 to 3
move 2 from 2 to 1
move 1 from 1 to 2"

def sampleInput := Input.mk sample

#eval stacker₉₀₀₀ sampleInput

#eval testPart₁ solution sample (expect:="CMZ")
#eval testPart₂ solution sample (expect:="MCD")


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

/- The Yoneda embedding, as a functor `yoneda : C ⥤ ((Cᵒᵖ) ⥤ (Type v₁))`,
   along with instances that it is `full` and `faithful`.

   Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`. -/

import category_theory.natural_transformation
import category_theory.opposites
import category_theory.types
import category_theory.embedding
import category_theory.natural_isomorphism

namespace category_theory

universes u₁ v₁ u₂

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

def yoneda : C ⥤ ((Cᵒᵖ) ⥤ (Type v₁)) :=
{ obj := λ X,
  { obj := λ Y : C, Y ⟶ X,
    map' := λ Y Y' f g, f ≫ g,
    map_comp' := begin intros X_1 Y Z f g, ext1, dsimp at *, erw [category.assoc] end,
    map_id' := begin intros X_1, ext1, dsimp at *, erw [category.id_comp] end },
  map' := λ X X' f, { app := λ Y g, g ≫ f } }

namespace yoneda
@[simp] lemma obj_obj (X Y : C) : ((yoneda C) X) Y = (Y ⟶ X) := rfl
@[simp] lemma obj_map (X : C) {Y Y' : C} (f : Y ⟶ Y') : ((yoneda C) X).map f = λ g, f ≫ g := rfl
@[simp] lemma map_app {X X' : C} (f : X ⟶ X') (Y : C) : ((yoneda C).map f) Y = λ g, g ≫ f := rfl

lemma obj_map_id {X Y : Cᵒᵖ} (f : X ⟶ Y) : ((yoneda C) X).map f (𝟙 X) = ((yoneda C).map f) Y (𝟙 Y) :=
by obviously

@[simp] lemma naturality {X Y : C} (α : (yoneda C) X ⟶ (yoneda C) Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α Z' h = α Z (f ≫ h) :=
begin erw [functor_to_types.naturality], refl end

instance full : full (yoneda C) :=
{ preimage := λ X Y f, (f X) (𝟙 X) }.

instance faithful : faithful (yoneda C) :=
begin
  fsplit,
  intros X Y f g p,
  injection p with h,
  convert (congr_fun (congr_fun h X) (𝟙 X)) ; simp
end

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ (yoneda C) _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category (((Cᵒᵖ) ⥤ Type v₁) × (Cᵒᵖ)) :=
category_theory.prod.{(max u₁ (v₁+1)) (max u₁ v₁) u₁ v₁} (Cᵒᵖ ⥤ Type v₁) (Cᵒᵖ)

instance prod_category_instance_2 : category ((Cᵒᵖ) × ((Cᵒᵖ) ⥤ Type v₁)) :=
category_theory.prod.{u₁ v₁ (max u₁ (v₁+1)) (max u₁ v₁)} (Cᵒᵖ) (Cᵒᵖ ⥤ Type v₁)

end yoneda

open yoneda

def yoneda_evaluation : (((Cᵒᵖ) ⥤ (Type v₁)) × (Cᵒᵖ)) ⥤ (Type (max u₁ v₁)) :=
(evaluation (Cᵒᵖ) (Type v₁)) ⋙ ulift_functor.{v₁ u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : (Cᵒᵖ ⥤ Type v₁) ×  (Cᵒᵖ)) (α : P ⟶ Q) (x : (yoneda_evaluation C) P) :
  ((yoneda_evaluation C).map α x).down = (α.1) (Q.2) ((P.1).map (α.2) (x.down)) := rfl

def yoneda_pairing : (((Cᵒᵖ) ⥤ (Type v₁)) × (Cᵒᵖ)) ⥤ (Type (max u₁ v₁)) :=
let F := (category_theory.prod.swap ((Cᵒᵖ) ⥤ (Type v₁)) (Cᵒᵖ)) in
let G := (functor.prod ((yoneda C).op) (functor.id ((Cᵒᵖ) ⥤ (Type v₁)))) in
let H := (functor.hom ((Cᵒᵖ) ⥤ (Type v₁))) in
  (F ⋙ G ⋙ H)

@[simp] lemma yoneda_pairing_map
  (P Q : (Cᵒᵖ ⥤ Type v₁) ×  (Cᵒᵖ)) (α : P ⟶ Q) (β : (yoneda_pairing C) (P.1, P.2)) :
  (yoneda_pairing C).map α β = (yoneda C).map (α.snd) ≫ β ≫ α.fst := rfl

def yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C) :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.2) (𝟙 F.2)),
    naturality' := begin intros X Y f, ext1, ext1, cases f, cases Y, cases X, dsimp at *, simp at *,
      erw [←functor_to_types.naturality, obj_map_id, functor_to_types.naturality, functor_to_types.map_id] end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.1.map a) x.down,
      naturality' := begin intros X Y f, ext1, cases x, cases F, dsimp at *, erw [functor_to_types.map_comp], refl end },
    naturality' := begin intros X Y f, ext1, ext1, ext1, cases x, cases f, cases Y, cases X,
      dsimp at *, simp at *, erw [←functor_to_types.naturality, functor_to_types.map_comp] end },
  hom_inv_id' := begin ext1, ext1, ext1, ext1, cases X, dsimp at *, simp at *,
    erw [←functor_to_types.naturality, obj_map_id, functor_to_types.naturality, functor_to_types.map_id] end,
  inv_hom_id' := begin ext1, ext1, ext1, cases x, cases X, dsimp at *, erw [functor_to_types.map_id] end }.

end category_theory


/-
  Runs theorem naming evaluation.
-/

import all
import backends.bfs.openai
import utils.util
import evaluation

section main

meta structure TheoremNamingEvalResult : Type :=
(decl_nm : name) -- name of top-level theorem (i.e. ground truth)
(decl_tp : expr) -- goal of top-level theorem
(predictions : list (string × native.float)) -- sorted list of predictions

meta instance : has_to_tactic_json TheoremNamingEvalResult :=
let fn : Π (σ : TheoremNamingEvalResult), tactic json := λ σ, match σ with
| ⟨nm, tp, preds⟩ := do {
  tp_msg ← json.of_string <$> format.to_string <$> format.flatten <$> tactic.pp tp,
  let pred_msg : json := json.array $ preds.map (λ ⟨candidate_name, score⟩, json.array $ [candidate_name, score]),
  pure $ json.object $ [
      ("name", nm.to_string)
    , ("type", tp_msg)
    , ("predictions", pred_msg)
  ]
}
end
in ⟨fn⟩
open openai

meta def autoname_core (e : expr) (req : CompletionRequest) (engine_id : string) (api_key : string) : tactic (list $ string × native.float) := do {
  ts_str ← format.to_string <$> format.flatten <$> (tactic.with_full_names $ tactic.pp e),
  let prompt : string := "[LN] GOAL " ++ ts_str ++ (format!" {req.prompt_token} ").to_string,
  let completion_request := {prompt := prompt, ..req},
  response_msg ← tactic.unsafe_run_io $ (openai_api engine_id api_key).query completion_request,
  responses ←
    ((list.qsort (λ x y : string × native.float, prod.snd x > prod.snd y) <$>
      unwrap_lm_response_logprobs "autonamer" response_msg) -- >>= list.dedup'
      ),
  eval_trace format! "[autoname_core] RESPONSES: {responses}",
  pure responses
}

meta def get_theorem_naming_result
  (decl_nm : name)
  (decl_tp : expr)
  (req : openai.CompletionRequest)
  (engine_id : string)
  (api_key : string)
  : tactic TheoremNamingEvalResult := do {
  predictions ← autoname_core decl_tp req engine_id api_key,
  pure $ {decl_nm := decl_nm, decl_tp := decl_tp, predictions := predictions}
}

meta def theorem_naming_eval_core
  (decls_file : string)
  (dest : string)
  (engine_id : string)
  (api_key : string)
  (req : openai.CompletionRequest)
  : io unit := do {
  nm_strs ← (io.mk_file_handle decls_file io.mode.read >>= λ f,
  (string.split (λ c, c = '\n') <$> buffer.to_string <$> io.fs.read_to_end f)),

  -- io.put_str_ln' format!"NM STRS: {nm_strs}",

  (nms : list (name × list name)) ← (nm_strs.filter $ λ nm_str, string.length nm_str > 0).mmap $ λ nm_str, do {
    ((io.run_tactic' ∘ parse_decl_nm_and_open_ns) $ nm_str)
  },
  io.put_str_ln' format!"[theorem_naming_eval_core] GOT {nms.length} NAMES",

  let nms_unfiltered_len := nms.length,
  nms ← io.run_tactic' $ do {
    env ← tactic.get_env,
    nms.mfilter $ λ ⟨nm, _⟩, (do {
      decl ← env.get nm,
      pure decl.is_theorem
    } <|> pure ff)
  },

  io.put_str_ln' format! "[evaluation_harness_from_decls_file] WARNING: SKIPPING {nms_unfiltered_len - nms.length}",

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

  let process_result : TheoremNamingEvalResult → io unit := λ result, do {
    msg ← json.unparse <$> (io.run_tactic' $ has_to_tactic_json.to_tactic_json result),
    io.fs.put_str_ln_flush dest_handle msg
  },
  for_ nms $ λ ⟨nm, _⟩, do {
    tp ← io.run_tactic' $ do {
      env ← tactic.get_env,
      decl ← env.get nm,
      pure $ decl.type
    },
    result ← io.run_tactic' $ get_theorem_naming_result nm tp req engine_id api_key,
    process_result result
  }
}

/--
  Loops through all the names in `names_file`, queries the model given by `engine_id` for `n` completions,
  and records the predictions
-/
meta def main : io unit := do {
  args ← io.cmdline_args,
  decls_file ← args.nth_except 0 "decls_file",
  dest ← args.nth_except 1 "dest",
  max_tokens ← string.to_nat <$> args.nth_except 2 "max_tokens",
  (some temperature) ← (native.float.of_string <$> (args.nth_except 3 "temperature")) | io.fail "failed to parse temperature",
  (some top_p) ← (native.float.of_string <$> (args.nth_except 4 "top_p")) | io.fail "failed to parse top_p",
  n ← string.to_nat <$> args.nth_except 5 "n",
  best_of ← string.to_nat <$> args.nth_except 6 "best_of",
  fuel ← string.to_nat <$> args.nth_except 7 "fuel",
  max_width ← string.to_nat <$> args.nth_except 8 "max_width",
  max_depth ← string.to_nat <$> args.nth_except 9 "max_depth",
  engine_id ← args.nth_except 10 "engine_id",
  api_key ← args.nth_except 11 "api_key",
  tac_timeout ← string.to_nat <$> args.nth_except 12 "tac_timeout in seconds",
  global_timeout ← string.to_nat <$> args.nth_except 13 "global_timeout in seconds",

  let req : openai.CompletionRequest := {
    max_tokens := max_tokens,
    temperature := temperature,
    top_p := top_p,
    n := n,
    best_of := best_of,
    prompt_token := "PREDICTNAME",
    ..openai.default_partial_req
  },

  theorem_naming_eval_core decls_file dest engine_id api_key req
  -- evaluation_harness_from_decls_file (SEARCH_CORE req engine_id api_key fuel)
  --   decls_file dest global_timeout
  --    $ BFSState.of_current_state 0 max_width max_depth tac_timeout
}
end main


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v3) = ((a2).read i1) → ((a2).write i1 (v3)) ≠ (a2) → False := by
  arr


/-
File: signature_recover_public_key_assert_nn_le_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
import .signature_recover_public_key_assert_le_soundness
open tactic

open starkware.cairo.common.math

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.math.assert_nn_le autogenerated soundness theorem -/

theorem auto_sound_assert_nn_le
    -- arguments
    (range_check_ptr a b : F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_assert_nn_le σ.pc)
    -- all dependencies are in memory
    (h_mem_0 : mem_at mem code_assert_nn (σ.pc  - 9))
    (h_mem_1 : mem_at mem code_assert_le (σ.pc  - 5))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 5))
    (hin_a : a = mem (σ.fp - 4))
    (hin_b : b = mem (σ.fp - 3))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 14 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 5)) (mem $ τ.ap - 1)
        (spec_assert_nn_le mem κ range_check_ptr a b (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_assert_nn_le at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_sub hpc2 (auto_sound_assert_nn mem _ range_check_ptr a _ _ _),
  { rw hpc3, norm_num2, exact h_mem_0 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call4 ap4 h_call4,
  rcases h_call4 with ⟨h_call4_ap_offset, h_call4⟩,
  rcases h_call4 with ⟨rc_m4, rc_mle4, hl_range_check_ptr₁, h_call4⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap4 - 1) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  try { simp only [arg0 ,arg1] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0 ,arg1] at h_call4 },
  rw [hin_range_check_ptr] at h_call4,
  clear arg0 arg1,
  -- function call
  step_assert_eq hpc4 with arg0,
  step_assert_eq hpc5 with arg1,
  step_sub hpc6 (auto_sound_assert_le mem _ range_check_ptr₁ a b _ _ _ _ _),
  { rw hpc7, norm_num2, exact h_mem_1 },
  { rw hpc7, norm_num2, exact h_mem_0 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call8 ap8 h_call8,
  rcases h_call8 with ⟨h_call8_ap_offset, h_call8⟩,
  rcases h_call8 with ⟨rc_m8, rc_mle8, hl_range_check_ptr₂, h_call8⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap8 - 1) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  try { simp only [arg0 ,arg1] at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1] at h_call8 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call8,
  clear arg0 arg1,
  -- return
  step_ret hpc8,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call4_ap_offset ,h_call8_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m4+rc_m8+0+0), split,
  linarith [rc_mle4, rc_mle8],
  split,
  { arith_simps,
    rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_assert_nn_le mem _ range_check_ptr a b _,
  { apply sound_assert_nn_le, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_assert_nn_le],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call4],
  use_only [range_check_ptr₁],
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
  have spec4 := h_call4 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec4,
  try { dsimp at spec4, arith_simps at spec4 },
  use_only [spec4],
  use_only [κ_call8],
  use_only [range_check_ptr₂],
  have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
  have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
  have spec8 := h_call8 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec8,
  try { dsimp at spec8, arith_simps at spec8 },
  use_only [spec8],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_range_check_ptr₂] }, },
  try { simp only [h_call4_ap_offset, h_call8_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


structure Foo where
  foo : Nat

def baz {x : _} := Foo.mk x -- works fine
example {x : _} := Foo.mk x
def qux {x : _} : Foo := Foo.mk x
example {x : _} : Foo := Foo.mk x


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Arthur Paulino, Gabriel Ebner, Mario Carneiro
-/
import Lean
import Mathlib.Tactic.Core

namespace Mathlib.Tactic

open Lean Parser.Tactic Elab.Tactic

syntax simpaArgsRest := (config)? (discharger)? &" only "? (simpArgs)? (withArgs)? (usingArg)?

syntax "simpa" "!"? "?"? simpaArgsRest : tactic
macro "simpa!" rest:simpaArgsRest : tactic => `(tactic| simpa ! $rest:simpaArgsRest)
macro "simpa?" rest:simpaArgsRest : tactic => `(tactic| simpa ? $rest:simpaArgsRest)
macro "simpa!?" rest:simpaArgsRest : tactic => `(tactic| simpa !? $rest:simpaArgsRest)

-- TODO
syntax "squeeze_simpa" "!"? "?"? simpaArgsRest : tactic
macro "squeeze_simpa!" rest:simpaArgsRest : tactic => `(tactic| squeeze_simpa ! $rest:simpaArgsRest)
macro "squeeze_simpa?" rest:simpaArgsRest : tactic => `(tactic| squeeze_simpa ? $rest:simpaArgsRest)
macro "squeeze_simpa!?" rest:simpaArgsRest : tactic => `(tactic| squeeze_simpa !? $rest:simpaArgsRest)

/--
This is a "finishing" tactic modification of `simp`. It has two forms.

* `simpa [rules, ⋯] using e` will simplify the goal and the type of
  `e` using `rules`, then try to close the goal using `e`.

  Simplifying the type of `e` makes it more likely to match the goal
  (which has also been simplified). This construction also tends to be
  more robust under changes to the simp lemma set.

* `simpa [rules, ⋯]` will simplify the goal and the type of a
  hypothesis `this` if present in the context, then try to close the goal using
  the `assumption` tactic.

#TODO: implement `with ⋯` behavior
#TODO: implement `!`
#TODO: implement `?`
-/
elab_rules : tactic
| `(tactic| simpa $[!%$unfold]? $[?%$squeeze]? $[$cfg:config]? $[$disch:discharger]? $[only%$only]?
      $[[$args,*]]? $[with $wth]? $[using $usingArg]?) => do
  let nGoals := (← getUnsolvedGoals).length
  evalTactic $ ← `(tactic|simp $(cfg)? $(disch)? $[only%$only]? $[[$[$args],*]]?)
  if (← getUnsolvedGoals).length < nGoals then
    throwError "try 'simp' instead of 'simpa'"
  match usingArg with
  | none   =>
    evalTactic $ ← `(tactic|try simp $(cfg)? $(disch)? $[only%$only]? $[[$[$args],*]]? at this)
    evalTactic $ ← `(tactic|assumption)
  | some e =>
    evalTactic $ ← `(tactic|have h := $e)
    evalTactic $ ← `(tactic|try simp $(cfg)? $(disch)? $[only%$only]? $[[$[$args],*]]? at h)
    evalTactic $ ← `(tactic|exact h)


import .yul_ast
import .aux

import tactic.linarith

import data.finset.basic
import data.vector
import init.data.fin.ops
import init.data.list.basic

set_option class.instance_max_depth 100

def FTContext := Identifier → option (ℕ × ℕ)
def empΓ : FTContext := λ_, none

def VarStore (vars : finset Identifier) := ∀ i : Identifier, (i ∈ vars) → Literal
def empStore : VarStore ∅
  | i i_in_emp := absurd i_in_emp (finset.not_mem_empty i)

namespace YulCommands

variable Γ : FTContext

inductive IsInFor : Type
| NestedInFor : IsInFor
| NotNestedInFor : IsInFor

inductive IsInFunc : Type
| InFunc : IsInFunc
| NotInFunc : IsInFunc

inductive TermType : Type
| BlockList :  finset Identifier → finset Identifier → IsInFor → IsInFunc → TermType
| CBlock : finset Identifier → IsInFor → IsInFunc → TermType
| SwitchBody : finset Identifier → IsInFor → IsInFunc → TermType
| CExpr : finset Identifier → ℕ → TermType
| CStatement : finset Identifier → finset Identifier → IsInFor → IsInFunc → TermType

open IsInFor
open IsInFunc
open TermType

inductive YulTerm : TermType → Type
| EmpCBlock :
    ∀{vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (BlockList vars vars b b')
| SeqCBlock  :
    ∀ {vars : finset Identifier} (vars' : finset Identifier)
      {vars'' : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CStatement vars vars' b b') ->
    YulTerm (BlockList vars' vars'' b b') →
    YulTerm (BlockList vars vars'' b b')

| NestedScope :
    ∀ {vars : finset Identifier} (inner_vars inner_vars' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore inner_vars →
    YulTerm (BlockList (inner_vars ∪ vars) (inner_vars' ∪ vars) b b') →
    YulTerm (CBlock vars b b')

| CCase :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      Literal → YulTerm (CBlock vars b b') → YulTerm (SwitchBody vars b b') →
      YulTerm (SwitchBody vars b b')
| CDefault :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CBlock vars b b') → YulTerm (SwitchBody vars b b')
| CNone :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (SwitchBody vars b b')

| CFunctionCall :
    ∀ {vars : finset Identifier}
      (f_id : Identifier) (n : ℕ) {m : ℕ},
        (Γ f_id = some (n,m)) →
        (fin n → YulTerm (CExpr vars 1)) →
        YulTerm (CExpr vars m)
| CId :
    ∀ {vars : finset Identifier} (id : Identifier),
    id ∈ vars → YulTerm (CExpr vars 1)
| CLit :
    ∀ {vars : finset Identifier},
      Literal → YulTerm (CExpr vars 1)
| Scope : ∀ {vars_outer : finset Identifier} (vars_inner vars_fin : finset Identifier)
               {n : ℕ} (ret_vars : vector Identifier n),
    VarStore (vars_inner ∪ (tofinset' ret_vars)) →
    YulTerm (BlockList (vars_inner ∪ (tofinset' ret_vars)) (vars_fin ∪ (tofinset' ret_vars)) NotNestedInFor InFunc) →
    YulTerm (CExpr vars_outer n)
| Result :
    ∀ {vars : finset Identifier} {n : ℕ},
      vector Literal n → YulTerm (CExpr vars n)

| CBlock :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CBlock vars b b') → YulTerm (CStatement vars vars b b')
  -- Function definitions already parsed into FTContext.
| CVariableDeclarationAss :
    ∀ {vars : finset Identifier} (n : ℕ)
        (new_vars : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      YulTerm (CExpr vars n) →
      YulTerm (CStatement vars (vars ∪ (tofinset new_vars)) b b')
| CVariableDeclaration :
    ∀ {vars : finset Identifier} (n : ℕ)
        (new_vars : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      YulTerm (CStatement vars (vars ∪ (tofinset new_vars)) b b')
| CAssignment :
    ∀ {vars : finset Identifier} (n : ℕ)
        (ids : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      tofinset ids ⊆ vars → YulTerm (CExpr vars n) →
      YulTerm (CStatement vars vars b b')
| CIf :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CExpr vars 1) → YulTerm (CBlock vars b b') →
      YulTerm (CStatement vars vars b b')
| CExpressionStatement :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CExpr vars 0) -> YulTerm (CStatement vars vars b b')
| CSwitch : ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CExpr vars 1) →
    YulTerm (SwitchBody vars b b') →
    YulTerm (CStatement vars vars b b')
| CFor :
  ∀ {vars : finset Identifier} (inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    YulTerm (BlockList vars (vars ∪ inner_vars) NotNestedInFor b') →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CStatement vars vars b b')
| CBreak :
    ∀ {vars : finset Identifier} {b' : IsInFunc},
      YulTerm (CStatement vars vars NestedInFor b')
| CContinue :
    ∀ {vars : finset Identifier} {b' : IsInFunc},
      YulTerm (CStatement vars vars NestedInFor b')
| CLeave :
    ∀ {vars : finset Identifier} {b : IsInFor},
      YulTerm (CStatement vars vars b InFunc)
| ForExecInit :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars) NotNestedInFor b') →
     YulTerm (CStatement vars vars b b')
| ForCheckCond :
  ∀ {vars : finset Identifier} (inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (CStatement vars vars b b')
| ForExecBody :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    vars ∪ inner_vars ⊆ vars ∪ curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (CStatement vars vars b b')
| ForExecPost :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CStatement vars vars b b')
| Skip :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CStatement vars vars b b')
  -- ForCheckCond, ForExecbody and Skip not in Yul specification, added for small step semantics.

open YulTerm

def getVariableUpdate : ∀ {t : TermType} , YulTerm Γ t → option (finset Identifier × finset Identifier)
| (BlockList vars vars' _ _) _ := some (vars, vars')
| (CBlock _ _ _) _ := none
| (SwitchBody _ _ _) _ := none
| (CExpr _ _) _ := none
| (CStatement vars vars' _ _) _ := some (vars, vars')

lemma term_scope_monotonic :
        ∀ {t : TermType} (term : YulTerm Γ t) (vars vars' : finset Identifier),
        getVariableUpdate Γ term = some (vars, vars') → vars ⊆ vars' :=
  begin
    intros ttype t,
    induction t,

    -- EmpCBlock
    intros vars vars' is_var_update i,
    intro i_in_vars,
    rw getVariableUpdate at is_var_update,
    injection is_var_update with is_var_update,
    injection is_var_update with vars_eq_tvars tvars_eq_tvars,
    rw [←tvars_eq_tvars, vars_eq_tvars],
    exact i_in_vars,

    -- SeqCBlock
    intros vars vars' is_var_update i,
    intro i_in_vars,
    rw getVariableUpdate at is_var_update,
    injection is_var_update with is_var_update,
    injection is_var_update with vars_eq_tvars tvars''_eq_vars',
    rw vars_eq_tvars at t_ᾰ,
    have int₁ := t_ih_ᾰ vars t_vars' _ i_in_vars,
    rw tvars''_eq_vars' at t_ᾰ_1,
    have int₂ := t_ih_ᾰ_1 t_vars' vars' _ int₁,
    exact int₂,
    rw getVariableUpdate,
    injection is_var_update with _ tvars''_eq_vars',
    rw tvars''_eq_vars',
    rw getVariableUpdate,
    rw vars_eq_tvars,

    -- Block, SwitchBody & Expr
    repeat {
      intros vars vars',
      intro f,
      rw getVariableUpdate at f,
      exfalso,
      exact option.some_ne_none (vars, vars') (eq.symm f),
    },

    -- CStatements that do not bring new variables into scope.
    repeat {
      intros vars vars',
      intro is_var_update,
      rw getVariableUpdate at is_var_update,
      injection is_var_update with is_var_update,
      injection is_var_update with vars_eq_tvars tvars_eq_vars',
      rw [←tvars_eq_vars', vars_eq_tvars],
      exact finset.subset.refl vars,
    },

    -- CVariableDeclaration, CVariableDeclarationAss
    repeat {
      intros vars vars',
      intro is_var_update,
      rw getVariableUpdate at is_var_update,
      injection is_var_update with is_var_update,
      injection is_var_update with vars_eq eq_vars',
      rw [←vars_eq,←eq_vars'],
      exact finset.subset_union_left _ _,
    },

  end

def frame_TermType : TermType → finset Identifier → TermType
| (BlockList vars vars' b b') fvars :=
    BlockList (vars ∪ fvars) (vars' ∪ fvars) b b'
| (CBlock vars b b') fvars := CBlock (vars ∪ fvars) b b'
| (SwitchBody vars b b') fvars := SwitchBody (vars ∪ fvars) b b'
| (CExpr vars n) fvars := CExpr (vars ∪ fvars) n
| (CStatement vars vars' b b') fvars :=
    CStatement (vars ∪ fvars) (vars' ∪ fvars) b b'

lemma frame_lemma :
  ∀ s₁ s₂ s₃ : finset Identifier,
    s₁ ∪ s₂ ∪ s₃ = s₁ ∪ s₃ ∪ s₂ :=
  begin
    intros s₁ s₂ s₃,
    rw (finset.union_assoc s₁ s₂ s₃),
    rw (finset.union_assoc s₁ s₃ s₂),
    rw (finset.union_comm s₂ s₃),
  end

def frame :
  ∀ {t : TermType} (fvars : finset Identifier),
    YulTerm Γ t → YulTerm Γ (frame_TermType t fvars)
| (BlockList _ _ _ _) fvars EmpCBlock := EmpCBlock
| (BlockList _ _ _ _) fvars (SeqCBlock vars' cstmnt cblklst') :=
    SeqCBlock (vars' ∪ fvars) (frame fvars cstmnt) (frame fvars cblklst')
| (CBlock vars b b') fvars (NestedScope inner_vars inner_vars' σ blklst) :=
    let inner_vars_eq:= finset.union_assoc inner_vars vars fvars,
       inner_vars'_eq := finset.union_assoc inner_vars' vars fvars,
       cast (cblklst : YulTerm Γ (BlockList((inner_vars ∪ vars) ∪ fvars) ((inner_vars' ∪ vars) ∪ fvars) b b')) :
                 YulTerm Γ (BlockList (inner_vars ∪ (vars ∪ fvars)) (inner_vars' ∪ (vars ∪ fvars)) b b') :=
              eq.rec (eq.rec cblklst inner_vars_eq) inner_vars'_eq
      in NestedScope inner_vars inner_vars' σ (cast $ frame fvars blklst)
| (SwitchBody _ _ _) fvars (CCase lit blk swtchbody) :=
    CCase lit (frame fvars blk) (frame fvars swtchbody)
| (SwitchBody _ _ _) fvars (CDefault blk) :=
    CDefault (frame fvars blk)
| (SwitchBody _ _ _) fvars CNone :=
    CNone
| (CExpr vars m) fvars (CFunctionCall f_id n p args) :=
    CFunctionCall f_id n p (λi, frame fvars (args i))
| (CExpr vars 1) fvars (CId i i_in_vars) :=
    CId i (finset.mem_of_subset (finset.subset_union_left vars fvars) i_in_vars)
| (CExpr _ 1) fvars (CLit lit) := CLit lit
| (CExpr _ _) fvars (Scope vars_inner vars_inner' ret_vars σ stmnt) :=
    Scope vars_inner vars_inner' ret_vars σ stmnt
| (CExpr _ _) fvars (Result res_vec) :=
    Result res_vec
| (CStatement _ _ _ _) fvars (CBlock blk) :=
    CBlock (frame fvars blk)
| (CStatement vars _ b b') fvars (CVariableDeclarationAss n new_vars cexpr) :=
    let cast (cstmnt : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ fvars ∪ tofinset new_vars) b b'))
            : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ tofinset new_vars ∪ fvars) b b') :=
              eq.rec cstmnt (finset.union_right_comm vars fvars (tofinset new_vars))
    in cast $ CVariableDeclarationAss n new_vars (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CVariableDeclaration n new_vars) :=
    let cast (cstmnt : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ fvars ∪ tofinset new_vars) b b'))
            : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ tofinset new_vars ∪ fvars) b b') :=
              eq.rec cstmnt (finset.union_right_comm vars fvars (tofinset new_vars))
    in cast $ CVariableDeclaration n new_vars
| (CStatement vars _ b b') fvars (CAssignment n ids in_scope cexpr) :=
    CAssignment n ids
      (has_subset.subset.trans in_scope (finset.subset_union_left vars fvars))
      (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CIf cexpr blk) :=
    CIf (frame fvars cexpr) (frame fvars blk)
| (CStatement vars _ b b') fvars (CExpressionStatement cexpr) :=
    CExpressionStatement (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CSwitch cexpr swtchbody) :=
    CSwitch (frame fvars cexpr) (frame fvars swtchbody)
| (CStatement vars _ b b') fvars (CFor inner_vars inner_vars' inner_vars'' init cond body post) :=
    let init_framed : YulTerm Γ (BlockList (vars ∪ fvars) (vars ∪ fvars ∪ inner_vars) NotNestedInFor b') :=
          begin
            have init_framed := frame fvars init,
            rw frame_TermType at init_framed,
            apply eq.rec init_framed,
            rw frame_lemma,
          end,
        cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        body_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have body_framed := frame fvars body,
            rw frame_TermType at body_framed,
            apply eq.rec body_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end
    in CFor inner_vars inner_vars' inner_vars''
        init_framed cond_framed body_framed post_framed
| (CStatement vars _ b b') fvars CBreak := CBreak
| (CStatement vars _ b b') fvars CContinue := CContinue
| (CStatement vars _ b b') fvars CLeave := CLeave
| (CStatement vars _ b b') fvars
      (ForExecInit curr_inner_vars inner_vars inner_vars' inner_vars'' σ cond loop post eval_init) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_init_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars) NotNestedInFor b') :=
          begin
            have eval_init_framed := frame fvars eval_init,
            rw frame_TermType at eval_init_framed,
            apply eq.rec eval_init_framed,
            rw (frame_lemma vars curr_inner_vars fvars),
            rw (frame_lemma vars inner_vars fvars),
          end
    in ForExecInit curr_inner_vars inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_init_framed
| (CStatement vars _ b b') fvars
      (ForCheckCond inner_vars inner_vars' inner_vars'' σ cond loop post eval_cond) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have eval_cond_framed := frame fvars eval_cond,
            rw frame_TermType at eval_cond_framed,
            apply eq.rec eval_cond_framed,
            rw (frame_lemma vars inner_vars fvars),
          end
    in ForCheckCond inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_cond_framed
| (CStatement vars _ b b') fvars
      (ForExecBody curr_inner_vars inner_vars inner_vars' inner_vars'' σ p cond loop post eval_loop) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_loop_framed :YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have eval_loop_framed := frame fvars eval_loop,
            rw frame_TermType at eval_loop_framed,
            apply eq.rec eval_loop_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars curr_inner_vars fvars),
          end,
        p' : vars ∪ fvars ∪ inner_vars ⊆ vars ∪ fvars ∪ curr_inner_vars :=
          begin
            intros i i_in,
            repeat {
              rw finset.mem_union at i_in,
            },
            repeat {
              rw finset.mem_union,
            },
            cases i_in with x y,
            exact or.inl x,
            cases finset.mem_union.1 (p (finset.mem_union_right vars y)) with h,
            exact or.inl (or.inl h),
            exact or.inr h,
          end
    in ForExecBody curr_inner_vars inner_vars inner_vars' inner_vars'' σ p'
        cond_framed loop_framed post_framed eval_loop_framed
| (CStatement vars _ b b') fvars
      (ForExecPost curr_inner_vars inner_vars inner_vars' inner_vars'' σ cond loop post eval_post) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have eval_post_framed := frame fvars eval_post,
            rw frame_TermType at eval_post_framed,
            apply eq.rec eval_post_framed,
            rw (frame_lemma vars inner_vars'' fvars),
            rw (frame_lemma vars curr_inner_vars fvars),
          end
    in ForExecPost curr_inner_vars inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_post_framed
| (CStatement vars _ b b') fvars Skip := Skip

def are_args_reduced :
  ∀ {vars : finset Identifier} {n : ℕ},
    vector (YulTerm Γ (CExpr vars 1)) n → Prop
| _ 0 _ := true
| vars (nat.succ n) ⟨ (Result _) :: cexprs, p ⟩ :=
  are_args_reduced
    (⟨
      cexprs,
      by {
            rw list.length at p,
            exact (nat.add_right_cancel p),
          }
     ⟩ : vector (YulTerm Γ (CExpr vars 1)) n)
| _ (nat.succ n) ⟨ _ :: _, _ ⟩ := false

instance (vars : finset Identifier) (n : ℕ)
  (cexprs : vector (YulTerm Γ (CExpr vars 1)) n) :
    decidable (are_args_reduced Γ cexprs) :=
  begin
    induction n,
    rw are_args_reduced,
    apply decidable.is_true,
    trivial,
    cases cexprs,
    cases cexprs_val,
    exfalso,
    exact list.ne_nil_of_length_eq_succ cexprs_property (eq.refl list.nil),
    cases cexprs_val_hd,
    repeat {
      rw are_args_reduced,
      apply decidable.is_false,
      trivial,
    },
    rw are_args_reduced,
    exact n_ih ⟨ cexprs_val_tl, _ ⟩,
  end

lemma nil_reduced :
  ∀ {Γ : FTContext} {vars : finset Identifier},
    @are_args_reduced Γ vars 0 vector.nil :=
  begin
    intros Γ vars,
    rw are_args_reduced,
    trivial,
  end

def is_result :
  ∀ {vars : finset Identifier} {n : ℕ},
    YulTerm Γ (CExpr vars n) -> Prop
| _ _ (Result _) := true
| _ _ (CLit _) := false
| _ _ (CId _ _) := false
| _ _ (CFunctionCall _ _ _ _) := false
| _ _ (Scope _ _ _ _ _) := false

instance
  (vars : finset Identifier) (n : ℕ)
    (cexpr : YulTerm Γ (CExpr vars n)) : decidable (is_result Γ cexpr) :=
  begin
    cases cexpr,
    repeat {
      rw is_result,
      apply decidable.is_false,
      trivial,
    },
    rw is_result,
    apply decidable.is_true,
    trivial,
  end

def is_skip :
  ∀ {vars vars': finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (CStatement vars vars' b b') -> Prop
| _ _ _ _ Skip := true
| _ _ _ _ (CBlock _) := false
| _ _ _ _ (CVariableDeclarationAss _ _ _) := false
| _ _ _ _ (CVariableDeclaration _ _) := false
| _ _ _ _ (CAssignment _ _ _ _) := false
| _ _ _ _ (CIf _ _) := false
| _ _ _ _ (CExpressionStatement _) := false
| _ _ _ _ (CSwitch _ _) := false
| _ _ _ _ (CFor _ _ _ _ _ _ _) := false
| _ _ _ _ CBreak := false
| _ _ _ _ CContinue := false
| _ _ _ _ CLeave := false
| _ _ _ _ (ForExecInit _ _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForCheckCond _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForExecBody _ _ _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForExecPost _ _ _ _ _ _ _ _ _) := false

lemma is_skip_imp_vars_eq_vars' :
  ∀ {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
      {cstmnt : YulTerm Γ (CStatement vars vars' b b')},
    is_skip Γ cstmnt → vars' = vars :=
  begin
    intros vars vars' b b' cstmnt cstmnt_is_skip,
    cases cstmnt,
    repeat {
      rw is_skip at cstmnt_is_skip,
    },
    repeat {
      exfalso,
      exact cstmnt_is_skip,
    },
  end

instance is_skip_decidable {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
  {stmnt : YulTerm Γ (CStatement vars vars' b b')} : decidable (is_skip Γ stmnt) :=
  begin
    cases stmnt,
    repeat{
      rw is_skip,
      apply decidable.is_false,
      trivial,
    },
    rw is_skip,
    apply decidable.is_true,
    trivial,
  end

def is_empcblock :
  ∀ {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (BlockList vars vars' b b') → Prop
| _ _ _ _ EmpCBlock := true
| _ _ _ _ _ := false

instance empcblock_decidable
  {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
    {blklst : YulTerm Γ (BlockList vars vars' b b')} :
  decidable (is_empcblock Γ blklst) :=
  begin
    cases blklst,
    rw is_empcblock,
    apply decidable.is_true,
    trivial,
    rw is_empcblock,
    apply decidable.is_false,
    trivial,
  end

lemma is_empcblock_imp_vars_eq_vars' :
  ∀ {vars vars' : finset Identifier} {b : IsInFor}
      {b' : IsInFunc} {cblk : YulTerm Γ (BlockList vars vars' b b')},
    is_empcblock Γ cblk → vars = vars' :=
  begin
    intros vars vars' b b' cblk cblk_is_empcblock,
    cases cblk,
    refl,
    exfalso,
    rw is_empcblock at cblk_is_empcblock,
    exact cblk_is_empcblock,
  end

def is_empblock :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (CBlock vars b b') → Prop
| _ _ _ (NestedScope _ _ _ blklst) := is_empcblock Γ blklst

instance (vars : finset Identifier) (b : IsInFor) (b' : IsInFunc)
  (blk : YulTerm Γ (CBlock vars b b')) : decidable (is_empblock Γ blk) :=
  begin
    cases blk,
    rw is_empblock,
    exact YulCommands.empcblock_decidable Γ,
  end

def to_literal : ∀ {vars : finset Identifier} {n : ℕ}
      (cexpr : YulTerm Γ (CExpr vars n)), is_result Γ cexpr → vector Literal n
  | _ _ cexpr@(CFunctionCall _ _ _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(CId _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(CLit l) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(Scope _ _ _ _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(Result res_vec) _ := res_vec

def getCase :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    Literal -> YulTerm Γ (SwitchBody vars b b') → YulTerm Γ (CBlock vars b b')
| _ _ _ _ CNone := NestedScope ∅ ∅ empStore EmpCBlock
| _ _ _ _ (CDefault blk) := blk
| _ _ _ l (CCase lit blk swtchbody') :=
  if l = lit
  then blk
  else getCase l swtchbody'

lemma reduced_and_n_tail_reduced_imp_n_lit
  {vars : finset Identifier}
  (cexpr : YulTerm Γ (CExpr vars 1))
  {n : ℕ}
  (cexprs : vector (YulTerm Γ (CExpr vars 1)) n) :
    ¬ (are_args_reduced Γ (vector.cons cexpr cexprs)) → are_args_reduced Γ cexprs →
      ¬ is_result Γ cexpr :=
  begin
    intros full_not_red tail_red,
    cases cexpr,
    repeat {
      rw is_result,
      intro f,
      exact f,
    },
    cases cexprs,
    exfalso,
    rw vector.cons at full_not_red,
    rw are_args_reduced at full_not_red,
    exact full_not_red(tail_red),
  end

def get_lits :
  ∀ {vars : finset Identifier} {n : ℕ}
    (arg_cexprs : vector (YulTerm Γ (CExpr vars 1)) n),
  are_args_reduced Γ arg_cexprs → vector Literal n
| _ 0 _ _ := vector.nil
| vars (nat.succ n) ⟨(Result lit) :: lit_cexprs, len_p⟩ p :=
  let lit_cexprs_vec' : vector (YulTerm Γ (CExpr vars 1)) n :=
        ⟨ lit_cexprs,
          by {
            rw list.length at len_p,
            exact (nat.add_right_cancel len_p),
          }
        ⟩
  in vector.cons lit.head $
      get_lits lit_cexprs_vec' $
        by {
          rw are_args_reduced at p,
          exact p,
        }

end YulCommands


import Lean.Meta
import Lean.Elab
import Scratch.IntrosRwFind
open Lean
open Meta
open Lean.Elab.Tactic
open Elab
open introsRwFind

-- copied from source

def g (x : Nat) : Nat :=
dbgTrace ("g: " ++ toString x) $ fun _ =>
  x + 1

def f1 (x : Nat) : Nat :=
dbgSleep 1000 $ fun _ =>
dbgTrace ("f1: " ++ toString x) $ fun _ =>
  g (x + 1)

def f2 (x : Nat) : Nat :=
dbgSleep 100 $ fun _ =>
dbgTrace ("f2: " ++ toString x) $ fun  _ =>
  g x

def tst (n : Nat) : IO Nat :=
let t1 := Task.spawn fun _ => f1 n;
let t2 := Task.spawn fun _ => f2 n;
dbgSleep 1000 $ fun _ =>
IO.println (toString t1.get ++ " " ++ toString t2.get) *>
pure t1.get

#eval tst 10

#check tst 20

syntax (name:= tasktac) "tasktac" : tactic
@[tactic tasktac] def tasktacImp : Tactic :=
  fun stx =>
    do
      let res ← tst 20
      let value ← ToExpr.toExpr res
      logInfo m!"got {res}"
      let type := mkConst `Nat
      liftMetaTactic $  addToContextM `result type value
      return ()

def tt : Nat := by
  tasktac
  exact result

#eval tt

def tstDirect(n: Nat) : Nat :=
   let t1 := Task.spawn fun _ => n * 2
   let t2 := Task.spawn fun _ => n * 3
   t1.get + t2.get

#eval tstDirect 3

def egRef := IO.mkRef 3

def egRefVal : IO Nat :=
  do
    let ref ← egRef
    let val ← ref.get
    return val

#eval egRefVal

def doubleEgRef : IO Nat :=
  do
    let ref ← egRef
    let val ← ref.get
    ref.set (val * 2)
    let val2 ← ref.get
    return val2

def egRefVal2 : IO Nat :=
  do
    let ref ← egRef
    let val ← ref.get
    return val

#eval egRefVal2
#eval doubleEgRef

open Lean.Elab.Term

-- copied from source, removed error registering and so syntax
/- whnfCore + implicit consumption.
   Example: given `e` with `eType := {α : Type} → (fun β => List β) α `, it produces `(e ?m, List ?m)` where `?m` is fresh metavariable. -/
partial def consumeImplicits  (e eType : Expr) (hasArgs : Bool) :
          TermElabM (Expr × Expr) := do
  let eType ← whnfCore eType
  match eType with
  | Expr.forallE n d b c =>
    if c.binderInfo.isImplicit || (hasArgs && c.binderInfo.isStrictImplicit) then
      let mvar ← mkFreshExprMVar d
      consumeImplicits (mkApp e mvar) (b.instantiate1 mvar) hasArgs
    else if c.binderInfo.isInstImplicit then
      let mvar ← mkInstMVar d
      let r := mkApp e mvar
      consumeImplicits  r (b.instantiate1 mvar) hasArgs
    else match d.getOptParamDefault? with
      | some defVal =>
          consumeImplicits (mkApp e defVal) (b.instantiate1 defVal) hasArgs
      -- TODO: we do not handle autoParams here.
      | _ => pure (e, eType)
  | _ => pure (e, eType)

partial def lambdaImplicits  (e  : Expr) (makeExplicit : Bool) :
          MetaM Expr := do
  let eType ← inferType e
  let eType ← whnfCore eType
  match eType with
  | Expr.forallE n d b c =>
    let bind := if makeExplicit then BinderInfo.default else c.binderInfo
    if c.binderInfo.isImplicit || c.binderInfo.isStrictImplicit then
      withLocalDecl Name.anonymous bind d  $ fun x =>
        do
          let prev ← lambdaImplicits (mkApp e x)  makeExplicit
          return ←  mkLambdaFVars #[x] prev
    else if c.binderInfo.isInstImplicit then
      withLocalDecl Name.anonymous bind d  $ fun x =>
        do
          let prev ← lambdaImplicits (mkApp e x)  makeExplicit
          return ←  mkLambdaFVars #[x] prev

    else match d.getOptParamDefault? with
      | some defVal =>
          lambdaImplicits (mkApp e defVal)  makeExplicit
      -- TODO: we do not handle autoParams here.
      | _ => pure e
  | _ => pure e

#check @Prod.mk

def three3 := PProd.mk "three" 3

#check three3

def checkProdMeta : TermElabM Expr :=
  do
    let env ← getEnv
    let ee ← Term.mkConst `three3
    let u ← mkFreshLevelMVar
    let v ← mkFreshLevelMVar
    let α ← mkFreshExprMVar (mkSort u)
    let β  ← mkFreshExprMVar (mkSort v)
    let a ← mkFreshExprMVar α
    let b ← mkFreshExprMVar β
    let f := mkAppN (Lean.mkConst ``PProd.mk [u, v]) #[α, β, a, b]
    logInfo f
    if ← isDefEq f ee
      then
        logInfo m!"unified"
        return b
      else
        logInfo m!"did not unify"
        return a

syntax (name:= checkmeta) "checkMeta!" : term
@[termElab checkmeta] def chkmImpl : TermElab :=
  fun _ _ => return ← checkProdMeta

def chk : Nat := checkMeta!

#eval chk

#eval checkProdMeta

def getFnsAux : Expr → List Expr → List Expr
  | Expr.app f a _, l  => getFnsAux f (f :: a :: l)
  | e, l => e :: l

def getFnsArgs : Expr → MetaM (List Expr)
  | Expr.app f a _ =>
    do
      let ft ← inferType f
      let expl := ft.data.binderInfo.isExplicit
      if expl then
      (←  getFnsArgs f) ++ (← getFnsArgs a) ++ [f, a]
      else [f]
  | e => try
         do  [← lambdaImplicits e true]
        catch _ => []

def consImpl (e: Expr) : TermElabM Expr := do
  let eType ← inferType e
  let (e, eType) ← consumeImplicits e eType true
  return e

def lamImpl (e: Expr) (mkExplicit : Bool) : TermElabM Expr := do
  let e ← lambdaImplicits e  mkExplicit
  return e

inductive Θ {α : Type u}: α →  Type u where
  | mk :  (a : α) → Θ  a

def Θ.value {α : Type u}{a: α} : Θ a → α
  | Θ.mk a => a

theorem Θ.value.eq {α : Type u}{a: α} :
    ∀ (s : Θ a), Θ.value s = a :=
            by intro s; cases s; rfl

initialize xxx : IO.Ref (Nat) ← IO.mkRef 0

#check xxx

def getX : IO Nat :=
  do
    let ref ← xxx
    return ← ref.get

def incX : IO Nat :=
  do
    let ref ← xxx
    let value ← ref.get
    ref.set (value + 1)
    return value

def getXRef (ref: IO.Ref Nat) : IO Nat :=
  do
    return ← ref.get

def incXRef(ref: IO.Ref Nat) : IO Nat :=
  do
    let value ← ref.get
    ref.set (value + 1)
    return value

#check getX

-- def incTask : IO Unit  :=
--   do
--     let tsk := IO.asTask (dbgSleep 600 $ fun _ => incX)
--     tsk.map (fun _ => ())
--     return ()

-- #check incTask

def update (snap: IO Nat) : IO Unit :=
  do
    let ref ← xxx
    let value ← snap
    ref.set value
    return ()

syntax (name:= snapmem) "snap!" : tactic
@[tactic snapmem] def snapImpl : Tactic :=
  fun stx =>
    liftMetaTactic $ fun mvar => do
      let value ← getX
      assignExprMVar mvar (ToExpr.toExpr value)
      return []

syntax (name:= nrmlform)"whnf!" term : term
@[termElab nrmlform] def normalformImpl : TermElab :=
  fun stx expectedType? =>
  match stx with
  | `(whnf! $s) =>
      do
        let t ← Term.elabTerm s none
        let e ← whnf t
        logInfo m!"whnf : {e}"
        return e
  | _ => Lean.Elab.throwIllFormedSyntax

-- expanded form of initialize
def initFn: IO (IO.Ref Nat) := do ← IO.mkRef 0
@[init initFn] constant yyy : IO.Ref Nat

def pad (s: String)(n: Nat) : String :=
  match n with
  | 0 => s
  | m + 1 => s ++ ⟨Char.ofNat (64 + n) :: []⟩

def addSingletonsToContextM (values : List Expr) :
     MVarId → TermElabM (List MVarId) :=
     match values with
      | [] => fun m =>
      return [m]
      | h::t => fun m =>
        do
          let f := Lean.mkConst `mkSingleton
          let htype ← inferType h
          let exprOpt : Option Expr ←
            try
              let expr ←  mkAppM `Θ.mk #[h]
              some expr
            catch _ => none
          match exprOpt with
          | some expr =>
            let n := values.length
            let name := Name.mkSimple (pad "piece" n)
            let newMVarIds ← addToContextM name (← inferType expr) expr m
            addSingletonsToContextM t newMVarIds.head!
          | none =>
            addSingletonsToContextM t m

syntax (name:= exppieces) "exppieces" : tactic
@[tactic exppieces] def exppiecesImp : Tactic :=
  fun stx =>
    withMainContext
    do
      let e ← getMainTarget
      let eType ← inferType e
      let e ← instantiateMVars e
      let pieces ← (← getFnsArgs e).eraseDups
      logInfo m!"got {pieces}"
      let fedPieces ← pieces.mapM (fun exp => consImpl exp)
      logInfo m!"refined {fedPieces}"
      let repieces ← pieces.mapM (fun exp => do whnf (← instantiateMVars exp))
      logInfo m!"rebuilt {repieces}"
      let h := fedPieces.head!
      let comp ← fedPieces.mapM (fun e => isDefEq h e)
      logInfo m!"compare {comp}"
      logInfo m!"post compare: {← fedPieces.mapM (fun e => whnf e)}"
      let unchanged ← pieces.mapM (fun exp =>
          do
          let fed ← consImpl exp
          return exp == fed
      )
      logInfo m!"equal? {unchanged}"
      let lamPieces ← pieces.mapM (fun exp => lamImpl exp true)
      let lamImplPieces ← pieces.mapM (fun exp => lamImpl exp false)
      logInfo m!"lambda {lamPieces}"
      let lamTypes ←  lamPieces.mapM (fun x => inferType x)
      logInfo m!"lambdaTypes {lamTypes}"
      liftMetaTactic $ fun mvar =>
        (addSingletonsToContextM  (lamImplPieces ++ lamPieces) mvar).run'
      return ()

-- set_option pp.all true

def transitPf {α : Type}:{a b c : α} →
          a = b → b = c → a = c := by
          intros a b c eq1 eq2
          exppieces
          let p := pieceA.value
          let pg := pieceG.value
          have h1 : p  = @Eq α a  := by
              apply Θ.value.eq
          rw [eq2] at eq1
          exact eq1

variable {M: Type u}[Mul M]

-- example : (∀ a b : M, (a * b) * b = a) → (∀ a b : M, a * (a * b) = b) →
--             (m n : M) →  (m * n) = n * m := by
--             intros eq1 eq2 m n
--             exppieces
--             exact sorry

#check @HMul.hMul Nat Nat Nat (inferInstance)

def op : Type := Nat → Nat → Nat

#check Eq