/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.fix_reflect_string
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Documentation commands

We generate html documentation from mathlib. It is convenient to collect lists of tactics, commands,
notes, etc. To facilitate this, we declare these documentation entries in the library
using special commands.

* `library_note` adds a note describing a certain feature or design decision. These can be
  referenced in doc strings with the text `note [name of note]`.
* `add_tactic_doc` adds an entry documenting an interactive tactic, command, hole command, or
  attribute.

Since these commands are used in files imported by `tactic.core`, this file has no imports.

## Implementation details

`library_note note_id note_msg` creates a declaration `` `library_note.i `` for some `i`.
This declaration is a pair of strings `note_id` and `note_msg`, and it gets tagged with the
`library_note` attribute.

Similarly, `add_tactic_doc` creates a declaration `` `tactic_doc.i `` that stores the provided
information.
-/

/-- A rudimentary hash function on strings. -/
def string.hash (s : string) : ℕ :=
  string.fold 1
    (fun (h : ℕ) (c : char) => (bit1 (bit0 (bit0 (bit0 (bit0 1)))) * h + char.val c) % unsigned_sz)
    s

/-- `mk_hashed_name nspace id` hashes the string `id` to a value `i` and returns the name
`nspace._i` -/
/--
`copy_doc_string fr to` copies the docstring from the declaration named `fr`
to each declaration named in the list `to`. -/
/--
`copy_doc_string source → target_1 target_2 ... target_n` copies the doc string of the
declaration named `source` to each of `target_1`, `target_2`, ..., `target_n`.
 -/
/-! ### The `library_note` command -/

/-- A user attribute `library_note` for tagging decls of type `string × string` for use in note
output. -/
/--
`mk_reflected_definition name val` constructs a definition declaration by reflection.

Example: ``mk_reflected_definition `foo 17`` constructs the definition
declaration corresponding to `def foo : ℕ := 17`
-/
/-- If `note_name` and `note` are `pexpr`s representing strings,
`add_library_note note_name note` adds a declaration of type `string × string` and tags it with
the `library_note` attribute. -/
/--
A command to add library notes. Syntax:
```
/--
note message
-/
/-- Collects all notes in the current environment.
Returns a list of pairs `(note_id, note_content)` -/
/-! ### The `add_tactic_doc_entry` command -/

/-- The categories of tactic doc entry. -/
inductive doc_category where
| tactic : doc_category
| cmd : doc_category
| hole_cmd : doc_category
| attr : doc_category

/-- Format a `doc_category` -/
/-- The information used to generate a tactic doc entry -/
structure tactic_doc_entry where
  name : string
  category : doc_category
  decl_names : List name
  tags : List string
  description : string
  inherit_description_from : Option name

/-- Turns a `tactic_doc_entry` into a JSON representation. -/
/-- `update_description_from tde inh_id` replaces the `description` field of `tde` with the
    doc string of the declaration named `inh_id`. -/
/--
`update_description tde` replaces the `description` field of `tde` with:

* the doc string of `tde.inherit_description_from`, if this field has a value
* the doc string of the entry in `tde.decl_names`, if this field has length 1

If neither of these conditions are met, it returns `tde`. -/
/-- A user attribute `tactic_doc` for tagging decls of type `tactic_doc_entry`
for use in doc output -/
/-- Collects everything in the environment tagged with the attribute `tactic_doc`. -/
/-- `add_tactic_doc tde` adds a declaration to the environment
with `tde` as its body and tags it with the `tactic_doc`
attribute. If `tde.decl_names` has exactly one entry `` `decl`` and
if `tde.description` is the empty string, `add_tactic_doc` uses the doc
string of `decl` as the description. -/
/--
A command used to add documentation for a tactic, command, hole command, or attribute.

Usage: after defining an interactive tactic, command, or attribute,
add its documentation as follows.
```lean
/--
describe what the command does here
-/
/--
At various places in mathlib, we leave implementation notes that are referenced from many other
files. To keep track of these notes, we use the command `library_note`. This makes it easy to
retrieve a list of all notes, e.g. for documentation output.

These notes can be referenced in mathlib with the syntax `Note [note id]`.
Often, these references will be made in code comments (`--`) that won't be displayed in docs.
If such a reference is made in a doc string or module doc, it will be linked to the corresponding
note in the doc display.

Syntax:
```
/--
note message
-/
/--
Some declarations work with open expressions, i.e. an expr that has free variables.
Terms will free variables are not well-typed, and one should not use them in tactics like
`infer_type` or `unify`. You can still do syntactic analysis/manipulation on them.
The reason for working with open types is for performance: instantiating variables requires
iterating through the expression. In one performance test `pi_binders` was more than 6x
quicker than `mk_local_pis` (when applied to the type of all imported declarations 100x).
-/
-- See Note [open expressions]

/-- behavior of f -/
-- add docs to core tactics

/--
The congruence closure tactic `cc` tries to solve the goal by chaining
equalities from context and applying congruence (i.e. if `a = b`, then `f a = f b`).
It is a finishing tactic, i.e. it is meant to close
the current goal, not to make some inconclusive progress.
A mostly trivial example would be:

```lean
example (a b c : ℕ) (f : ℕ → ℕ) (h: a = b) (h' : b = c) : f a = f c := by cc
```

As an example requiring some thinking to do by hand, consider:

```lean
example (f : ℕ → ℕ) (x : ℕ)
  (H1 : f (f (f x)) = x) (H2 : f (f (f (f (f x)))) = x) :
  f x = x :=
by cc
```

The tactic works by building an equality matching graph. It's a graph where
the vertices are terms and they are linked by edges if they are known to
be equal. Once you've added all the equalities in your context, you take
the transitive closure of the graph and, for each connected component
(i.e. equivalence class) you can elect a term that will represent the
whole class and store proofs that the other elements are equal to it.
You then take the transitive closure of these equalities under the
congruence lemmas.

The `cc` implementation in Lean does a few more tricks: for example it
derives `a=b` from `nat.succ a = nat.succ b`, and `nat.succ a !=
nat.zero` for any `a`.

* The starting reference point is Nelson, Oppen, [Fast decision procedures based on congruence
closure](http://www.cs.colorado.edu/~bec/courses/csci5535-s09/reading/nelson-oppen-congruence.pdf),
Journal of the ACM (1980)

* The congruence lemmas for dependent type theory as used in Lean are described in
[Congruence closure in intensional type theory](https://leanprover.github.io/papers/congr.pdf)
(de Moura, Selsam IJCAR 2016).
-/
/--
`conv {...}` allows the user to perform targeted rewriting on a goal or hypothesis,
by focusing on particular subexpressions.

See <https://leanprover-community.github.io/extras/conv.html> for more details.

Inside `conv` blocks, mathlib currently additionally provides
* `erw`,
* `ring`, `ring2` and `ring_exp`,
* `norm_num`,
* `norm_cast`,
* `apply_congr`, and
* `conv` (within another `conv`).

`apply_congr` applies congruence lemmas to step further inside expressions,
and sometimes gives between results than the automatically generated
congruence lemmas used by `congr`.

Using `conv` inside a `conv` block allows the user to return to the previous
state of the outer `conv` block after it is finished. Thus you can continue
editing an expression without having to start a new `conv` block and re-scoping
everything. For example:
```lean
example (a b c d : ℕ) (h₁ : b = c) (h₂ : a + c = a + d) : a + b = a + d :=
by conv {
  to_lhs,
  conv {
    congr, skip,
    rw h₁,
  },
  rw h₂,
}
```
Without `conv`, the above example would need to be proved using two successive
`conv` blocks, each beginning with `to_lhs`.

Also, as a shorthand, `conv_lhs` and `conv_rhs` are provided, so that
```lean
example : 0 + 0 = 0 :=
begin
  conv_lhs { simp }
end
```
just means
```lean
example : 0 + 0 = 0 :=
begin
  conv { to_lhs, simp }
end
```
and likewise for `to_rhs`.
-/
/--
Accepts terms with the type `component tactic_state string` or `html empty` and
renders them interactively.
Requires a compatible version of the vscode extension to view the resulting widget.

### Example:

```lean
/-- A simple counter that can be incremented or decremented with some buttons. -/
/--
The `add_decl_doc` command is used to add a doc string to an existing declaration.

```lean
def foo := 5

/--
Doc string for foo.
-/
end Mathlib


import Etch.Basic
import Etch.Stream
import Etch.LVal
import Etch.Add
import Etch.Mul

class NatLt (m n : ℕ) where proof : m < n
instance NatLt.one (n : ℕ) : NatLt 0 n.succ := ⟨Nat.succ_pos _⟩
instance NatLt.trans (m n : ℕ) [h : NatLt m n] : NatLt (m+1) (n+1) :=
⟨Nat.succ_lt_succ h.proof⟩

-- example : NatLt 3 2 := inferInstance -- no
example : NatLt 1 3 := inferInstance

universe u v

class Atomic (α : Type u)

@[reducible] def Ind (_ : ℕ) (ι : Type _) := ι

class IndexedFunctor (f : ℕ → Type u → Type v) : Type (max (u+1) v) where
  imap : {i : ℕ} → {α β : Type u} → (α → β) → f i α → f i β
  imapConst : {i : ℕ} → {α β : Type u} → α → f i β → f i α := imap ∘ (Function.const _)

instance [IndexedFunctor F] : Functor (F n) where
  map := IndexedFunctor.imap
  mapConst := IndexedFunctor.imapConst

inductive StrF (ι : Type _) (n : ℕ) (α : Type _)
| fun (v : Ind n ι →ₐ α) : StrF ι n α

instance : IndexedFunctor (StrF ι) where
  imap | f, .fun v => .fun (f ∘ v)

inductive StrS (ι : Type _) (n : ℕ) (α : Type _)
| str (s : Ind n ι →ₛ α) : StrS ι n α

instance : IndexedFunctor (StrS ι) where
  imap | f, .str g => .str { g with value := f ∘ g.value }

section HMul
variable {ι : Type} [Tagged ι] [DecidableEq ι] [Max ι]
variable [IndexedFunctor F] [IndexedFunctor F'] [Atomic ρ]

instance instHMul.Merge.succ_ss [HMul α β γ] : HMul (StrS ι i α) (StrS ι i β) (StrS ι i γ) :=
⟨fun | .str s₁, .str s₂ => .str (s₁ * s₂)⟩
instance instHMul.Merge.succ_sf [HMul α β γ] : HMul (StrS ι i α) (StrF ι i β) (StrS ι i γ) :=
⟨fun | .str s₁, .fun s₂ => .str (s₁ * s₂)⟩
instance instHMul.Merge.succ_fs [HMul α β γ] : HMul (StrF ι i α) (StrS ι i β) (StrS ι i γ) :=
⟨fun | .fun s₁, .str s₂ => .str (s₁ * s₂)⟩
instance instHMul.Merge.succ_ff [HMul α β γ] : HMul (StrF ι i α) (StrF ι i β) (StrF ι i γ) :=
⟨fun | .fun s₁, .fun s₂ => .fun (s₁ * s₂)⟩

instance instHMul.Merge.scalar_r [HMul α ρ α] : HMul (F i α) ρ (F i α) :=
⟨fun s₁ k => (· * k) <$> s₁⟩
instance instHMul.Merge.lt [NatLt i j] [HMul α (F' j β) γ] : HMul (F i α) (F' j β) (F i γ) :=
⟨fun s₁ k => (· * k) <$> s₁⟩
instance instHMul.Merge.scalar_l [HMul ρ α α] : HMul ρ (F i α) (F i α) :=
⟨fun k s₂ => (k * ·) <$> s₂⟩
instance instHMul.Merge.gt [NatLt j i] [HMul (F' i α) β γ] : HMul (F' i α) (F j β) (F j γ) :=
⟨fun k s₂ => (k * ·) <$> s₂⟩

instance [Mul α] : Mul (StrS ι i α) := ⟨HMul.hMul⟩
instance [Mul α] : Mul (StrF ι i α) := ⟨HMul.hMul⟩

-- Special: bool * S
instance instHMul.Merge.scalar_r_bool : HMul (StrS ι i α) (E Bool) (StrS ι i α) :=
⟨fun | .str s₁, k => .str (Guard.guard k s₁)⟩
instance instHMul.Merge.scalar_l_bool : HMul (E Bool) (StrS ι i α) (StrS ι i α) :=
⟨fun | k, .str s₂ => .str (Guard.guard k s₂)⟩
instance instHMul.Merge.succ_sf_bool : HMul (StrS ι i α) (StrF ι i (E Bool)) (StrS ι i α) :=
⟨fun | .str s₁, .fun s₂ => .str (s₁ * s₂)⟩
instance instHMul.Merge.succ_fs_bool : HMul (StrF ι i (E Bool)) (StrS ι i β) (StrS ι i β) :=
⟨fun | .fun s₁, .str s₂ => .str (s₁ * s₂)⟩
end HMul

section HAdd
variable {α β γ ι : Type}
  [Tagged ι] [TaggedC ι] [DecidableEq ι]
  [LT ι] [LE ι] [DecidableRel (LT.lt : ι → ι → Prop)]
  [DecidableRel (LE.le : ι → ι → _)]
  {i : ℕ}
  [Guard α] [Guard β]
variable [IndexedFunctor F] [IndexedFunctor F'] [Atomic ρ]

instance instHAdd.Merge.succ_ss [HAdd α β γ] : HAdd (StrS ι i α) (StrS ι i β) (StrS ι i γ) :=
⟨fun | .str s₁, .str s₂ => .str (s₁ + s₂)⟩
instance instHAdd.Merge.succ_sf [HAdd α β γ] : HAdd (StrS ι i α) (StrF ι i β) (StrS ι i γ) :=
⟨fun | .str s₁, .fun s₂ => .str (s₁ + s₂)⟩
instance instHAdd.Merge.succ_fs [HAdd α β γ] : HAdd (StrF ι i α) (StrS ι i β) (StrS ι i γ) :=
⟨fun | .fun s₁, .str s₂ => .str (s₁ + s₂)⟩
instance instHAdd.Merge.succ_ff [HAdd α β γ] : HAdd (StrF ι i α) (StrF ι i β) (StrF ι i γ) :=
⟨fun | .fun s₁, .fun s₂ => .fun (s₁ + s₂)⟩

instance instHAdd.Merge.scalar_r [HAdd α ρ α] : HAdd (F i α) ρ (F i α) :=
⟨fun s₁ k => (· + k) <$> s₁⟩
instance instHAdd.Merge.lt [NatLt i j] [HAdd α (F' j β) γ] : HAdd (F i α) (F' j β) (F i γ) :=
⟨fun s₁ k => (· + k) <$> s₁⟩
instance instHAdd.Merge.scalar_l [HAdd ρ α α] : HAdd ρ (F i α) (F i α) :=
⟨fun k s₂ => (k + ·) <$> s₂⟩
instance instHAdd.Merge.gt [NatLt j i] [HAdd (F i α) β γ] : HAdd (F i α) (F' j β) (F' j γ) :=
⟨fun k s₂ => (k + ·) <$> s₂⟩

instance [Add α] : Add (StrS ι i α) := ⟨HAdd.hAdd⟩
instance [Add α] : Add (StrF ι i α) := ⟨HAdd.hAdd⟩
end HAdd

instance : Atomic (E α) := ⟨⟩

notation:37 a:36 " × " b:36 " ⟶ₐ " c:36  => StrF b a c
infixr:25 " ↠ₐ " => λ (p : ℕ×Type) c => StrF (Prod.snd p) (Prod.fst p) c
notation:37 a:36 " × " b:36 " ⟶ₛ " c:36  => StrS b a c
infixr:25 " ↠ₛ " => λ (p : ℕ×Type) c => StrS (Prod.snd p) (Prod.fst p) c

instance [Guard α] : Guard (n × ι ⟶ₛ α) where
  guard b := fun | .str f => .str (Guard.guard b f)

instance [Tagged α] [Zero α] : Guard (n × ι ⟶ₐ E α) where
  guard b := fun | .fun f => .fun (Guard.guard b f)

variable
{α β γ : Type _}
(n : ℕ)
{ι : Type _} [Tagged ι] [TaggedC ι] [DecidableEq ι]
[LT ι] [DecidableRel (LT.lt : ι → ι → _)] [Zero ι]
[LE ι] [DecidableRel (LE.le : ι → ι → _)]
[Max ι]

instance StrS.Mul [Mul γ] : Mul (i × ι ⟶ₛ γ) := ⟨HMul.hMul⟩
instance StrF.Mul [Mul γ] : Mul (i × ι ⟶ₐ γ) := ⟨HMul.hMul⟩

instance : Coe (ι →ₛ α) (n × ι ⟶ₛ α) := ⟨.str⟩
instance : Coe (ι →ₐ α) (n × ι ⟶ₐ α) := ⟨.fun⟩
instance [Coe α β] : Coe (ι →ₛ α) (n × ι ⟶ₛ β) := ⟨.str ∘ Functor.map Coe.coe⟩
instance [Coe α β] : Coe (ι →ₐ α) (n × ι ⟶ₐ β) := ⟨.fun ∘ Functor.map Coe.coe⟩

class of_stream (α β : Type _) := (coe : α → β)
instance base.of_stream : of_stream α α := ⟨id⟩

def Stream.of [of_stream α β] : α → β := of_stream.coe

class SumIndex (n : ℕ) (α : Type _) (β : outParam $ Type _) := (sum : α → β)
instance sum_eq (n : ℕ) : SumIndex n (n × ι ⟶ₛ α) (Contraction α) := ⟨fun | .str s => S.contract s⟩
instance sum_lt_f [IndexedFunctor F] (m n : ℕ) [NatLt n m] [SumIndex m α β] : SumIndex m (F n α) (F n β) := ⟨IndexedFunctor.imap $ SumIndex.sum m⟩
instance sum_lt_s [IndexedFunctor F] (m n : ℕ) [NatLt n m] [SumIndex m α β] : SumIndex m (F n α) (F n β) := ⟨IndexedFunctor.imap $ SumIndex.sum m⟩

notation:35 "∑" i:34 ":" v:34 => SumIndex.sum i.1 v
notation:35 "∑" i:34 "," j:34 ":" v:34 => SumIndex.sum i.1 (SumIndex.sum j.1 v)
notation:35 "∑" i:34 "," j:34 "," k:34 ":" v:34 => SumIndex.sum i.1 (SumIndex.sum j.1 (SumIndex.sum k.1 v))
notation:35 "∑" i:34 "," j:34 "," k:34 "," l:34 ":" v:34 => SumIndex.sum i.1 (SumIndex.sum j.1 (SumIndex.sum k.1 (SumIndex.sum l.1 v)))
--macro "∑" i:term ws j:term "," v:term : term => `(SumIndex.sum $i.1 (SumIndex.sum $j.1 $v))
--macro "∑" i:term "," v:term : term => `(SumIndex.sum $i.1 $v)
--macro "∑" i:term+ "," v:term : term => `(SumIndex.sum $(i[0]!).1 $v)

class ApplyScalarFn (α β γ : Type _) (δ : outParam $ Type _) := (map : (E α → E β) → γ → δ)
instance : ApplyScalarFn α β (E α) (E β) := ⟨ (. $ .) ⟩
instance [IndexedFunctor F] [ApplyScalarFn α β α' β'] : ApplyScalarFn α β (F n α') (F n β') := ⟨ λ f x => ApplyScalarFn.map f <$> x ⟩
infixr:10 " <$$> "  => ApplyScalarFn.map

section tests

variable (a : 0 × ℕ ⟶ₛ E R)
variable (A : ℕ →ₛ ℕ →ₛ E R)
variable (B : ℕ →ₐ ℕ →ₛ E R)
private abbrev i := (0, ℕ)
private abbrev j := (1, ℕ)
private abbrev k := (2, ℕ)
#check SumIndex.sum 0 a
#check ∑ i: (A : i ↠ₛ j ↠ₛ E R)
#check ∑ i, j: (A : i ↠ₛ j ↠ₛ E R)
#check (A : i ↠ₛ j ↠ₛ E R) * (B : j ↠ₐ k ↠ₛ E R)
--#check ∑ i, j: (A : i ↠ j ↠ E R)
--#check ∑ j, k: (A : i ↠ j ↠ E R) * (B : j ↠ k ↠ E R)

end tests

/-
#check Nat.add
inductive St (α : Type) : ℕ → Type
| base : St α 0
| vec (δ) {n} (of : St α n) : St α (n+δ)

-- no
def St.eval {n α} (ctxt : Fin n → Type) : St α n → List Type
| base => []
| vec d x => ctxt ⟨d, Nat.add⟩ :: x.eval _

class Broadcast (α β : Type _) (γ : outParam $ Type _) :=
  broadcast : List ℕ → α → β → γ × γ

instance [Rectangle f] [Broadcast α β γ] : Broadcast (f i α) (f j β) (f

def broadcast (ordering : List ℕ) (a : f i α) (b : g i β)
/- todo
  fix ∑ notation (use ∃ from Heap)
  make broadcast based on a given ordering argument
-/
-/


/-
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.Util.CollectFVars
import Lean.Meta.Match.MatchPatternAttr
import Lean.Meta.Match.Match
import Lean.Meta.SortLocalDecls
import Lean.Meta.GeneralizeVars
import Lean.Elab.SyntheticMVars
import Lean.Elab.Arg
import Lean.Parser.Term
import Lean.Elab.PatternVar

namespace Lean.Elab.Term
open Meta
open Lean.Parser.Term

private def expandSimpleMatch (stx discr lhsVar rhs : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  let newStx ← `(let $lhsVar := $discr; $rhs)
  withMacroExpansion stx newStx <| elabTerm newStx expectedType?

private def mkUserNameFor (e : Expr) : TermElabM Name := do
  match e with
  /- Remark: we use `mkFreshUserName` to make sure we don't add a variable to the local context that can be resolved to `e`. -/
  | Expr.fvar fvarId _ => mkFreshUserName ((← getLocalDecl fvarId).userName)
  | _                  => mkFreshBinderName

/-- Return true iff `n` is an auxiliary variable created by `expandNonAtomicDiscrs?` -/
def isAuxDiscrName (n : Name) : Bool :=
  n.hasMacroScopes && n.eraseMacroScopes == `_discr

/--
   We treat `@x` as atomic to avoid unnecessary extra local declarations from being
   inserted into the local context. Recall that `expandMatchAltsIntoMatch` uses `@` modifier.
   Thus this is kind of discriminant is quite common.

   Remark: if the discriminat is `Systax.missing`, we abort the elaboration of the `match`-expression.
   This can happen due to error recovery. Example
   ```
   example : (p ∨ p) → p := fun h => match
   ```
   If we don't abort, the elaborator loops because we will keep trying to expand
   ```
   match
   ```
   into
   ```
   let d := <Syntax.missing>; match
   ```
   Recall that `Syntax.setArg stx i arg` is a no-op when `i` is out-of-bounds. -/
def isAtomicDiscr? (discr : Syntax) : TermElabM (Option Expr) := do
  match discr with
  | `($x:ident)  => isLocalIdent? x
  | `(@$x:ident) => isLocalIdent? x
  | _ => if discr.isMissing then throwAbortTerm else return none

-- See expandNonAtomicDiscrs?
private def elabAtomicDiscr (discr : Syntax) : TermElabM Expr := do
  let term := discr[1]
  match (← isAtomicDiscr? term) with
  | some e@(Expr.fvar fvarId _) =>
    let localDecl ← getLocalDecl fvarId
    if !isAuxDiscrName localDecl.userName then
      addTermInfo discr e
      return e -- it is not an auxiliary local created by `expandNonAtomicDiscrs?`
    else
      instantiateMVars localDecl.value
  | _ => throwErrorAt discr "unexpected discriminant"

structure ElabMatchTypeAndDiscrsResult where
  discrs    : Array Expr
  matchType : Expr
  /- `true` when performing dependent elimination. We use this to decide whether we optimize the "match unit" case.
     See `isMatchUnit?`. -/
  isDep     : Bool
  alts      : Array MatchAltView

private partial def elabMatchTypeAndDiscrs (discrStxs : Array Syntax) (matchOptType : Syntax) (matchAltViews : Array MatchAltView) (expectedType : Expr)
      : TermElabM ElabMatchTypeAndDiscrsResult := do
    let numDiscrs := discrStxs.size
    if matchOptType.isNone then
      elabDiscrs 0 #[]
    else
      let matchTypeStx := matchOptType[0][1]
      let matchType ← elabType matchTypeStx
      let (discrs, isDep) ← elabDiscrsWitMatchType matchType expectedType
      return { discrs := discrs, matchType := matchType, isDep := isDep, alts := matchAltViews }
  where
    /- Easy case: elaborate discriminant when the match-type has been explicitly provided by the user.  -/
    elabDiscrsWitMatchType (matchType : Expr) (expectedType : Expr) : TermElabM (Array Expr × Bool) := do
      let mut discrs := #[]
      let mut i := 0
      let mut matchType := matchType
      let mut isDep := false
      for discrStx in discrStxs do
        i := i + 1
        matchType ← whnf matchType
        match matchType with
        | Expr.forallE _ d b _ =>
          let discr ← fullApproxDefEq <| elabTermEnsuringType discrStx[1] d
          trace[Elab.match] "discr #{i} {discr} : {d}"
          if b.hasLooseBVars then
            isDep := true
          matchType := b.instantiate1 discr
          discrs := discrs.push discr
        | _ =>
          throwError "invalid type provided to match-expression, function type with arity #{discrStxs.size} expected"
      return (discrs, isDep)

    markIsDep (r : ElabMatchTypeAndDiscrsResult) :=
      { r with isDep := true }

    /- Elaborate discriminants inferring the match-type -/
    elabDiscrs (i : Nat) (discrs : Array Expr) : TermElabM ElabMatchTypeAndDiscrsResult := do
      if h : i < discrStxs.size then
        let discrStx := discrStxs.get ⟨i, h⟩
        let discr     ← elabAtomicDiscr discrStx
        let discr     ← instantiateMVars discr
        let discrType ← inferType discr
        let discrType ← instantiateMVars discrType
        let discrs    := discrs.push discr
        let userName ← mkUserNameFor discr
        if discrStx[0].isNone then
          let mut result ← elabDiscrs (i + 1) discrs
          let matchTypeBody ← kabstract result.matchType discr
          if matchTypeBody.hasLooseBVars then
            result := markIsDep result
          return { result with matchType := Lean.mkForall userName BinderInfo.default discrType matchTypeBody }
        else
          let discrs := discrs.push (← mkEqRefl discr)
          let result ← elabDiscrs (i + 1) discrs
          let result := markIsDep result
          let identStx := discrStx[0][0]
          withLocalDeclD userName discrType fun x => do
            let eqType ← mkEq discr x
            withLocalDeclD identStx.getId eqType fun h => do
              let matchTypeBody ← kabstract result.matchType discr
              let matchTypeBody := matchTypeBody.instantiate1 x
              let matchType ← mkForallFVars #[x, h] matchTypeBody
              return { result with
                matchType := matchType
                alts      := result.alts.map fun altView =>
                  if i+1 > altView.patterns.size then
                    -- Unexpected number of patterns. The input is invalid, but we want to process whatever to provide info to users.
                    altView
                  else
                    { altView with patterns := altView.patterns.insertAt (i+1) identStx }
              }
      else
        return { discrs, alts := matchAltViews, isDep := false, matchType := expectedType }

def expandMacrosInPatterns (matchAlts : Array MatchAltView) : MacroM (Array MatchAltView) := do
  matchAlts.mapM fun matchAlt => do
    let patterns ← matchAlt.patterns.mapM expandMacros
    pure { matchAlt with patterns := patterns }

private def getMatchGeneralizing? : Syntax → Option Bool
  | `(match (generalizing := true)  $discrs,* $[: $ty?]? with $alts:matchAlt*) => some true
  | `(match (generalizing := false) $discrs,* $[: $ty?]? with $alts:matchAlt*) => some false
  | _ => none

/- Given `stx` a match-expression, return its alternatives. -/
private def getMatchAlts : Syntax → Array MatchAltView
  | `(match $[$gen]? $discrs,* $[: $ty?]? with $alts:matchAlt*) =>
    alts.filterMap fun alt => match alt with
      | `(matchAltExpr| | $patterns,* => $rhs) => some {
          ref      := alt,
          patterns := patterns,
          rhs      := rhs
        }
      | _ => none
  | _ => #[]

builtin_initialize Parser.registerBuiltinNodeKind `MVarWithIdKind

/--
  The elaboration function for `Syntax` created using `mkMVarSyntax`.
  It just converts the metavariable id wrapped by the Syntax into an `Expr`. -/
@[builtinTermElab MVarWithIdKind] def elabMVarWithIdKind : TermElab := fun stx expectedType? =>
  return mkInaccessible <| mkMVar (getMVarSyntaxMVarId stx)

@[builtinTermElab inaccessible] def elabInaccessible : TermElab := fun stx expectedType? => do
  let e ← elabTerm stx[1] expectedType?
  return mkInaccessible e

open Lean.Elab.Term.Quotation in
@[builtinQuotPrecheck Lean.Parser.Term.match] def precheckMatch : Precheck
  | `(match $[$discrs:term],* with $[| $[$patss],* => $rhss]*) => do
    discrs.forM precheck
    for (pats, rhs) in patss.zip rhss do
      let vars ←
        try
          getPatternsVars pats
        catch
          | _ => return  -- can happen in case of pattern antiquotations
      Quotation.withNewLocals (getPatternVarNames vars) <| precheck rhs
  | _ => throwUnsupportedSyntax

/- We convert the collected `PatternVar`s intro `PatternVarDecl` -/
inductive PatternVarDecl where
  /- For `anonymousVar`, we create both a metavariable and a free variable. The free variable is used as an assignment for the metavariable
     when it is not assigned during pattern elaboration. -/
  | anonymousVar (mvarId : MVarId) (fvarId : FVarId)
  | localVar     (fvarId : FVarId)

private partial def withPatternVars {α} (pVars : Array PatternVar) (k : Array PatternVarDecl → TermElabM α) : TermElabM α :=
  let rec loop (i : Nat) (decls : Array PatternVarDecl) := do
    if h : i < pVars.size then
      match pVars.get ⟨i, h⟩ with
      | PatternVar.anonymousVar mvarId =>
        let type ← mkFreshTypeMVar
        let userName ← mkFreshBinderName
        withLocalDecl userName BinderInfo.default type fun x =>
          loop (i+1) (decls.push (PatternVarDecl.anonymousVar mvarId x.fvarId!))
      | PatternVar.localVar userName   =>
        let type ← mkFreshTypeMVar
        withLocalDecl userName BinderInfo.default type fun x =>
          loop (i+1) (decls.push (PatternVarDecl.localVar x.fvarId!))
    else
      /- We must create the metavariables for `PatternVar.anonymousVar` AFTER we create the new local decls using `withLocalDecl`.
         Reason: their scope must include the new local decls since some of them are assigned by typing constraints. -/
      decls.forM fun decl => match decl with
        | PatternVarDecl.anonymousVar mvarId fvarId => do
          let type ← inferType (mkFVar fvarId)
          discard <| mkFreshExprMVarWithId mvarId type
        | _ => pure ()
      k decls
  loop 0 #[]

/-
Remark: when performing dependent pattern matching, we often had to write code such as

```lean
def Vec.map' (f : α → β) (xs : Vec α n) : Vec β n :=
  match n, xs with
  | _, nil       => nil
  | _, cons a as => cons (f a) (map' f as)
```
We had to include `n` and the `_`s because the type of `xs` depends on `n`.
Moreover, `nil` and `cons a as` have different types.
This was quite tedious. So, we have implemented an automatic "discriminant refinement procedure".
The procedure is based on the observation that we get a type error whenenver we forget to include `_`s
and the indices a discriminant depends on. So, we catch the exception, check whether the type of the discriminant
is an indexed family, and add their indices as new discriminants.

The current implementation, adds indices as they are found, and does not
try to "sort" the new discriminants.

If the refinement process fails, we report the original error message.
-/

/- Auxiliary structure for storing an type mismatch exception when processing the
   pattern #`idx` of some alternative. -/
structure PatternElabException where
  ex          : Exception
  patternIdx  : Nat -- Discriminant that sh
  pathToIndex : List Nat -- Path to the problematic inductive type index that produced the type mismatch

/--
  This method is part of the "discriminant refinement" procedure. It in invoked when the
  type of the `pattern` does not match the expected type. The expected type is based on the
  motive computed using the `match` discriminants.
  It tries to compute a path to an index of the discriminant type.
  For example, suppose the user has written
  ```
  inductive Mem (a : α) : List α → Prop where
    | head {as} : Mem a (a::as)
    | tail {as} : Mem a as → Mem a (a'::as)

  infix:50 " ∈ " => Mem

  example (a b : Nat) (h : a ∈ [b]) : b = a :=
  match h with
  | Mem.head => rfl
  ```
  The motive for the match is `a ∈ [b] → b = a`, and get a type mismatch between the type
  of `Mem.head` and `a ∈ [b]`. This procedure return the path `[2, 1]` to the index `b`.
  We use it to produce the following refinement
  ```
  example (a b : Nat) (h : a ∈ [b]) : b = a :=
  match b, h with
  | _, Mem.head => rfl
  ```
  which produces the new motive `(x : Nat) →  a ∈ [x] → x = a`
  After this refinement step, the `match` is elaborated successfully.

  This method relies on the fact that the dependent pattern matcher compiler solves equations
  between indices of indexed inductive families.
  The following kinds of equations are supported by this compiler:
  - `x = t`
  - `t = x`
  - `ctor ... = ctor ...`

  where `x` is a free variable, `t` is an arbitrary term, and `ctor` is constructor.
  Our procedure ensures that "information" is not lost, and will *not* succeed in an
  example such as
  ```
  example (a b : Nat) (f : Nat → Nat) (h : f a ∈ [f b]) : f b = f a :=
    match h with
    | Mem.head => rfl
  ```
  and will not add `f b` as a new discriminant. We may add an option in the future to
  enable this more liberal form of refinement.
-/
private partial def findDiscrRefinementPath (pattern : Expr) (expected : Expr) : OptionT MetaM (List Nat) := do
  goType (← instantiateMVars (← inferType pattern)) expected
where
  checkCompatibleApps (t d : Expr) : OptionT MetaM Unit := do
    guard d.isApp
    guard <| t.getAppNumArgs == d.getAppNumArgs
    let tFn := t.getAppFn
    let dFn := d.getAppFn
    guard <| tFn.isConst && dFn.isConst
    guard (← isDefEq tFn dFn)

  -- Visitor for inductive types
  goType (t d : Expr) : OptionT MetaM (List Nat) := do
    trace[Meta.debug] "type {t} =?= {d}"
    let t ← whnf t
    let d ← whnf d
    checkCompatibleApps t d
    matchConstInduct t.getAppFn (fun _ => failure) fun info _ => do
      let tArgs := t.getAppArgs
      let dArgs := d.getAppArgs
      for i in [:info.numParams] do
        let tArg := tArgs[i]
        let dArg := dArgs[i]
        unless (← isDefEq tArg dArg) do
          return i :: (← goType tArg dArg)
      for i in [info.numParams : tArgs.size] do
        let tArg := tArgs[i]
        let dArg := dArgs[i]
        unless (← isDefEq tArg dArg) do
          return i :: (← goIndex tArg dArg)
      failure

  -- Visitor for indexed families
  goIndex (t d : Expr) : OptionT MetaM (List Nat) := do
    let t ← whnfD t
    let d ← whnfD d
    if t.isFVar || d.isFVar then
      return [] -- Found refinement path
    else
      trace[Meta.debug] "index {t} =?= {d}"
      checkCompatibleApps t d
      matchConstCtor t.getAppFn (fun _ => failure) fun info _ => do
        let tArgs := t.getAppArgs
        let dArgs := d.getAppArgs
        for i in [:info.numParams] do
          let tArg := tArgs[i]
          let dArg := dArgs[i]
          unless (← isDefEq tArg dArg) do
            failure
        for i in [info.numParams : tArgs.size] do
          let tArg := tArgs[i]
          let dArg := dArgs[i]
          unless (← isDefEq tArg dArg) do
            return i :: (← goIndex tArg dArg)
        failure

private partial def eraseIndices (type : Expr) : MetaM Expr := do
  let type' ← whnfD type
  matchConstInduct type'.getAppFn (fun _ => return type) fun info _ => do
    let args := type'.getAppArgs
    let params ← args[:info.numParams].toArray.mapM eraseIndices
    let result := mkAppN type'.getAppFn params
    let resultType ← inferType result
    let (newIndices, _, _) ←  forallMetaTelescopeReducing resultType (some (args.size - info.numParams))
    return mkAppN result newIndices

private def elabPatterns (patternStxs : Array Syntax) (matchType : Expr) : ExceptT PatternElabException TermElabM (Array Expr × Expr) :=
  withReader (fun ctx => { ctx with implicitLambda := false }) do
    let mut patterns  := #[]
    let mut matchType := matchType
    for idx in [:patternStxs.size] do
      let patternStx := patternStxs[idx]
      matchType ← whnf matchType
      match matchType with
      | Expr.forallE _ d b _ =>
        let pattern ← do
          let s ← saveState
          try
            liftM <| withSynthesize <| withoutErrToSorry <| elabTermEnsuringType patternStx d
          catch ex : Exception =>
            restoreState s
            match (← liftM <| commitIfNoErrors? <| withoutErrToSorry do elabTermAndSynthesize patternStx (← eraseIndices d)) with
            | some pattern =>
              match (← findDiscrRefinementPath pattern d |>.run) with
              | some path =>
                trace[Meta.debug] "refinement path: {path}"
                restoreState s
                -- Wrap the type mismatch exception for the "discriminant refinement" feature.
                throwThe PatternElabException { ex := ex, patternIdx := idx, pathToIndex := path }
              | none => restoreState s; throw ex
            | none => throw ex
        matchType := b.instantiate1 pattern
        patterns  := patterns.push pattern
      | _ => throwError "unexpected match type"
    return (patterns, matchType)

def finalizePatternDecls (patternVarDecls : Array PatternVarDecl) : TermElabM (Array LocalDecl) := do
  let mut decls := #[]
  for pdecl in patternVarDecls do
    match pdecl with
    | PatternVarDecl.localVar fvarId =>
      let decl ← getLocalDecl fvarId
      let decl ← instantiateLocalDeclMVars decl
      decls := decls.push decl
    | PatternVarDecl.anonymousVar mvarId fvarId =>
       let e ← instantiateMVars (mkMVar mvarId);
       trace[Elab.match] "finalizePatternDecls: mvarId: {mvarId.name} := {e}, fvar: {mkFVar fvarId}"
       match e with
       | Expr.mvar newMVarId _ =>
         /- Metavariable was not assigned, or assigned to another metavariable. So,
            we assign to the auxiliary free variable we created at `withPatternVars` to `newMVarId`. -/
         assignExprMVar newMVarId (mkFVar fvarId)
         trace[Elab.match] "finalizePatternDecls: {mkMVar newMVarId} := {mkFVar fvarId}"
         let decl ← getLocalDecl fvarId
         let decl ← instantiateLocalDeclMVars decl
         decls := decls.push decl
       | _ => pure ()
  /- We perform a topological sort (dependecies) on `decls` because the pattern elaboration process may produce a sequence where a declaration d₁ may occur after d₂ when d₂ depends on d₁. -/
  sortLocalDecls decls

open Meta.Match (Pattern Pattern.var Pattern.inaccessible Pattern.ctor Pattern.as Pattern.val Pattern.arrayLit AltLHS MatcherResult)

namespace ToDepElimPattern

structure State where
  found      : FVarIdSet := {}
  localDecls : Array LocalDecl
  newLocals  : FVarIdSet := {}

abbrev M := StateRefT State TermElabM

private def alreadyVisited (fvarId : FVarId) : M Bool := do
  let s ← get
  return s.found.contains fvarId

private def markAsVisited (fvarId : FVarId) : M Unit :=
  modify fun s => { s with found := s.found.insert fvarId }

private def throwInvalidPattern {α} (e : Expr) : M α :=
  throwError "invalid pattern {indentExpr e}"

/- Create a new LocalDecl `x` for the metavariable `mvar`, and return `Pattern.var x` -/
private def mkLocalDeclFor (mvar : Expr) : M Pattern := do
  let mvarId := mvar.mvarId!
  let s ← get
  match (← getExprMVarAssignment? mvarId) with
  | some val => return Pattern.inaccessible val
  | none =>
    let fvarId ← mkFreshFVarId
    let type   ← inferType mvar
    /- HACK: `fvarId` is not in the scope of `mvarId`
       If this generates problems in the future, we should update the metavariable declarations. -/
    assignExprMVar mvarId (mkFVar fvarId)
    let userName ← mkFreshBinderName
    let newDecl := LocalDecl.cdecl default fvarId userName type BinderInfo.default;
    modify fun s =>
      { s with
        newLocals  := s.newLocals.insert fvarId,
        localDecls :=
        match s.localDecls.findIdx? fun decl => mvar.occurs decl.type with
        | none   => s.localDecls.push newDecl -- None of the existing declarations depend on `mvar`
        | some i => s.localDecls.insertAt i newDecl }
    return Pattern.var fvarId

partial def main (e : Expr) : M Pattern := do
  let isLocalDecl (fvarId : FVarId) : M Bool := do
    return (← get).localDecls.any fun d => d.fvarId == fvarId
  let mkPatternVar (fvarId : FVarId) (e : Expr) : M Pattern := do
    if (← alreadyVisited fvarId) then
      return Pattern.inaccessible e
    else
      markAsVisited fvarId
      return Pattern.var e.fvarId!
  let mkInaccessible (e : Expr) : M Pattern := do
    match e with
    | Expr.fvar fvarId _ =>
      if (← isLocalDecl fvarId) then
        mkPatternVar fvarId e
      else
        return Pattern.inaccessible e
    | _ =>
      return Pattern.inaccessible e
  match inaccessible? e with
  | some t => mkInaccessible t
  | none =>
    match e.arrayLit? with
    | some (α, lits) =>
      return Pattern.arrayLit α (← lits.mapM main)
    | none =>
      -- TODO: namedPattern will have 4 arguments
      if e.isAppOfArity ``_root_.namedPattern 4 then
        let p ← main <| e.getArg! 2
        match e.getArg! 1, e.getArg! 3 with
        | Expr.fvar x _, Expr.fvar h _ => return Pattern.as x p h
        | _,             _             => throwError "unexpected occurrence of auxiliary declaration 'namedPattern'"
      else if isMatchValue e then
        return Pattern.val e
      else if e.isFVar then
        let fvarId := e.fvarId!
        unless (← isLocalDecl fvarId) do
          throwInvalidPattern e
        mkPatternVar fvarId e
      else if e.isMVar then
        mkLocalDeclFor e
      else
        let newE ← whnf e
        if newE != e then
          main newE
        else
         matchConstCtor e.getAppFn
           (fun _ => do
              if (← isProof e) then
                /- We mark nested proofs as inaccessible. This is fine due to proof irrelevance.
                   We need this feature to be able to elaborate definitions such as:
                   ```
                    def f : Fin 2 → Nat
                      | 0 => 5
                      | 1 => 45
                   ```
                -/
                return Pattern.inaccessible e
              else
                throwInvalidPattern e)
           (fun v us => do
              let args := e.getAppArgs
              unless args.size == v.numParams + v.numFields do
                throwInvalidPattern e
              let params := args.extract 0 v.numParams
              let fields := args.extract v.numParams args.size
              let fields ← fields.mapM main
              return Pattern.ctor v.name us params.toList fields.toList)

end ToDepElimPattern

def withDepElimPatterns {α} (localDecls : Array LocalDecl) (ps : Array Expr) (k : Array LocalDecl → Array Pattern → TermElabM α) : TermElabM α := do
  let (patterns, s) ← (ps.mapM ToDepElimPattern.main).run { localDecls := localDecls }
  let localDecls ← s.localDecls.mapM fun d => instantiateLocalDeclMVars d
  /- toDepElimPatterns may have added new localDecls. Thus, we must update the local context before we execute `k` -/
  let lctx ← getLCtx
  let lctx := localDecls.foldl (fun (lctx : LocalContext) d => lctx.erase d.fvarId) lctx
  let lctx := localDecls.foldl (fun (lctx : LocalContext) d => lctx.addDecl d) lctx
  withTheReader Meta.Context (fun ctx => { ctx with lctx := lctx }) do
    k localDecls patterns

private def withElaboratedLHS {α} (ref : Syntax) (patternVarDecls : Array PatternVarDecl) (patternStxs : Array Syntax) (matchType : Expr)
    (k : AltLHS → Expr → TermElabM α) : ExceptT PatternElabException TermElabM α := do
  let (patterns, matchType) ← withSynthesize <| elabPatterns patternStxs matchType
  id (α := TermElabM α) do
    let localDecls ← finalizePatternDecls patternVarDecls
    let patterns ← patterns.mapM (instantiateMVars ·)
    withDepElimPatterns localDecls patterns fun localDecls patterns =>
      k { ref := ref, fvarDecls := localDecls.toList, patterns := patterns.toList } matchType

private def elabMatchAltView (alt : MatchAltView) (matchType : Expr) : ExceptT PatternElabException TermElabM (AltLHS × Expr) := withRef alt.ref do
  let (patternVars, alt) ← collectPatternVars alt
  trace[Elab.match] "patternVars: {patternVars}"
  withPatternVars patternVars fun patternVarDecls => do
    withElaboratedLHS alt.ref patternVarDecls alt.patterns matchType fun altLHS matchType => do
      let rhs ← elabTermEnsuringType alt.rhs matchType
      let xs := altLHS.fvarDecls.toArray.map LocalDecl.toExpr
      let rhs ← if xs.isEmpty then pure <| mkSimpleThunk rhs else mkLambdaFVars xs rhs
      trace[Elab.match] "rhs: {rhs}"
      return (altLHS, rhs)

/--
  Collect problematic index for the "discriminant refinement feature". This method is invoked
  when we detect a type mismatch at a pattern #`idx` of some alternative. -/
private partial def getIndexToInclude? (discr : Expr) (pathToIndex : List Nat) : TermElabM (Option Expr) := do
  go (← inferType discr) pathToIndex |>.run
where
  go (e : Expr) (path : List Nat) : OptionT MetaM Expr := do
    match path with
    | [] => return e
    | i::path =>
      let e ← whnfD e
      guard <| e.isApp && i < e.getAppNumArgs
      go (e.getArg! i) path

/--
  "Generalize" variables that depend on the discriminants.

  Remarks and limitations:
  - If `matchType` is a proposition, then we generalize even when the user did not provide `(generalizing := true)`.
    Motivation: users should have control about the actual `match`-expressions in their programs.
  - We currently do not generalize let-decls.
  - We abort generalization if the new `matchType` is type incorrect.
  - Only discriminants that are free variables are considered during specialization.
  - We "generalize" by adding new discriminants and pattern variables. We do not "clear" the generalized variables,
    but they become inaccessible since they are shadowed by the patterns variables. We assume this is ok since
    this is the exact behavior users would get if they had written it by hand. Recall there is no `clear` in term mode.
-/
private def generalize (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) (generalizing? : Option Bool) : TermElabM (Array Expr × Expr × Array MatchAltView × Bool) := do
  let gen ←
    match generalizing? with
    | some g => pure g
    | _ => isProp matchType
  if !gen then
    return (discrs, matchType, altViews, false)
  else
    let ysFVarIds ← getFVarsToGeneralize discrs
    /- let-decls are currently being ignored by the generalizer. -/
    let ysFVarIds ← ysFVarIds.filterM fun fvarId => return !(← getLocalDecl fvarId).isLet
    if ysFVarIds.isEmpty then
      return (discrs, matchType, altViews, false)
    else
      let ys := ysFVarIds.map mkFVar
      -- trace[Meta.debug] "ys: {ys}, discrs: {discrs}"
      let matchType' ← forallBoundedTelescope matchType discrs.size fun ds type => do
        let type ← mkForallFVars ys type
        let (discrs', ds') := Array.unzip <| Array.zip discrs ds |>.filter fun (di, d) => di.isFVar
        let type := type.replaceFVars discrs' ds'
        mkForallFVars ds type
      -- trace[Meta.debug] "matchType': {matchType'}"
      if (← isTypeCorrect matchType') then
        let discrs := discrs ++ ys
        let altViews ← altViews.mapM fun altView => do
          let patternVars ← getPatternsVars altView.patterns
          -- We traverse backwards because we want to keep the most recent names.
          -- For example, if `ys` contains `#[h, h]`, we want to make sure `mkFreshUsername is applied to the first `h`,
          -- since it is already shadowed by the second.
          let ysUserNames ← ys.foldrM (init := #[]) fun ys ysUserNames => do
            let yDecl ← getLocalDecl ys.fvarId!
            let mut yUserName := yDecl.userName
            if ysUserNames.contains yUserName then
              yUserName ← mkFreshUserName yUserName
            -- Explicitly provided pattern variables shadow `y`
            else if patternVars.any fun | PatternVar.localVar x => x == yUserName | _ => false then
              yUserName ← mkFreshUserName yUserName
            return ysUserNames.push yUserName
          let ysIds ← ysUserNames.reverse.mapM fun n => return mkIdentFrom (← getRef) n
          return { altView with patterns := altView.patterns ++ ysIds }
        return (discrs, matchType', altViews, true)
      else
        return (discrs, matchType, altViews, true)

private partial def elabMatchAltViews (generalizing? : Option Bool) (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) : TermElabM (Array Expr × Expr × Array (AltLHS × Expr) × Bool) := do
  loop discrs matchType altViews none
where
  /-
    "Discriminant refinement" main loop.
    `first?` contains the first error message we found before updated the `discrs`. -/
  loop (discrs : Array Expr) (matchType : Expr) (altViews : Array MatchAltView) (first? : Option (SavedState × Exception))
      : TermElabM (Array Expr × Expr × Array (AltLHS × Expr) × Bool) := do
    let s ← saveState
    let (discrs', matchType', altViews', refined) ← generalize discrs matchType altViews generalizing?
    match (← altViews'.mapM (fun altView => elabMatchAltView altView matchType') |>.run) with
    | Except.ok alts => return (discrs', matchType', alts, first?.isSome || refined)
    | Except.error { patternIdx := patternIdx, pathToIndex := pathToIndex, ex := ex } =>
      trace[Meta.debug] "pathToIndex: {toString pathToIndex}"
      let some index ← getIndexToInclude? discrs[patternIdx] pathToIndex
        | throwEx (← updateFirst first? ex)
      trace[Meta.debug] "index: {index}"
      if (← discrs.anyM fun discr => isDefEq discr index) then
        throwEx (← updateFirst first? ex)
      let first ← updateFirst first? ex
      s.restore
      let indices ← collectDeps #[index] discrs
      let matchType ←
        try
          updateMatchType indices matchType
        catch ex =>
          throwEx first
      let altViews  ← addWildcardPatterns indices.size altViews
      let discrs    := indices ++ discrs
      loop discrs matchType altViews first

  throwEx {α} (p : SavedState × Exception) : TermElabM α := do
    p.1.restore; throw p.2

  updateFirst (first? : Option (SavedState × Exception)) (ex : Exception) : TermElabM (SavedState × Exception) := do
    match first? with
    | none       => return (← saveState, ex)
    | some first => return first

  containsFVar (es : Array Expr) (fvarId : FVarId) : Bool :=
    es.any fun e => e.isFVar && e.fvarId! == fvarId

  /- Update `indices` by including any free variable `x` s.t.
     - Type of some `discr` depends on `x`.
     - Type of `x` depends on some free variable in `indices`.

     If we don't include these extra variables in indices, then
     `updateMatchType` will generate a type incorrect term.
     For example, suppose `discr` contains `h : @HEq α a α b`, and
     `indices` is `#[α, b]`, and `matchType` is `@HEq α a α b → B`.
     `updateMatchType indices matchType` produces the type
     `(α' : Type) → (b : α') → @HEq α' a α' b → B` which is type incorrect
     because we have `a : α`.
     The method `collectDeps` will include `a` into `indices`.

     This method does not handle dependencies among non-free variables.
     We rely on the type checking method `check` at `updateMatchType`.

     Remark: `indices : Array Expr` does not need to be an array anymore.
     We should cleanup this code, and use `index : Expr` instead.
   -/
  collectDeps (indices : Array Expr) (discrs : Array Expr) : TermElabM (Array Expr) := do
    let mut s : CollectFVars.State := {}
    for discr in discrs do
      s := collectFVars s (← instantiateMVars (← inferType discr))
    let (indicesFVar, indicesNonFVar) := indices.split Expr.isFVar
    let indicesFVar := indicesFVar.map Expr.fvarId!
    let mut toAdd := #[]
    for fvarId in s.fvarSet.toList do
      unless containsFVar discrs fvarId || containsFVar indices fvarId do
        let localDecl ← getLocalDecl fvarId
        let mctx ← getMCtx
        for indexFVarId in indicesFVar do
          if mctx.localDeclDependsOn localDecl indexFVarId then
            toAdd := toAdd.push fvarId
    let indicesFVar ← sortFVarIds (indicesFVar ++ toAdd)
    return indicesFVar.map mkFVar ++ indicesNonFVar

  updateMatchType (indices : Array Expr) (matchType : Expr) : TermElabM Expr := do
    let matchType ← indices.foldrM (init := matchType) fun index matchType => do
      let indexType ← inferType index
      let matchTypeBody ← kabstract matchType index
      let userName ← mkUserNameFor index
      return Lean.mkForall userName BinderInfo.default indexType matchTypeBody
    check matchType
    return matchType

  addWildcardPatterns (num : Nat) (altViews : Array MatchAltView) : TermElabM (Array MatchAltView) := do
    let hole := mkHole (← getRef)
    let wildcards := mkArray num hole
    return altViews.map fun altView => { altView with patterns := wildcards ++ altView.patterns }

def mkMatcher (input : Meta.Match.MkMatcherInput) : TermElabM MatcherResult :=
  Meta.Match.mkMatcher input

register_builtin_option match.ignoreUnusedAlts : Bool := {
  defValue := false
  descr := "if true, do not generate error if an alternative is not used"
}

def reportMatcherResultErrors (altLHSS : List AltLHS) (result : MatcherResult) : TermElabM Unit := do
  unless result.counterExamples.isEmpty do
    withHeadRefOnly <| logError m!"missing cases:\n{Meta.Match.counterExamplesToMessageData result.counterExamples}"
  unless match.ignoreUnusedAlts.get (← getOptions) || result.unusedAltIdxs.isEmpty do
    let mut i := 0
    for alt in altLHSS do
      if result.unusedAltIdxs.contains i then
        withRef alt.ref do
          logError "redundant alternative"
      i := i + 1

/--
  If `altLHSS + rhss` is encoding `| PUnit.unit => rhs[0]`, return `rhs[0]`
  Otherwise, return none.
-/
private def isMatchUnit? (altLHSS : List Match.AltLHS) (rhss : Array Expr) : MetaM (Option Expr) := do
  assert! altLHSS.length == rhss.size
  match altLHSS with
  | [ { fvarDecls := [], patterns := [ Pattern.ctor `PUnit.unit .. ], .. } ] =>
    /- Recall that for alternatives of the form `| PUnit.unit => rhs`, `rhss[0]` is of the form `fun _ : Unit => b`. -/
    match rhss[0] with
    | Expr.lam _ _ b _ => return if b.hasLooseBVars then none else b
    | _ => return none
  | _ => return none
private def elabMatchAux (generalizing? : Option Bool) (discrStxs : Array Syntax) (altViews : Array MatchAltView) (matchOptType : Syntax) (expectedType : Expr)
    : TermElabM Expr := do
  let mut generalizing? := generalizing?
  if !matchOptType.isNone then
    if generalizing? == some true then
      throwError "the '(generalizing := true)' parameter is not supported when the 'match' type is explicitly provided"
    generalizing? := some false
  let (discrs, matchType, altLHSS, isDep, rhss) ← commitIfDidNotPostpone do
    let ⟨discrs, matchType, isDep, altViews⟩ ← elabMatchTypeAndDiscrs discrStxs matchOptType altViews expectedType
    let matchAlts ← liftMacroM <| expandMacrosInPatterns altViews
    trace[Elab.match] "matchType: {matchType}"
    let (discrs, matchType, alts, refined) ← elabMatchAltViews generalizing? discrs matchType matchAlts
    let isDep := isDep || refined
    /-
     We should not use `synthesizeSyntheticMVarsNoPostponing` here. Otherwise, we will not be
     able to elaborate examples such as:
     ```
     def f (x : Nat) : Option Nat := none

     def g (xs : List (Nat × Nat)) : IO Unit :=
     xs.forM fun x =>
       match f x.fst with
       | _ => pure ()
     ```
     If `synthesizeSyntheticMVarsNoPostponing`, the example above fails at `x.fst` because
     the type of `x` is only available after we proces the last argument of `List.forM`.

     We apply pending default types to make sure we can process examples such as
     ```
     let (a, b) := (0, 0)
     ```
    -/
    synthesizeSyntheticMVarsUsingDefault
    let rhss := alts.map Prod.snd
    let matchType ← instantiateMVars matchType
    let altLHSS ← alts.toList.mapM fun alt => do
      let altLHS ← Match.instantiateAltLHSMVars alt.1
      /- Remark: we try to postpone before throwing an error.
         The combinator `commitIfDidNotPostpone` ensures we backtrack any updates that have been performed.
         The quick-check `waitExpectedTypeAndDiscrs` minimizes the number of scenarios where we have to postpone here.
         Here is an example that passes the `waitExpectedTypeAndDiscrs` test, but postpones here.
         ```
          def bad (ps : Array (Nat × Nat)) : Array (Nat × Nat) :=
            (ps.filter fun (p : Prod _ _) =>
              match p with
              | (x, y) => x == 0)
            ++
            ps
         ```
         When we try to elaborate `fun (p : Prod _ _) => ...` for the first time, we haven't propagated the type of `ps` yet
         because `Array.filter` has type `{α : Type u_1} → (α → Bool) → (as : Array α) → optParam Nat 0 → optParam Nat (Array.size as) → Array α`
         However, the partial type annotation `(p : Prod _ _)` makes sure we succeed at the quick-check `waitExpectedTypeAndDiscrs`.
      -/
      withRef altLHS.ref do
        for d in altLHS.fvarDecls do
            if d.hasExprMVar then
            withExistingLocalDecls altLHS.fvarDecls do
              tryPostpone
              throwMVarError m!"invalid match-expression, type of pattern variable '{d.toExpr}' contains metavariables{indentExpr d.type}"
        for p in altLHS.patterns do
          if p.hasExprMVar then
            withExistingLocalDecls altLHS.fvarDecls do
              tryPostpone
              throwMVarError m!"invalid match-expression, pattern contains metavariables{indentExpr (← p.toExpr)}"
        pure altLHS
    return (discrs, matchType, altLHSS, isDep, rhss)
  if let some r ← if isDep then pure none else isMatchUnit? altLHSS rhss then
    return r
  else
    let numDiscrs := discrs.size
    let matcherName ← mkAuxName `match
    let matcherResult ← mkMatcher { matcherName, matchType, numDiscrs, lhss := altLHSS }
    matcherResult.addMatcher
    let motive ← forallBoundedTelescope matchType numDiscrs fun xs matchType => mkLambdaFVars xs matchType
    reportMatcherResultErrors altLHSS matcherResult
    let r := mkApp matcherResult.matcher motive
    let r := mkAppN r discrs
    let r := mkAppN r rhss
    trace[Elab.match] "result: {r}"
    return r

private def getDiscrs (matchStx : Syntax) : Array Syntax :=
  matchStx[2].getSepArgs

private def getMatchOptType (matchStx : Syntax) : Syntax :=
  matchStx[3]

private def expandNonAtomicDiscrs? (matchStx : Syntax) : TermElabM (Option Syntax) :=
  let matchOptType := getMatchOptType matchStx;
  if matchOptType.isNone then do
    let discrs := getDiscrs matchStx;
    let allLocal ← discrs.allM fun discr => Option.isSome <$> isAtomicDiscr? discr[1]
    if allLocal then
      return none
    else
      -- We use `foundFVars` to make sure the discriminants are distinct variables.
      -- See: code for computing "matchType" at `elabMatchTypeAndDiscrs`
      let rec loop (discrs : List Syntax) (discrsNew : Array Syntax) (foundFVars : FVarIdSet) := do
        match discrs with
        | [] =>
          let discrs := Syntax.mkSep discrsNew (mkAtomFrom matchStx ", ");
          pure (matchStx.setArg 2 discrs)
        | discr :: discrs =>
          -- Recall that
          -- matchDiscr := leading_parser optional (ident >> ":") >> termParser
          let term := discr[1]
          let addAux : TermElabM Syntax := withFreshMacroScope do
            let d ← `(_discr);
            unless isAuxDiscrName d.getId do -- Use assertion?
              throwError "unexpected internal auxiliary discriminant name"
            let discrNew := discr.setArg 1 d;
            let r ← loop discrs (discrsNew.push discrNew) foundFVars
            `(let _discr := $term; $r)
          match (← isAtomicDiscr? term) with
          | some x  => if x.isFVar then loop discrs (discrsNew.push discr) (foundFVars.insert x.fvarId!) else addAux
          | none    => addAux
      return some (← loop discrs.toList #[] {})
  else
    -- We do not pull non atomic discriminants when match type is provided explicitly by the user
    return none

private def waitExpectedType (expectedType? : Option Expr) : TermElabM Expr := do
  tryPostponeIfNoneOrMVar expectedType?
  match expectedType? with
    | some expectedType => pure expectedType
    | none              => mkFreshTypeMVar

private def tryPostponeIfDiscrTypeIsMVar (matchStx : Syntax) : TermElabM Unit := do
  -- We don't wait for the discriminants types when match type is provided by user
  if getMatchOptType matchStx |>.isNone then
    let discrs := getDiscrs matchStx
    for discr in discrs do
      let term := discr[1]
      match (← isAtomicDiscr? term) with
      | none   => throwErrorAt discr "unexpected discriminant" -- see `expandNonAtomicDiscrs?
      | some d =>
        let dType ← inferType d
        trace[Elab.match] "discr {d} : {dType}"
        tryPostponeIfMVar dType

/-
We (try to) elaborate a `match` only when the expected type is available.
If the `matchType` has not been provided by the user, we also try to postpone elaboration if the type
of a discriminant is not available. That is, it is of the form `(?m ...)`.
We use `expandNonAtomicDiscrs?` to make sure all discriminants are local variables.
This is a standard trick we use in the elaborator, and it is also used to elaborate structure instances.
Suppose, we are trying to elaborate
```
match g x with
  | ... => ...
```
`expandNonAtomicDiscrs?` converts it intro
```
let _discr := g x
match _discr with
  | ... => ...
```
Thus, at `tryPostponeIfDiscrTypeIsMVar` we only need to check whether the type of `_discr` is not of the form `(?m ...)`.
Note that, the auxiliary variable `_discr` is expanded at `elabAtomicDiscr`.

This elaboration technique is needed to elaborate terms such as:
```lean
xs.filter fun (a, b) => a > b
```
which are syntax sugar for
```lean
List.filter (fun p => match p with | (a, b) => a > b) xs
```
When we visit `match p with | (a, b) => a > b`, we don't know the type of `p` yet.
-/
private def waitExpectedTypeAndDiscrs (matchStx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  tryPostponeIfNoneOrMVar expectedType?
  tryPostponeIfDiscrTypeIsMVar matchStx
  match expectedType? with
  | some expectedType => return expectedType
  | none              => mkFreshTypeMVar

/-
```
leading_parser:leadPrec "match " >> sepBy1 matchDiscr ", " >> optType >> " with " >> matchAlts
```
Remark the `optIdent` must be `none` at `matchDiscr`. They are expanded by `expandMatchDiscr?`.
-/
private def elabMatchCore (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
  let expectedType ← waitExpectedTypeAndDiscrs stx expectedType?
  let discrStxs := (getDiscrs stx).map fun d => d
  let gen?         := getMatchGeneralizing? stx
  let altViews     := getMatchAlts stx
  let matchOptType := getMatchOptType stx
  elabMatchAux gen? discrStxs altViews matchOptType expectedType

private def isPatternVar (stx : Syntax) : TermElabM Bool := do
  match (← resolveId? stx "pattern") with
  | none   => return isAtomicIdent stx
  | some f => match f with
    | Expr.const fName _ _ =>
      match (← getEnv).find? fName with
      | some (ConstantInfo.ctorInfo _) => return false
      | some _                         => return !hasMatchPatternAttribute (← getEnv) fName
      | _                              => return isAtomicIdent stx
    | _ => return isAtomicIdent stx
where
  isAtomicIdent (stx : Syntax) : Bool :=
    stx.isIdent && stx.getId.eraseMacroScopes.isAtomic

-- leading_parser "match " >> sepBy1 termParser ", " >> optType >> " with " >> matchAlts
/--
Pattern matching. `match e, ... with | p, ... => f | ...` matches each given
term `e` against each pattern `p` of a match alternative. When all patterns
of an alternative match, the `match` term evaluates to the value of the
corresponding right-hand side `f` with the pattern variables bound to the
respective matched values.
When not constructing a proof, `match` does not automatically substitute variables
matched on in dependent variables' types. Use `match (generalizing := true) ...` to
enforce this. -/
@[builtinTermElab «match»] def elabMatch : TermElab := fun stx expectedType? => do
  match stx with
  | `(match $discr:term with | $y:ident => $rhs:term) =>
     if (← isPatternVar y) then expandSimpleMatch stx discr y rhs expectedType? else elabMatchDefault stx expectedType?
  | _ => elabMatchDefault stx expectedType?
where
  elabMatchDefault (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
    match (← expandNonAtomicDiscrs? stx) with
    | some stxNew => withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
    | none =>
      let discrs       := getDiscrs stx;
      let matchOptType := getMatchOptType stx;
      if !matchOptType.isNone && discrs.any fun d => !d[0].isNone then
        throwErrorAt matchOptType "match expected type should not be provided when discriminants with equality proofs are used"
      elabMatchCore stx expectedType?

builtin_initialize
  registerTraceClass `Elab.match

-- leading_parser:leadPrec "nomatch " >> termParser
/-- Empty match/ex falso. `nomatch e` is of arbitrary type `α : Sort u` if
Lean can show that an empty set of patterns is exhaustive given `e`'s type,
e.g. because it has no constructors. -/
@[builtinTermElab «nomatch»] def elabNoMatch : TermElab := fun stx expectedType? => do
  match stx with
  | `(nomatch $discrExpr) =>
    match (← isLocalIdent? discrExpr) with
    | some _ =>
      let expectedType ← waitExpectedType expectedType?
      let discr := mkNode ``Lean.Parser.Term.matchDiscr #[mkNullNode, discrExpr]
      elabMatchAux none #[discr] #[] mkNullNode expectedType
    | _ =>
      let stxNew ← `(let _discr := $discrExpr; nomatch _discr)
      withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
  | _ => throwUnsupportedSyntax

end Lean.Elab.Term


import .simulation

import ..scheduling
import ..spec

universe variables u u₀ u₁ u₂
open predicate nat
local infix ` ≃ `:75 := v_eq
local prefix `♯ `:0 := cast (by simp)

namespace temporal

namespace one_to_one
section
open fairness
parameters {α : Type u} {β : Type u₀} {γ : Type u₁ }
parameters {evt : Type u₂}
parameters {m₀ : mch' evt (γ×α)} {m₁ : mch' evt (γ×β)}
local notation `p` := m₀.init
local notation `q` := m₁.init
local notation `aevt` := m₀.evt
local notation `cevt` := m₁.evt
local notation `cs₀` := m₀.cs
local notation `fs₀` := m₀.fs
local notation `cs₁` := m₁.cs
local notation `fs₁` := m₁.fs
local notation `A` := m₀.A
local notation `C` := m₁.A
parameters (J : pred' (γ×α×β))
parameters (Jₐ : pred' (γ×α))

def C' (e : evt) : act (evt×γ×β) :=
λ ⟨sch,s⟩ ⟨_,s'⟩, sch = e ∧ C e s s'

abbreviation ae (i : evt) : event (γ×α) := ⟨cs₀ i,fs₀ i,A i⟩
abbreviation ce (i : evt) : event (evt×γ×β) := ⟨cs₁ i!pair.snd,fs₁ i!pair.snd,C' i⟩

section specs

parameters m₀ m₁

def SPEC₀.saf' (v : tvar α) (o : tvar γ) (sch : tvar evt) : cpred :=
spec_saf_spec m₀ ⦃o,v⦄ sch

def SPEC₀ (v : tvar α) (o : tvar γ) : cpred :=
spec m₀ ⦃o,v⦄

def SPEC₁ (v : tvar β) (o : tvar γ) : cpred :=
spec m₁ ⦃o,v⦄

def SPEC₂ (v : tvar β) (o : tvar γ) (s : tvar evt) : cpred :=
spec_sch m₁ ⦃o,v⦄ s

end specs

parameters [inhabited α] [inhabited evt]

parameter init_Jₐ : ∀ w o, (o,w) ⊨ p → (o,w) ⊨ Jₐ
parameter evt_Jₐ  : ∀ w o w' o' e,
                          (o,w) ⊨ Jₐ →
                          (o,w) ⊨ cs₀ e →
                          (o,w) ⊨ fs₀ e →
                          A e (o,w) (o',w') →
                          (o',w') ⊨ Jₐ

parameter SIM₀ : ∀ v o, (o,v) ⊨ q → ∃ w, (o,w) ⊨ p ∧ (o,w,v) ⊨ J
parameter SIM
: ∀ w v o v' o' e,
  (o,w,v) ⊨ J →
  (o,w) ⊨ Jₐ →
  (o,v) ⊨ cs₁ e →
  (o,v) ⊨ fs₁ e →
  C e (o,v) (o',v') →
  ∃ w', (o,w) ⊨ cs₀ e ∧
        (o,w) ⊨ fs₀ e ∧
        A e (o,w) (o',w') ∧
        (o',w',v') ⊨ J

parameters (v : tvar β) (o : tvar γ) (sch : tvar evt)

variable (Γ : cpred)

parameters β γ

variable Hpo : ∀ w e sch,
  one_to_one_po' (SPEC₁ v o ⋀ SPEC₀.saf' w o sch ⋀ ◻(J ! ⦃o,w,v⦄))
     (ce e) (ae e) ⦃sch,o,v⦄ ⦃o,w⦄

parameters {β γ}

section SPEC₂
variables H : Γ ⊢ SPEC₂ v o sch

open prod temporal.prod

def Next_a : act $ (γ × evt) × α :=
λ σ σ',
∃ e, σ.1.2 = e ∧
     map_left fst σ ⊨ cs₀ e ∧
     map_left fst σ ⊨ fs₀ e ∧
     (A e on map_left fst) σ σ'

def Next_c : act $ (γ × evt) × β :=
λ σ σ',
∃ e, σ.1.2 = e ∧
     map_left fst σ ⊨ cs₁ e ∧
     map_left fst σ ⊨ fs₁ e ∧
     (C e on map_left fst) σ σ'

section J
def J' : pred' ((γ × evt) × α × β) :=
J ! ⟨ prod.map_left fst ⟩

def JJₐ : pred' ((γ × evt) × α) :=
Jₐ ! ⟨ prod.map_left fst ⟩

def p' : pred' ((γ × evt) × α) :=
p ! ⟨ prod.map_left fst ⟩

def q' : pred' ((γ × evt) × β) :=
q ! ⟨ prod.map_left fst ⟩

end J

variable w : tvar α
open simulation function
noncomputable def Wtn := Wtn p' Next_a J' v ⦃o,sch⦄

variable valid_witness
: Γ ⊢ Wtn w

lemma abstract_sch (e : evt)
: Γ ⊢ sch ≃ e ⋀ cs₀ e ! ⦃o,w⦄ ⋀ fs₀ e ! ⦃o,w⦄ ⋀ ⟦ o,w | A e ⟧ ≡
      sch ≃ e ⋀ ⟦ ⦃o,sch⦄,w | Next_a ⟧ :=
begin
  lifted_pred,
  split ; intro h ; split
  ; casesm* _ ∧ _ ; try { assumption }
  ; simp [Next_a,on_fun] at * ; cc,
end

section Simulation_POs
include SIM₀
lemma SIM₀' (v : β) (o : γ × evt)
  (h : (o, v) ⊨ q')
: (∃ (w : α), (o, w) ⊨ p' ∧ (o, w, v) ⊨ J') :=
begin
  simp [q',prod.map_left] at h,
  specialize SIM₀ v o.1 h,
  revert SIM₀, intros_mono,
  simp [J',p',map], intros,
  constructor_matching* [Exists _, _ ∧ _] ;
  tauto,
end

omit SIM₀
include SIM
lemma SIM' (w : α) (v : β) (o : γ × evt) (v' : β) (o' : γ × evt)
  (h₀ : (o, w, v) ⊨ J')
  (h₃ : (o, w) ⊨ JJₐ)
  (h₄ : Next_c (o, v) (o', v'))
: (∃ w', Next_a (o,w) (o',w') ∧ (o', w', v') ⊨ J') :=
begin
  simp [J',map] at h₀,
  simp [Next_c,on_fun] at h₄,
  casesm* _ ∧ _,
  simp [JJₐ] at h₃,
  specialize SIM w v o.1 v' o'.1 o.2 h₀ _ _ _ _
  ; try { assumption },
  cases SIM with w' SIM,
  existsi [w'],
  simp [Next_a, J',on_fun,map,h₀],
  tauto,
end

include H
omit SIM
lemma H'
: Γ ⊢ simulation.SPEC₁ q' Next_c v ⦃o,sch⦄ :=
begin [temporal]
  simp [SPEC₂,simulation.SPEC₁,q'] at H ⊢,
  split, tauto,
  casesm* _ ⋀ _,
  select h : ◻p_exists _,
  henceforth! at h ⊢,
  cases h with e h,
  explicit' [Next_c,sched] with h
  { casesm* _ ∧ _, subst e, tauto, }
end

omit H
section
include init_Jₐ
lemma init_Jₐ' (w : α) (o : γ × evt)
  (h : (o, w) ⊨ p')
: (o, w) ⊨ JJₐ :=
by { cases o, simp [JJₐ,p'] at *, solve_by_elim }
end

section
include evt_Jₐ
lemma evt_Jₐ' (w : α) (o : γ × evt) (w' : α) (o' : γ × evt)
  (h₀ : (o, w) ⊨ JJₐ)
  (h₁ : Next_a (o, w) (o', w'))
: (o', w') ⊨ JJₐ :=
by { cases o, simp [JJₐ,p',Next_a,on_fun] at *, tauto }
end

include SIM₀ SIM init_Jₐ evt_Jₐ H
lemma witness_imp_SPEC₀_saf
  (h : Γ ⊢ Wtn w)
: Γ ⊢ SPEC₀.saf' w o sch :=
begin [temporal]
  have hJ := J_inv_in_w p' q'
                        temporal.one_to_one.Next_a
                        temporal.one_to_one.Next_c
                        temporal.one_to_one.J'
                        temporal.one_to_one.JJₐ
                        temporal.one_to_one.init_Jₐ'
                        temporal.one_to_one.evt_Jₐ'
                        temporal.one_to_one.SIM₀'
                        temporal.one_to_one.SIM'
                        v ⦃o,sch⦄ Γ
                        (temporal.one_to_one.H' _ H) _ h,
  have hJ' := abs_J_inv_in_w p' q'--
                        temporal.one_to_one.Next_a
                        temporal.one_to_one.Next_c
                        temporal.one_to_one.J'
                        temporal.one_to_one.JJₐ
                        temporal.one_to_one.init_Jₐ'
                        temporal.one_to_one.evt_Jₐ'
                        temporal.one_to_one.SIM₀'
                        temporal.one_to_one.SIM'
                        v ⦃o,sch⦄ Γ
                        (temporal.one_to_one.H' _ H)
                        _ h ,
  simp [SPEC₀.saf',SPEC₂,Wtn,simulation.Wtn] at h ⊢ H,
  casesm* _ ⋀ _,
  split,
  { clear SIM hJ,
    select h : w ≃ _,
    select h' : q ! _,
    rw [← pair.snd_mk sch w,h],
    explicit
    { simp [Wx₀] at ⊢ h', unfold_coes,
      simp [Wx₀_f,p',J',map],
      cases SIM₀ (σ ⊨ v) (σ ⊨ o) h',
      apply_epsilon_spec, } },
  { clear SIM₀,
    select h : ◻(_ ≃ _),
    select h' : ◻(p_exists _),
    henceforth! at h h' ⊢ hJ hJ',
    explicit' [Wf,Wf_f,J',JJₐ]
      with  h h' hJ hJ'
    { simp [Next_a,on_fun] at h h',
      casesm* [_ ∧ _,Exists _],
      subst w', subst h'_w,
      apply_epsilon_spec,
      have : (∃ (w' : α), (o, w) ⊨ cs₀ sch ∧
      (o, w) ⊨ fs₀ sch ∧ A sch (o, w) (o', w') ∧ (o', w', v') ⊨ J), solve_by_elim,
      cases this, tauto, } },
end

omit H
parameters p q cs₁ fs₁
include Hpo p

lemma SPEC₂_imp_SPEC₁
: (SPEC₂ v o sch) ⟹ (SPEC₁ v o) :=
begin [temporal]
  simp only [SPEC₁,SPEC₂,temporal.one_to_one.SPEC₁,temporal.one_to_one.SPEC₂],
  monotonicity, apply ctx_p_and_p_imp_p_and',
  { monotonicity, simp, intros x h₀ h₁ _ _,
    existsi x, tauto, },
  { intros h i h₀ h₁,
    replace h := h _ h₀ h₁,
    revert h, monotonicity, simp, }
end

lemma H_C_imp_A (e : evt)
: SPEC₂ v o sch ⋀ Wtn w ⋀ ◻(J ! ⦃o,w,v⦄) ⟹
  ◻(cs₁ e ! ⦃o,v⦄ ⋀ fs₁ e ! ⦃o,v⦄ ⋀ sch ≃ ↑e ⋀ ⟦ o,v | C e ⟧ ⟶
    cs₀ e ! ⦃o,w⦄ ⋀ fs₀ e ! ⦃o,w⦄ ⋀ ⟦ o,w | A e ⟧) :=
begin [temporal]
  intro H',
  have H : temporal.one_to_one.SPEC₁ v o ⋀
           temporal.one_to_one.Wtn w ⋀
           ◻(J ! ⦃o,w,v⦄),
  { revert H',  persistent,
    intro, casesm* _ ⋀ _, split* ; try { assumption },
    apply temporal.one_to_one.SPEC₂_imp_SPEC₁ _ Γ _,
    solve_by_elim, casesm* _ ⋀ _, solve_by_elim, },
  clear Hpo,
  let J' := temporal.one_to_one.J',
  have init_Jₐ' := temporal.one_to_one.init_Jₐ', clear init_Jₐ,
  have evt_Jₐ' := temporal.one_to_one.evt_Jₐ',  clear evt_Jₐ,
  have SIM₀' := temporal.one_to_one.SIM₀', clear SIM₀,
  have SIM' := temporal.one_to_one.SIM',  clear SIM,
  have := C_imp_A_in_w p' _ (Next_a A) (Next_c C) J' _
    init_Jₐ' evt_Jₐ'
    SIM₀' SIM' v ⦃o,sch⦄ Γ _ w _,
  { henceforth! at this ⊢,
    simp, intros h₀ h₁ h₂ h₃, clear_except this h₀ h₁ h₂ h₃,
    suffices : sch ≃ ↑e ⋀ cs₀ e ! ⦃o,w⦄ ⋀ fs₀ e ! ⦃o,w⦄ ⋀ ⟦ o,w | A e ⟧,
    { tauto },
    rw abstract_sch, split, assumption,
    apply this _,
    simp [Next_c],
    suffices : ⟦ ⦃o,sch⦄,v | λ (σ σ' : (γ × evt) × β), (σ.fst).snd = e ∧ (C e on map_left fst) σ σ' ⟧,
    { explicit' with h₀ h₁ h₂ h₃ { cc, }, },
    rw [← action_and_action,← init_eq_action,action_on'], split,
    explicit
    { simp at ⊢ h₀, assumption },
    simp [h₃], },
  clear_except H',
  simp [simulation.SPEC₁,SPEC₂,temporal.one_to_one.SPEC₂] at H' ⊢,
  cases_matching* _ ⋀ _, split,
  { simp [q'], assumption, },
  { select H' : ◻(p_exists _), clear_except H',
    henceforth at H' ⊢, cases H' with i H',
    simp [Next_c],
    suffices : ⟦ ⦃o,sch⦄,v | λ (σ σ' : (γ × evt) × β), (σ.fst).snd = i ∧ (C i on map_left fst) σ σ' ⟧,
    { explicit'* { cases this, subst i, tauto, } },
    explicit'* { cc }, },
  { cases_matching* _ ⋀ _, assumption, },
end

lemma Hpo' (e : evt)
: one_to_one_po (SPEC₂ v o sch ⋀ Wtn w ⋀ ◻(J ! ⦃o,w,v⦄))
/- -/ (cs₁ e ! ⦃o,v⦄)
      (fs₁ e ! ⦃o,v⦄)
      (sch ≃ ↑e ⋀ ⟦ o,v | C e ⟧)
/- -/ (cs₀ e ! ⦃o,w⦄)
      (fs₀ e ! ⦃o,w⦄)
      ⟦ o,w | A e ⟧ :=
begin
  have
  : temporal.one_to_one.SPEC₂ v o sch ⋀ temporal.one_to_one.Wtn w ⋀ ◻(J ! ⦃o,w,v⦄) ⟹
    temporal.one_to_one.SPEC₁ v o ⋀ temporal.one_to_one.SPEC₀.saf' w o sch ⋀ ◻(J ! ⦃o,w,v⦄),
  begin [temporal]
    simp, intros h₀ h₁ h₂,
    split*,
    { apply temporal.one_to_one.SPEC₂_imp_SPEC₁ Hpo _ h₀, },
    { apply temporal.one_to_one.witness_imp_SPEC₀_saf ; solve_by_elim, },
    { solve_by_elim }
  end,
  constructor,
  iterate 3
  { cases (Hpo w e sch),
    simp at *,
    transitivity,
    { apply this },
    { assumption }, },
  begin [temporal]
    intros Hs,
    have H_imp := temporal.one_to_one.H_C_imp_A Hpo w e _ Hs,
    henceforth! at ⊢ H_imp,
    simp at H_imp ⊢,
    exact H_imp,
  end
end

end Simulation_POs

include H SIM₀ SIM Hpo init_Jₐ evt_Jₐ

lemma sched_ref (i : evt) (w : tvar α)
 (Hw : Γ ⊢ Wtn w)
 (h : Γ ⊢ sched (cs₁ i ! ⦃o,v⦄) (fs₁ i ! ⦃o,v⦄) (sch ≃ ↑i ⋀ ⟦ o,v | C i ⟧))
: Γ ⊢ sched (cs₀ i ! ⦃o,w⦄) (fs₀ i ! ⦃o,w⦄)
            ⟦ o,w | A i ⟧ :=
begin [temporal]
  have H' := one_to_one.H' C v o sch _ H,
  have hJ : ◻(J' J ! ⦃⦃o,sch⦄,w,v⦄),
  { replace SIM₀ := SIM₀' _ SIM₀,
    replace SIM := SIM' A C J _ SIM,
    apply simulation.J_inv_in_w p' q' (Next_a A) _ (J' J) _ _ _ SIM₀ SIM _ ⦃o,sch⦄ _ H' w Hw,
    apply temporal.one_to_one.init_Jₐ',
    apply temporal.one_to_one.evt_Jₐ' },
  simp [J'] at hJ,
  have Hpo' := temporal.one_to_one.Hpo' Hpo w i,
  apply replacement Hpo' Γ _,
  tauto, solve_by_elim,
end

lemma one_to_one
: Γ ⊢ ∃∃ w, SPEC₀ w o :=
begin [temporal]
  select_witness w : temporal.one_to_one.Wtn w
    with Hw using J,
  have this := H, revert this,
  dsimp [SPEC₀,SPEC₁],
  have H' := temporal.one_to_one.H' , -- o sch,
  apply ctx_p_and_p_imp_p_and' _ _,
  apply ctx_p_and_p_imp_p_and' _ _,
  { clear_except SIM₀ Hw H,
    replace SIM₀ := temporal.one_to_one.SIM₀',
    have := init_in_w p' q' (Next_a A) (J' J) SIM₀ v ⦃o,sch⦄ Γ _ Hw,
    intro Hq,
    simp [p',q'] at this,
    solve_by_elim, },
  { clear_except SIM SIM₀ Hw H init_Jₐ evt_Jₐ,
    have H' := H' C v o sch _ H,
    replace SIM₀ := SIM₀' _ SIM₀,
    replace SIM := SIM' A C J _ SIM,
    have := temporal.simulation.C_imp_A_in_w p' q'
      (Next_a A) (Next_c C) (J' J) _ _ _ SIM₀ SIM v ⦃o,sch⦄ _ H' w Hw,
    { monotonicity!,
      simp [exists_action],
      intros e h₀ h₁ h₂ h₃, replace this := this _,
      explicit'* [Next_a]
      { intros, casesm* _ ∧ _,
        constructor_matching* [Exists _,_ ∧ _] ; solve_by_elim, },
      simp [Next_c],
      suffices : ⟦ ⦃o,sch⦄,v | λ (σ σ' : (γ × evt) × β), map_left prod.fst σ ⊨ fs₁ e ∧ ((λ s s', s = e) on (prod.snd ∘ prod.fst)) σ σ' ∧ (C e on map_left prod.fst) σ σ' ⟧,
      explicit' with h₀ h₁ this
      { intros, subst e, tauto, },
      henceforth at this,
      explicit'* [Next_c]
      { tauto } },
    { apply temporal.one_to_one.init_Jₐ' },
    { apply temporal.one_to_one.evt_Jₐ' }, },
  { intros h i,
    replace h := h i,
    apply temporal.one_to_one.sched_ref; solve_by_elim },
end
end SPEC₂

section refinement_SPEC₂
include Hpo SIM₀ SIM init_Jₐ evt_Jₐ
parameters m₁ m₀

lemma refinement_SPEC₂
: Γ ⊢ (∃∃ sch, SPEC₂ v o sch) ⟶ (∃∃ a, SPEC₀ a o) :=
begin [temporal]
  simp, intros sch Hc,
  apply one_to_one J Jₐ init_Jₐ evt_Jₐ SIM₀ SIM _ _ _ _ _  Hc,
  apply Hpo,
end
end refinement_SPEC₂

lemma refinement_SPEC₁ [schedulable evt]
: SPEC₁ v o ⟹ (∃∃ sch, SPEC₂ v o sch) :=
assume Γ,
sch_intro _ _ _ _ _ _

include SIM₀ SIM init_Jₐ evt_Jₐ
lemma refinement [schedulable evt]
  (h : ∀ c a e sch, one_to_one_po' (SPEC₁ c o ⋀ SPEC₀.saf' a o sch ⋀ ◻(J ! ⦃o,a,c⦄))
         ⟨cs₁ e!pair.snd,fs₁ e!pair.snd,C' e⟩
         ⟨cs₀ e,fs₀ e,A e⟩ ⦃sch,o,c⦄ ⦃o,a⦄)
: (∃∃ c, SPEC₁ c o) ⟹ (∃∃ a, SPEC₀ a o) :=
begin [temporal]
  transitivity (∃∃ c sch, SPEC₂ q C cs₁ fs₁ c o sch),
  { apply p_exists_p_imp_p_exists ,
    intro v,
    apply refinement_SPEC₁, },
  { simp, intros c sch Hspec,
    specialize h c, simp [one_to_one_po'] at h,
    apply refinement_SPEC₂ A C cs₀ fs₀ cs₁ fs₁ J Jₐ init_Jₐ evt_Jₐ SIM₀ SIM c o _ _ _,
    simp [one_to_one_po'],
    exact h,
    existsi sch, assumption },
end

end
end one_to_one

end temporal