/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Check
import Lean.Meta.Match.MatcherInfo
import Lean.Meta.Match.CaseArraySizes

namespace Lean.Meta.Match

/--
  Auxiliary annotation used to mark terms marked with the "inaccessible" annotation `.(t)` and
  `_` in patterns. -/
def mkInaccessible (e : Expr) : Expr :=
  mkAnnotation `_inaccessible e

def inaccessible? (e : Expr) : Option Expr :=
  annotation? `_inaccessible e

inductive Pattern : Type where
  | inaccessible (e : Expr) : Pattern
  | var          (fvarId : FVarId) : Pattern
  | ctor         (ctorName : Name) (us : List Level) (params : List Expr) (fields : List Pattern) : Pattern
  | val          (e : Expr) : Pattern
  | arrayLit     (type : Expr) (xs : List Pattern) : Pattern
  | as           (varId : FVarId) (p : Pattern) : Pattern
  deriving Inhabited

namespace Pattern

partial def toMessageData : Pattern → MessageData
  | inaccessible e         => m!".({e})"
  | var varId              => mkFVar varId
  | ctor ctorName _ _ []   => ctorName
  | ctor ctorName _ _ pats => m!"({ctorName}{pats.foldl (fun (msg : MessageData) pat => msg ++ " " ++ toMessageData pat) Format.nil})"
  | val e                  => e
  | arrayLit _ pats        => m!"#[{MessageData.joinSep (pats.map toMessageData) ", "}]"
  | as varId p             => m!"{mkFVar varId}@{toMessageData p}"

partial def toExpr (p : Pattern) (annotate := false) : MetaM Expr :=
  visit p
where
  visit (p : Pattern) := do
    match p with
    | inaccessible e                 =>
      if annotate then
        pure (mkInaccessible e)
      else
        pure e
    | var fvarId                     => pure $ mkFVar fvarId
    | val e                          => pure e
    | as fvarId p                    =>
      if annotate then
        mkAppM `namedPattern #[mkFVar fvarId, (← visit p)]
      else
        visit p
    | arrayLit type xs               =>
      let xs ← xs.mapM visit
      mkArrayLit type xs
    | ctor ctorName us params fields =>
      let fields ← fields.mapM visit
      pure $ mkAppN (mkConst ctorName us) (params ++ fields).toArray

/- Apply the free variable substitution `s` to the given pattern -/
partial def applyFVarSubst (s : FVarSubst) : Pattern → Pattern
  | inaccessible e  => inaccessible $ s.apply e
  | ctor n us ps fs => ctor n us (ps.map s.apply) $ fs.map (applyFVarSubst s)
  | val e           => val $ s.apply e
  | arrayLit t xs   => arrayLit (s.apply t) $ xs.map (applyFVarSubst s)
  | var fvarId      => match s.find? fvarId with
    | some e => inaccessible e
    | none   => var fvarId
  | as fvarId p     => match s.find? fvarId with
    | none   => as fvarId $ applyFVarSubst s p
    | some _ => applyFVarSubst s p

def replaceFVarId (fvarId : FVarId) (v : Expr) (p : Pattern) : Pattern :=
  let s : FVarSubst := {}
  p.applyFVarSubst (s.insert fvarId v)

partial def hasExprMVar : Pattern → Bool
  | inaccessible e => e.hasExprMVar
  | ctor _ _ ps fs => ps.any (·.hasExprMVar) || fs.any hasExprMVar
  | val e          => e.hasExprMVar
  | as _ p         => hasExprMVar p
  | arrayLit t xs  => t.hasExprMVar || xs.any hasExprMVar
  | _              => false

end Pattern

partial def instantiatePatternMVars : Pattern → MetaM Pattern
  | Pattern.inaccessible e      => return Pattern.inaccessible (← instantiateMVars e)
  | Pattern.val e               => return Pattern.val (← instantiateMVars e)
  | Pattern.ctor n us ps fields => return Pattern.ctor n us (← ps.mapM instantiateMVars) (← fields.mapM instantiatePatternMVars)
  | Pattern.as x p              => return Pattern.as x (← instantiatePatternMVars p)
  | Pattern.arrayLit t xs       => return Pattern.arrayLit (← instantiateMVars t) (← xs.mapM instantiatePatternMVars)
  | p                   => return p

structure AltLHS where
  ref        : Syntax
  fvarDecls  : List LocalDecl -- Free variables used in the patterns.
  patterns   : List Pattern   -- We use `List Pattern` since we have nary match-expressions.

def instantiateAltLHSMVars (altLHS : AltLHS) : MetaM AltLHS :=
  return { altLHS with
    fvarDecls := (← altLHS.fvarDecls.mapM instantiateLocalDeclMVars),
    patterns  := (← altLHS.patterns.mapM instantiatePatternMVars)
  }

structure Alt where
  ref       : Syntax
  idx       : Nat -- for generating error messages
  rhs       : Expr
  fvarDecls : List LocalDecl
  patterns  : List Pattern
  deriving Inhabited

namespace Alt

partial def toMessageData (alt : Alt) : MetaM MessageData := do
  withExistingLocalDecls alt.fvarDecls do
    let msg : List MessageData := alt.fvarDecls.map fun d => m!"{d.toExpr}:({d.type})"
    let msg : MessageData := m!"{msg} |- {alt.patterns.map Pattern.toMessageData} => {alt.rhs}"
    addMessageContext msg

def applyFVarSubst (s : FVarSubst) (alt : Alt) : Alt :=
  { alt with
    patterns  := alt.patterns.map fun p => p.applyFVarSubst s,
    fvarDecls := alt.fvarDecls.map fun d => d.applyFVarSubst s,
    rhs       := alt.rhs.applyFVarSubst s }

def replaceFVarId (fvarId : FVarId) (v : Expr) (alt : Alt) : Alt :=
  { alt with
    patterns  := alt.patterns.map fun p => p.replaceFVarId fvarId v,
    fvarDecls :=
      let decls := alt.fvarDecls.filter fun d => d.fvarId != fvarId
      decls.map $ replaceFVarIdAtLocalDecl fvarId v,
    rhs       := alt.rhs.replaceFVarId fvarId v }

/-
  Similar to `checkAndReplaceFVarId`, but ensures type of `v` is definitionally equal to type of `fvarId`.
  This extra check is necessary when performing dependent elimination and inaccessible terms have been used.
  For example, consider the following code fragment:

```
inductive Vec (α : Type u) : Nat → Type u where
  | nil : Vec α 0
  | cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)

inductive VecPred {α : Type u} (P : α → Prop) : {n : Nat} → Vec α n → Prop where
  | nil   : VecPred P Vec.nil
  | cons  {n : Nat} {head : α} {tail : Vec α n} : P head → VecPred P tail → VecPred P (Vec.cons head tail)

theorem ex {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
  | _, Vec.cons head _, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩
```
Recall that `_` in a pattern can be elaborated into pattern variable or an inaccessible term.
The elaborator uses an inaccessible term when typing constraints restrict its value.
Thus, in the example above, the `_` at `Vec.cons head _` becomes the inaccessible pattern `.(Vec.nil)`
because the type ascription `(w : VecPred P Vec.nil)` propagates typing constraints that restrict its value to be `Vec.nil`.
After elaboration the alternative becomes:
```
  | .(0), @Vec.cons .(α) .(0) head .(Vec.nil), @VecPred.cons .(α) .(P) .(0) .(head) .(Vec.nil) h w => ⟨head, h⟩
```
where
```
(head : α), (h: P head), (w : VecPred P Vec.nil)
```
Then, when we process this alternative in this module, the following check will detect that
`w` has type `VecPred P Vec.nil`, when it is supposed to have type `VecPred P tail`.
Note that if we had written
```
theorem ex {α : Type u} (P : α → Prop) : {n : Nat} → (v : Vec α (n+1)) → VecPred P v → Exists P
  | _, Vec.cons head Vec.nil, VecPred.cons h (w : VecPred P Vec.nil) => ⟨head, h⟩
```
we would get the easier to digest error message
```
missing cases:
_, (Vec.cons _ _ (Vec.cons _ _ _)), _
```
-/
def checkAndReplaceFVarId (fvarId : FVarId) (v : Expr) (alt : Alt) : MetaM Alt := do
  match alt.fvarDecls.find? fun (fvarDecl : LocalDecl) => fvarDecl.fvarId == fvarId with
  | none          => throwErrorAt alt.ref "unknown free pattern variable"
  | some fvarDecl => do
    let vType ← inferType v
    unless (← isDefEqGuarded fvarDecl.type vType) do
      withExistingLocalDecls alt.fvarDecls do
        let (expectedType, givenType) ← addPPExplicitToExposeDiff vType fvarDecl.type
        throwErrorAt alt.ref "type mismatch during dependent match-elimination at pattern variable '{mkFVar fvarDecl.fvarId}' with type{indentExpr givenType}\nexpected type{indentExpr expectedType}"
    pure $ replaceFVarId fvarId v alt

end Alt

inductive Example where
  | var        : FVarId → Example
  | underscore : Example
  | ctor       : Name → List Example → Example
  | val        : Expr → Example
  | arrayLit   : List Example → Example

namespace Example

partial def replaceFVarId (fvarId : FVarId) (ex : Example) : Example → Example
  | var x        => if x == fvarId then ex else var x
  | ctor n exs   => ctor n $ exs.map (replaceFVarId fvarId ex)
  | arrayLit exs => arrayLit $ exs.map (replaceFVarId fvarId ex)
  | ex           => ex

partial def applyFVarSubst (s : FVarSubst) : Example → Example
  | var fvarId =>
    match s.get fvarId with
    | Expr.fvar fvarId' _ => var fvarId'
    | _                   => underscore
  | ctor n exs   => ctor n $ exs.map (applyFVarSubst s)
  | arrayLit exs => arrayLit $ exs.map (applyFVarSubst s)
  | ex           => ex

partial def varsToUnderscore : Example → Example
  | var x        => underscore
  | ctor n exs   => ctor n $ exs.map varsToUnderscore
  | arrayLit exs => arrayLit $ exs.map varsToUnderscore
  | ex           => ex

partial def toMessageData : Example → MessageData
  | var fvarId        => mkFVar fvarId
  | ctor ctorName []  => mkConst ctorName
  | ctor ctorName exs => m!"({mkConst ctorName}{exs.foldl (fun msg pat => m!"{msg} {toMessageData pat}") Format.nil})"
  | arrayLit exs      => "#" ++ MessageData.ofList (exs.map toMessageData)
  | val e             => e
  | underscore        => "_"

end Example

def examplesToMessageData (cex : List Example) : MessageData :=
  MessageData.joinSep (cex.map (Example.toMessageData ∘ Example.varsToUnderscore)) ", "

structure Problem where
  mvarId        : MVarId
  vars          : List Expr
  alts          : List Alt
  examples      : List Example
  deriving Inhabited

def withGoalOf {α} (p : Problem) (x : MetaM α) : MetaM α :=
  withMVarContext p.mvarId x

def Problem.toMessageData (p : Problem) : MetaM MessageData :=
  withGoalOf p do
    let alts ← p.alts.mapM Alt.toMessageData
    let vars ← p.vars.mapM fun x => do let xType ← inferType x; pure m!"{x}:({xType})"
    return m!"remaining variables: {vars}\nalternatives:{indentD (MessageData.joinSep alts Format.line)}\nexamples:{examplesToMessageData p.examples}\n"

abbrev CounterExample := List Example

def counterExampleToMessageData (cex : CounterExample) : MessageData :=
  examplesToMessageData cex

def counterExamplesToMessageData (cexs : List CounterExample) : MessageData :=
  MessageData.joinSep (cexs.map counterExampleToMessageData) Format.line

structure MatcherResult where
  matcher         : Expr -- The matcher. It is not just `Expr.const matcherName` because the type of the major premises may contain free variables.
  counterExamples : List CounterExample
  unusedAltIdxs   : List Nat
  addMatcher      : MetaM Unit

/--
  Convert a expression occurring as the argument of a `match` motive application back into a `Pattern`
  For example, we can use this method to convert `x::y::xs` at
  ```
  ...
  (motive : List Nat → Sort u_1) (xs : List Nat) (h_1 : (x y : Nat) → (xs : List Nat) → motive (x :: y :: xs))
  ...
  ```
  into a pattern object
-/
partial def toPattern (e : Expr) : MetaM Pattern := do
  match inaccessible? e with
  | some t => return Pattern.inaccessible t
  | none =>
    match e.arrayLit? with
    | some (α, lits) =>
      return Pattern.arrayLit α (← lits.mapM toPattern)
    | none =>
      if e.isAppOfArity `namedPattern 3 then
        let p ← toPattern <| e.getArg! 2
        match e.getArg! 1 with
        | Expr.fvar fvarId _ => return Pattern.as fvarId p
        | _                  => throwError "unexpected occurrence of auxiliary declaration 'namedPattern'"
      else if e.isNatLit || e.isStringLit || e.isCharLit then
        return Pattern.val e
      else if e.isFVar then
        return Pattern.var e.fvarId!
      else
        let newE ← whnf e
        if newE != e then
          toPattern newE
        else matchConstCtor e.getAppFn (fun _ => throwError "unexpected pattern{indentExpr e}") fun v us => do
          let args := e.getAppArgs
          unless args.size == v.numParams + v.numFields do
            throwError "unexpected pattern{indentExpr e}"
          let params := args.extract 0 v.numParams
          let fields := args.extract v.numParams args.size
          let fields ← fields.mapM toPattern
          return Pattern.ctor v.name us params.toList fields.toList

end Lean.Meta.Match


import Lean

-- The `cases` tactic does not use `Lean.Meta.cases` under the hood,
-- so it is unaffected by this issue. We define a tactic
-- `mcases` that delegates to `Lean.Meta.cases`.
syntax (name := mcases) "mcases" ident : tactic

namespace Lean.Elab.Tactic

@[tactic mcases]
def evalMcases : Tactic
| `(tactic| mcases $hyp) => do
  let hyp ← getFVarId hyp
  liftMetaTactic fun goal => do
    let goals ← Lean.Meta.cases goal hyp
    return goals.map (·.mvarId) |>.toList
| _ => unreachable!

end Lean.Elab.Tactic

example : True := by
  let h : ∃ n, n = 0 := ⟨0, rfl⟩
  mcases h
  sorry -- sorry

example : True := by
  have h : ∃ n, n = 0 := ⟨0, rfl⟩
  mcases h
  apply True.intro


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.strong_epi
import category_theory.limits.shapes.equalizers

/-!
# Definitions and basic properties of regular monomorphisms and epimorphisms.

A regular monomorphism is a morphism that is the equalizer of some parallel pair.

We give the constructions
* `split_mono → regular_mono` and
* `regular_mono → mono`
as well as the dual constructions for regular epimorphisms. Additionally, we give the construction
* `regular_epi ⟶ strong_epi`.

We also define classes `regular_mono_category` and `regular_epi_category` for categories in which
every monomorphism or epimorphism is regular, and deduce that these categories are
`strong_mono_category`s resp. `strong_epi_category`s.

-/

noncomputable theory

namespace category_theory
open category_theory.limits

universes v₁ u₁ u₂

variables {C : Type u₁} [category.{v₁} C]

variables {X Y : C}

/-- A regular monomorphism is a morphism which is the equalizer of some parallel pair. -/
class regular_mono (f : X ⟶ Y) :=
(Z : C)
(left right : Y ⟶ Z)
(w : f ≫ left = f ≫ right)
(is_limit : is_limit (fork.of_ι f w))

attribute [reassoc] regular_mono.w

/-- Every regular monomorphism is a monomorphism. -/
@[priority 100]
instance regular_mono.mono (f : X ⟶ Y) [regular_mono f] : mono f :=
mono_of_is_limit_fork regular_mono.is_limit

instance equalizer_regular (g h : X ⟶ Y) [has_limit (parallel_pair g h)] :
  regular_mono (equalizer.ι g h) :=
{ Z := Y,
  left := g,
  right := h,
  w := equalizer.condition g h,
  is_limit := fork.is_limit.mk _ (λ s, limit.lift _ s) (by simp) (λ s m w, by { ext1, simp [←w] }) }

/-- Every split monomorphism is a regular monomorphism. -/
@[priority 100]
instance regular_mono.of_split_mono (f : X ⟶ Y) [split_mono f] : regular_mono f :=
{ Z     := Y,
  left  := 𝟙 Y,
  right := retraction f ≫ f,
  w     := by tidy,
  is_limit := split_mono_equalizes f }

/-- If `f` is a regular mono, then any map `k : W ⟶ Y` equalizing `regular_mono.left` and
    `regular_mono.right` induces a morphism `l : W ⟶ X` such that `l ≫ f = k`. -/
def regular_mono.lift' {W : C} (f : X ⟶ Y) [regular_mono f] (k : W ⟶ Y)
  (h : k ≫ (regular_mono.left : Y ⟶ @regular_mono.Z _ _ _ _ f _) = k ≫ regular_mono.right) :
  {l : W ⟶ X // l ≫ f = k} :=
fork.is_limit.lift' regular_mono.is_limit _ h

/--
The second leg of a pullback cone is a regular monomorphism if the right component is too.

See also `pullback.snd_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_fst_of_regular` for the flipped version.
-/
def regular_of_is_pullback_snd_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono h] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono g :=
{ Z := hr.Z,
  left := k ≫ hr.left,
  right := k ≫ hr.right,
  w := by rw [← reassoc_of comm, ← reassoc_of comm, hr.w],
  is_limit :=
  begin
    apply fork.is_limit.mk' _ _,
    intro s,
    have l₁ : (fork.ι s ≫ k) ≫ regular_mono.left = (fork.ι s ≫ k) ≫ regular_mono.right,
      rw [category.assoc, s.condition, category.assoc],
    obtain ⟨l, hl⟩ := fork.is_limit.lift' hr.is_limit _ l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pullback_cone.is_limit.lift' t _ _ hl,
    refine ⟨p, hp₂, _⟩,
    intros m w,
    have z : m ≫ g = p ≫ g := w.trans hp₂.symm,
    apply t.hom_ext,
    apply (pullback_cone.mk f g comm).equalizer_ext,
    { erw [← cancel_mono h, category.assoc, category.assoc, comm, reassoc_of z] },
    { exact z },
  end }

/--
The first leg of a pullback cone is a regular monomorphism if the left component is too.

See also `pullback.fst_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_snd_of_regular` for the flipped version.
-/
def regular_of_is_pullback_fst_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono k] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono f :=
regular_of_is_pullback_snd_of_regular comm.symm (pullback_cone.flip_is_limit t)

@[priority 100]
instance strong_mono_of_regular_mono (f : X ⟶ Y) [regular_mono f] : strong_mono f :=
{ mono := by apply_instance,
  has_lift :=
  begin
    introsI,
    have : v ≫ (regular_mono.left : Y ⟶ regular_mono.Z f) = v ≫ regular_mono.right,
    { apply (cancel_epi z).1,
      simp only [regular_mono.w, ← reassoc_of h] },
    obtain ⟨t, ht⟩ := regular_mono.lift' _ _ this,
    refine arrow.has_lift.mk ⟨t, (cancel_mono f).1 _, ht⟩,
    simp only [arrow.mk_hom, arrow.hom_mk'_left, category.assoc, ht, h]
  end }

/-- A regular monomorphism is an isomorphism if it is an epimorphism. -/
lemma is_iso_of_regular_mono_of_epi (f : X ⟶ Y) [regular_mono f] [e : epi f] : is_iso f :=
is_iso_of_epi_of_strong_mono _

section
variables (C)

/-- A regular mono category is a category in which every monomorphism is regular. -/
class regular_mono_category :=
(regular_mono_of_mono : ∀ {X Y : C} (f : X ⟶ Y) [mono f], regular_mono f)

end

/-- In a category in which every monomorphism is regular, we can express every monomorphism as
    an equalizer. This is not an instance because it would create an instance loop. -/
def regular_mono_of_mono [regular_mono_category C] (f : X ⟶ Y) [mono f] : regular_mono f :=
regular_mono_category.regular_mono_of_mono _

@[priority 100]
instance regular_mono_category_of_split_mono_category [split_mono_category C] :
  regular_mono_category C :=
{ regular_mono_of_mono := λ _ _ f _,
  by { haveI := by exactI split_mono_of_mono f, apply_instance } }

@[priority 100]
instance strong_mono_category_of_regular_mono_category [regular_mono_category C] :
  strong_mono_category C :=
{ strong_mono_of_mono := λ _ _ f _,
    by { haveI := by exactI regular_mono_of_mono f, apply_instance } }

/-- A regular epimorphism is a morphism which is the coequalizer of some parallel pair. -/
class regular_epi (f : X ⟶ Y) :=
(W : C)
(left right : W ⟶ X)
(w : left ≫ f = right ≫ f)
(is_colimit : is_colimit (cofork.of_π f w))

attribute [reassoc] regular_epi.w

/-- Every regular epimorphism is an epimorphism. -/
@[priority 100]
instance regular_epi.epi (f : X ⟶ Y) [regular_epi f] : epi f :=
epi_of_is_colimit_cofork regular_epi.is_colimit

instance coequalizer_regular (g h : X ⟶ Y) [has_colimit (parallel_pair g h)] :
  regular_epi (coequalizer.π g h) :=
{ W := X,
  left := g,
  right := h,
  w := coequalizer.condition g h,
  is_colimit := cofork.is_colimit.mk _ (λ s, colimit.desc _ s) (by simp)
    (λ s m w, by { ext1, simp [←w] }) }

/-- Every split epimorphism is a regular epimorphism. -/
@[priority 100]
instance regular_epi.of_split_epi (f : X ⟶ Y) [split_epi f] : regular_epi f :=
{ W     := X,
  left  := 𝟙 X,
  right := f ≫ section_ f,
  w     := by tidy,
  is_colimit := split_epi_coequalizes f }

/-- If `f` is a regular epi, then every morphism `k : X ⟶ W` coequalizing `regular_epi.left` and
    `regular_epi.right` induces `l : Y ⟶ W` such that `f ≫ l = k`. -/
def regular_epi.desc' {W : C} (f : X ⟶ Y) [regular_epi f] (k : X ⟶ W)
  (h : (regular_epi.left : regular_epi.W f ⟶ X) ≫ k = regular_epi.right ≫ k) :
  {l : Y ⟶ W // f ≫ l = k} :=
cofork.is_colimit.desc' (regular_epi.is_colimit) _ h

/--
The second leg of a pushout cocone is a regular epimorphism if the right component is too.

See also `pushout.snd_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_fst_of_regular` for the flipped version.
-/
def regular_of_is_pushout_snd_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [gr : regular_epi g] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi h :=
{ W := gr.W,
  left := gr.left ≫ f,
  right := gr.right ≫ f,
  w := by rw [category.assoc, category.assoc, comm, reassoc_of gr.w],
  is_colimit :=
  begin
    apply cofork.is_colimit.mk' _ _,
    intro s,
    have l₁ : gr.left ≫ f ≫ s.π = gr.right ≫ f ≫ s.π,
      rw [← category.assoc, ← category.assoc, s.condition],
    obtain ⟨l, hl⟩ := cofork.is_colimit.desc' gr.is_colimit (f ≫ cofork.π s) l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pushout_cocone.is_colimit.desc' t _ _ hl.symm,
    refine ⟨p, hp₁, _⟩,
    intros m w,
    have z := w.trans hp₁.symm,
    apply t.hom_ext,
    apply (pushout_cocone.mk _ _ comm).coequalizer_ext,
    { exact z },
    { erw [← cancel_epi g, ← reassoc_of comm, ← reassoc_of comm, z], refl },
  end }

/--
The first leg of a pushout cocone is a regular epimorphism if the left component is too.

See also `pushout.fst_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_snd_of_regular` for the flipped version.
-/
def regular_of_is_pushout_fst_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [fr : regular_epi f] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi k :=
regular_of_is_pushout_snd_of_regular comm.symm (pushout_cocone.flip_is_colimit t)

@[priority 100]
instance strong_epi_of_regular_epi (f : X ⟶ Y) [regular_epi f] : strong_epi f :=
{ epi := by apply_instance,
  has_lift :=
  begin
    introsI,
    have : (regular_epi.left : regular_epi.W f ⟶ X) ≫ u = regular_epi.right ≫ u,
    { apply (cancel_mono z).1,
      simp only [category.assoc, h, regular_epi.w_assoc] },
    obtain ⟨t, ht⟩ := regular_epi.desc' f u this,
    exact arrow.has_lift.mk ⟨t, ht, (cancel_epi f).1
      (by simp only [←category.assoc, ht, ←h, arrow.mk_hom, arrow.hom_mk'_right])⟩,
  end }

/-- A regular epimorphism is an isomorphism if it is a monomorphism. -/
lemma is_iso_of_regular_epi_of_mono (f : X ⟶ Y) [regular_epi f] [m : mono f] : is_iso f :=
is_iso_of_mono_of_strong_epi _

section
variables (C)

/-- A regular epi category is a category in which every epimorphism is regular. -/
class regular_epi_category :=
(regular_epi_of_epi : ∀ {X Y : C} (f : X ⟶ Y) [epi f], regular_epi f)

end

/-- In a category in which every epimorphism is regular, we can express every epimorphism as
    a coequalizer. This is not an instance because it would create an instance loop. -/
def regular_epi_of_epi [regular_epi_category C] (f : X ⟶ Y) [epi f] : regular_epi f :=
regular_epi_category.regular_epi_of_epi _

@[priority 100]
instance regular_epi_category_of_split_epi_category [split_epi_category C] :
  regular_epi_category C :=
{ regular_epi_of_epi := λ _ _ f _, by { haveI := by exactI split_epi_of_epi f, apply_instance } }

@[priority 100]
instance strong_epi_category_of_regular_epi_category [regular_epi_category C] :
  strong_epi_category C :=
{ strong_epi_of_epi := λ _ _ f _, by { haveI := by exactI regular_epi_of_epi f, apply_instance } }

end category_theory


import Mt.Reservation

namespace Mt.TaskM.impl

inductive IterationResult (spec : Spec) (T : Type)
| Done : spec.State -> T -> IterationResult spec T
| Panic : spec.State -> String -> IterationResult spec T
| Running : spec.State -> (spec.State -> Bool) ->
    (spec.State -> IterationResult spec T) ->
    IterationResult spec T

def TaskM (spec : Spec) (T : Type) :=spec.State -> IterationResult spec T

namespace TaskM

variable {spec : Spec}

def atomic_read_modify_read
  (f : spec.State -> T × spec.State)
  : TaskM spec T
| s => match f s with
  | ⟨t, s'⟩ => IterationResult.Done s' t

def panic {T : Type} (msg : String) : TaskM spec T
| s => IterationResult.Panic s msg

def atomic_assert
  (cond : spec.State -> Bool)
  : TaskM spec Unit
| s => if cond s then
    IterationResult.Done s ⟨⟩
  else
    IterationResult.Panic s "Assertion failed"

def atomic_blocking_rmr
  (block_until : spec.State -> Bool)
  (f : spec.State -> T × spec.State) : TaskM spec T
| s => IterationResult.Running s block_until (atomic_read_modify_read f)

inductive is_direct_cont {T : Type} : TaskM spec T -> TaskM spec T -> Prop
| running
    {p cont : TaskM spec T}
    {s s'}
    {block_until : spec.State -> Bool}
    (iteration : p s = IterationResult.Running s' block_until cont)
    : is_direct_cont cont p

theorem is_direct_cont.wf {T : Type} : WellFounded (@is_direct_cont spec T) :=by
  constructor
  intro p
  constructor
  intro cont is_cont
  cases is_cont
  rename_i s s' bu iteration
  exact helper (p s) cont iteration

where
  helper (it : IterationResult spec T) (p : TaskM spec T) {s block_until} :
    it = IterationResult.Running s block_until p → Acc is_direct_cont p :=by
    revert p s block_until
    induction it
    . intros ; contradiction
    . intros ; contradiction
    . intro p s bu h
      rename_i s' bu' p' IH
      injection h ; rename_i h ; rw [h] at IH
      constructor
      intro cont is_cont ; cases is_cont ; rename_i h
      exact IH _ _ h

instance instWf {T : Type} : WellFoundedRelation (TaskM spec T) where
  rel :=is_direct_cont
  wf  :=is_direct_cont.wf

def pure {T : Type} (t : T) : TaskM spec T :=
  λ s => IterationResult.Done s t

def bind {U V : Type} (mu : TaskM spec U) (f : U -> TaskM spec V) : TaskM spec V :=
  λ s => match h : mu s with
    | IterationResult.Done s' u => IterationResult.Running s' (λ _ => true) (f u)
    | IterationResult.Panic s' msg => IterationResult.Panic s' msg
    | IterationResult.Running s' block_until cont =>
        have : is_direct_cont cont mu :=⟨h⟩
        IterationResult.Running s' block_until (bind cont f)
termination_by bind => mu

theorem bind_def {U V spec}
  {mu : TaskM spec U} {f : U -> TaskM spec V}
  {s}
  : (bind mu f) s = match mu s with
    | IterationResult.Done s' u => IterationResult.Running s' (λ _ => true) (f u)
    | IterationResult.Panic s' msg => IterationResult.Panic s' msg
    | IterationResult.Running s' block_until cont =>
        IterationResult.Running s' block_until (bind cont f) :=by
  simp only [bind]
  cases mu s <;> rfl

theorem bind_assoc {U V W : Type}
  (mu : TaskM spec U)
  (f : U -> TaskM spec V)
  (g : V -> TaskM spec W) :
  mu.bind (fun u => (f u).bind g) = (mu.bind f).bind g :=by
  apply funext ; intro s0
  simp only [bind_def]
  induction mu s0 <;> try rfl
  rename_i s' block_until cont IH
  simp only []
  simp only [<- bind_def] at IH
  apply congrArg (IterationResult.Running _ _)
  apply funext ; intro s
  exact IH ..

end TaskM

end Mt.TaskM.impl


import Lean.Meta.Tactic.Rewrite
import Lean.Meta.Tactic.Replace
import Lean.Elab.Tactic.Basic
import Lean.Elab.Tactic.ElabTerm
import Lean.Elab.Tactic.Location
import Lean.Elab.Tactic.Config
open Lean Meta Elab Tactic
open Lean.Elab.Term

/- Shows how to get arguments to tactics
elab "myTactic" argumentStx:term : tactic =>  do
  let goals <- getGoals
  let target <- getMainTarget
  match target.eq? with
  | none =>  throwError "target {target} is not an equality"
  | some (equalityType, equalityLhs, equalityRhs) =>
    let maingoal <- getMainGoal
    let argumentAsTy <- Lean.Elab.Term.elabType argumentStx

    liftMetaTactic fun mvarId => do
      -- let (h, mvarId) <- intro1P mvarId
      -- let goals <- apply mvarId (mkApp (mkConst ``Or.elim) (mkFVar h))
      let lctx <- getLCtx
      let mctx <- getMCtx
      let hypsOfType <- lctx.foldlM (init := []) (fun accum decl =>  do
          if decl.type == equalityType
          then return (decl.userName, decl.type) :: accum
          else return accum)
      let out := "\n====\n"
      let out := out ++ m!"-argumentStx: {argumentStx}\n"
      let out := out ++ m!"-argumentAsTy: {argumentAsTy}\n"
      let out := out ++ m!"-equalityType: {equalityType}\n"
      let out := out ++ m!"-equalityLhs: {equalityLhs}\n"
      let out := out ++ m!"-equalityRhs: {equalityRhs}\n"
      let out := out ++ m!"-hypsOfEqualityType: {hypsOfType}\n"
      -- let out := out ++ m!"-argumentStx: {argumentStx}\n"
      -- let out := out ++ m!"-mainGoal: {maingoal}\n"
      -- let out := out ++ m!"-goals: {goals}\n"
      -- let out := out ++ m!"-target: {target}\n"
      let out := out ++ "\n====\n"
      throwTacticEx `myTactic mvarId out
      return goals
-/

elab "myTactic" : tactic =>  do
  let goals <- getGoals
  let target <- getMainTarget
  match target.eq? with
  | none =>  throwError "target {target} is not an equality"
  | some (equalityType, equalityLhs, equalityRhs) =>
    let maingoal <- getMainGoal
    liftMetaTactic fun mvarId => do
      -- let (h, mvarId) <- intro1P mvarId
      -- let goals <- apply mvarId (mkApp (mkConst ``Or.elim) (mkFVar h))
      let lctx <- getLCtx
      let mctx <- getMCtx
      let hypsOfType <- lctx.foldlM (init := []) (fun accum decl =>  do
          if decl.type == equalityType
          then return (decl.userName, decl.type) :: accum
          else return accum)
      let out := "\n====\n"
      let out := out ++ m!"-equalityType: {equalityType}\n"
      let out := out ++ m!"-equalityLhs: {equalityLhs}\n"
      let out := out ++ m!"-equalityRhs: {equalityRhs}\n"
      let out := out ++ m!"-hypsOfEqualityType: {hypsOfType}\n"
      -- let out := out ++ m!"-argumentStx: {argumentStx}\n"
      -- let out := out ++ m!"-mainGoal: {maingoal}\n"
      -- let out := out ++ m!"-goals: {goals}\n"
      -- let out := out ++ m!"-target: {target}\n"
      let out := out ++ "\n====\n"
      throwTacticEx `myTactic mvarId out
      return goals

-- theorem test {p: Prop} : (p ∨ p) -> p := by
--   intro h
--   apply Or.elim h
--   trace_state

-- TODO: Figure out how to extract hypotheses from goal.
theorem testSuccess : ∀ (anat: Nat) (bint: Int) (cnat: Nat) (dint: Int) (eint: Int), bint = dint := by
 intros a b c d e
 myTactic
 sorry

theorem testGoalNotEqualityMustFail  : ∀ (a: Nat) (b: Int) (c: Nat) , Nat := by
 intros a b c
 myTactic


import vc0.basic

namespace c0
open ast

namespace value

def ts_sized (Γ : ast) : type ⊕ sdef → Prop
| (sum.inl τ) := Γ.sized τ
| (sum.inr sd) := ∀ τ ∈ sd.values, Γ.sized τ

theorem default_exists {Γ : ast} (ok : Γ.okind) :
  ∀ ts, ts_sized Γ ts → ∃ (v : value), default Γ ts v :=
ast.okind.induction' ok $ λ Γ ok IH, begin
  have : ∀ {τ}, Γ.sized τ → ∃ (v : value), default Γ (sum.inl τ) v,
  { intros τ sz, induction τ,
    { exact ⟨_, default.int⟩ },
    { exact ⟨_, default.bool⟩ },
    { exact ⟨_, default.ref⟩ },
    { exact ⟨_, default.arr⟩ },
    { cases sz with sd h,
      cases (get_sdef_ex_iff ok).1 ⟨_, h⟩ with xτs m,
      cases IH with d Γ ok' IH'; rcases m with rfl | m,
      { rcases sdecl_ok1 ok' with ⟨nd, sd', al, sz⟩,
        cases get_sdef_determ ok h ⟨or.inl rfl, al.imp $ λ _ _ _ h, h.weak⟩,
        rcases IH' (sum.inr sd) sz with ⟨v, h'⟩,
        exact ⟨_, default.struct h h'.weak⟩ },
      { cases ok,
        cases (get_sdef_ex_iff ok_a_1).2 ⟨_, m⟩ with sd' h₁,
        cases IH' (sum.inl (type.struct τ)) ⟨_, h₁⟩ with v h₂,
        exact ⟨v, h₂.weak⟩ } } },
  rintro (τ | sd) sz,
  { exact this sz },
  { refine alist.rec' (λ sz, ⟨_, default.nil⟩) (λ sd x τ h IH sz, _) sd sz,
    cases list.forall_mem_cons.1 sz with sz₁ sz₂,
    cases this sz₁ with v v0,
    cases IH sz₂ with vs vs0,
    exact ⟨_, default.cons v0 vs0⟩ }
end

end value

namespace addr

theorem update_at.progress {α β} (S : α → β → Prop) {b}
  {R : α → α → Prop} (hR : ∀ x, S x b → ∃ y, R x y) :
  ∀ {l₁ l₂}, list.forall₂ S l₁ l₂ → ∀ {n}, b ∈ list.nth l₂ n → ∃ l', list.update_at R n l₁ l'
| _ _ (@list.forall₂.cons _ _ S a b' l₁ l₂ r h) 0 rfl :=
  let ⟨y, r⟩ := hR a r in ⟨_, list.update_at.one r⟩
| _ _ (@list.forall₂.cons _ _ S a b' l₁ l₂ r h) (n+1) h' :=
  let ⟨l₂, r⟩ := update_at.progress h h' in
  ⟨_, list.update_at.cons r⟩

theorem at_head.progress {Γ E τ τs}
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τ → ∃ y, R x y)
  (x) (xok : value.ok Γ E x (vtype.cons τ τs)) :
  ∃ y, value.at_head R x y :=
by cases xok; cases hR _ xok_a with v' h'; exact ⟨_, ⟨h'⟩⟩

theorem at_tail.progress {Γ E τ τs}
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τs → ∃ y, R x y)
  (x) (xok : value.ok Γ E x (vtype.cons τ τs)) :
  ∃ y, value.at_tail R x y :=
by cases xok; cases hR _ xok_a_1 with v' h'; exact ⟨_, ⟨h'⟩⟩

theorem at_nth'.progress {Γ E τ}
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τ → ∃ y, R x y) :
  ∀ {i n}, i < n → ∀ x, value.ok Γ E x (vtype.arr' τ n) →
  ∃ y, value.at_nth' R i x y
| 0     (n+1) h := at_head.progress hR
| (i+1) (n+1) h := at_tail.progress (at_nth'.progress (nat.lt_of_succ_lt_succ h))

theorem at_nth.progress {Γ E τ}
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τ → ∃ y, R x y)
  {i n} (lt : i < n) (x) (xok : value.ok Γ E x (vtype.arr τ n)) :
  ∃ y, value.at_nth R i x y :=
begin
  cases xok,
  cases at_nth'.progress hR lt _ xok_a with y h,
  exact ⟨_, lt, h⟩
end

theorem at_field.progress {Γ E τ}
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τ → ∃ y, R x y)
  {s sd f} (hd : Γ.get_sdef s sd)
  {t} (ht : t ∈ sd.lookup f) (tτ : vtype.of_ty (exp.type.reg t) τ)
  (x) (xok : value.ok Γ E x (vtype.struct s)) :
  ∃ y, value.at_field R f x y :=
begin
  rcases xok with _|_|_|_|_|_|_|_|⟨_, vs, rfl, al⟩,
  cases vtype.of_ty_alist sd with τs sτ,
  rcases value.of_map_ok.1 (al _ _ hd sτ) with ⟨vs', e, h⟩,
  cases value.of_map_inj e,
  rcases sτ.rel_of_lookup_right ht with ⟨τ', hτ, tτ'⟩,
  cases vtype.of_ty_determ tτ tτ',
  rcases h.flip.rel_of_lookup_right hτ with ⟨v, m, vok⟩,
  cases hR _ vok with y r,
  exact ⟨_, r, m, rfl, rfl⟩
end

theorem update.progress {Γ E σ H η} (ok : ast.okind Γ)
  (Eok : heap.ok Γ H E) (ηok : vars.ok Γ E η σ)
  {a τ} (aok : addr.ok Γ E σ a τ)
  {R : value → value → Prop} (hR : ∀ x, value.ok Γ E x τ → ∃ y, R x y)
  (Rok : ∀ x, value.ok Γ E x τ → ∀ y, R x y → value.ok Γ E y τ) :
  ∃ H' η', update H η R a H' η' :=
begin
  induction a generalizing τ R; cases aok,
  { cases update_at.progress _ hR Eok aok_a with H' h,
    exact ⟨_, _, update.ref h⟩ },
  { rcases ηok _ _ aok_a with ⟨v, h, vok⟩,
    cases hR v vok with v' h',
    exact ⟨_, _, update.var h h' rfl⟩ },
  { rcases a_ih aok_a_1 (at_head.progress hR) (at_head.ok Rok) with ⟨H', η', h⟩,
    exact ⟨_, _, update.head h⟩ },
  { rcases a_ih aok_a_1 (at_tail.progress hR) (at_tail.ok Rok) with ⟨H', η', h⟩,
    exact ⟨_, _, update.tail h⟩ },
  { rcases a_ih aok_a_2 (at_nth.progress hR aok_a_1) (at_nth.ok Rok aok_a_1) with ⟨H', η', h⟩,
    exact ⟨_, _, update.nth h⟩ },
  { rcases a_ih aok_a_4 (at_field.progress hR aok_a_1 aok_a_2 aok_a_3)
      (at_field.ok ok Rok aok_a_1 aok_a_2 aok_a_3) with ⟨H', η', h⟩,
    exact ⟨_, _, update.field h⟩ }
end

theorem get.progress {Γ E σ Δ H η a τ}
  (Eok : heap.ok Γ H E) (σok : vars_ty.ok Δ σ)
  (ηok : vars.ok Γ E η σ) (aok : addr.ok Γ E σ a τ) :
  ∃ v, get H η a v :=
begin
  induction aok,
  { rcases Eok.flip.nth_right aok_a with ⟨v, h, vok⟩,
    exact ⟨_, get.ref h⟩ },
  { rcases ηok _ _ aok_a with ⟨v, h, vok⟩,
    exact ⟨_, get.var h⟩ },
  { rcases aok_ih with ⟨v, h⟩,
    cases get.ok σok Eok ηok aok_a_1 h,
    exact ⟨_, get.head h⟩ },
  { rcases aok_ih with ⟨v, h⟩,
    cases get.ok σok Eok ηok aok_a_1 h,
    exact ⟨_, get.tail h⟩ },
  case c0.addr.ok.nth : a i n τ lt aok IH {
    rcases IH with ⟨_, h⟩,
    cases get.ok σok Eok ηok aok h,
    suffices : ∃ v', value.is_nth i v v',
    { cases this with v' h', exact ⟨v', get.nth h h'⟩ },
    clear h aok _x,
    induction i with i IH generalizing n v,
    { cases n, {cases lt},
      cases a_1, exact ⟨_, value.is_nth.zero⟩ },
    { cases n, {cases lt},
      cases a_1 with _ _ _ _ _ v vs _ _ vok vsok,
      cases IH (nat.lt_of_succ_lt_succ lt) vsok with v' h',
      exact ⟨_, value.is_nth.succ h'⟩ } },
  case c0.addr.ok.field : a s f t sd τ hd hf tτ aok IH {
    rcases IH with ⟨v, h⟩,
    cases get.ok σok Eok ηok aok h, subst v,
    cases vtype.of_ty_alist sd with τs sτ,
    rcases value.of_map_ok.1 (a_1 _ _ hd sτ) with ⟨vs', e, al⟩,
    cases value.of_map_inj e,
    rcases sτ.rel_of_lookup_right hf with ⟨τ', hτ, tτ'⟩,
    cases vtype.of_ty_determ tτ tτ',
    rcases al.flip.rel_of_lookup_right hτ with ⟨v', h', vok⟩,
    exact ⟨v', get.field h h'⟩ }
end

theorem get_len.progress {Γ E σ Δ H η a τ n}
  (Eok : heap.ok Γ H E) (σok : vars_ty.ok Δ σ)
  (ηok : vars.ok Γ E η σ) (aok : addr.ok Γ E σ a (vtype.arr τ n)) :
  get_len H η a n :=
begin
  cases get.progress Eok σok ηok aok with v h,
  cases get.ok σok Eok ηok aok h, exact ⟨h⟩
end

end addr

theorem alloc_arr.progress (i:int32) :
  (∃ (j:ℕ), (i:ℤ) = j) ∨ i < 0 :=
begin
  cases lt_or_le (i:ℤ) 0 with h₁,
  { rw [← int32.coe_zero, int32.coe_lt] at h₁,
    exact or.inr h₁ },
  { cases e : (i:ℤ) with j,
    { exact or.inl ⟨_, rfl⟩ },
    { rw e at h, cases h } },
end

theorem bounds.progress (n : ℕ) (i:int32) :
  (∃ (j:ℕ), (i:ℤ) = j ∧ j < n) ∨ i < 0 ∨ (n:ℤ) ≤ (i:ℤ) :=
begin
  rcases alloc_arr.progress i with ⟨j, e⟩ | h,
  { cases lt_or_le (i:ℤ) (n:ℤ) with h₂,
    { refine or.inl ⟨j, e, int.coe_nat_lt.1 _⟩,
      rw ← e, exact h₂ },
    { exact or.inr (or.inr h) } },
  { exact or.inr (or.inl h) }
end

theorem step_binop.progress {Γ E op v₁ v₂ t₁ t₂ τ₁}
  (opok : binop.ok op t₁ t₂)
  (tτ₁ : vtype.of_ty (exp.type.reg t₁) τ₁)
  (vok₁ : value.ok Γ E v₁ τ₁)
  (vok₂ : value.ok Γ E v₂ τ₁) :
  ∃ v, value.step_binop op v₁ v₂ v :=
begin
  cases opok,
  case c0.binop.ok.comp {
    cases tτ₁, cases vok₁ with n₁, cases vok₂ with n₂,
    have : ∃ b, value.step_comp opok_1 (value.int n₁) (value.int n₂) b,
    { cases opok_1; exact ⟨_, by constructor⟩ },
    cases this with b h,
    exact ⟨_, value.step_binop.comp h⟩ },
  case c0.binop.ok.eq { exact ⟨_, by constructor; constructor⟩ },
  case c0.binop.ok.ne { exact ⟨_, by constructor; constructor⟩ },
  all_goals {
    cases tτ₁, cases vok₁, cases vok₂,
    exact ⟨_, by constructor⟩ }
end

theorem step_unop.progress  {Γ E op v t₁ t₂ τ₁}
  (opok : unop.ok op t₁ t₂)
  (tτ : vtype.of_ty (exp.type.reg t₁) τ₁)
  (vok : value.ok Γ E v τ₁) :
  ∃ v', value.step_unop op v v' :=
by cases opok; {
  cases tτ, cases vok,
  exact ⟨_, by constructor⟩ }

theorem step_call.progress {Γ E Δ f vs ts τs t τ s}
  (ok : ast.ok Γ)
  (fd : get_fdef Γ f ⟨ts, t⟩)
  (hs : get_body Γ f τ Δ s)
  (tτ : vtype.of_ty (exp.type.ls ts) τs)
  (vsok : value.ok Γ E vs τs) :
  ∃ η, step_call Δ vs η :=
begin
  cases hs,
  have : list.forall₂ (λ (c : ident × ast.type), eval_ty Γ c.2) hs_xτs Δ.values,
  { rw [alist.values, list.forall₂_map_right_iff],
    unfold alist.forall₂ at hs_a_1,
    rw [alist.mk'_entries, list.forall₂_map_left_iff] at hs_a_1,
    refine hs_a_1.imp _, rintro _ _ ⟨i, t, τ, h⟩, exact h },
  cases ok.fdef_uniq fd (ast.get_fdef.mk hs_a this hs_a_2),
  clear _x this fd hs_a hs_a_1 hs_a_2 hs_nd,
  change Δ.entries.map sigma.snd with Δ.values,
  refine alist.rec' _ (λ Δ x t h IH, _) Δ vs τs vsok tτ; intros vs τs vsok tτ,
  { cases tτ, cases vsok,
    exact ⟨_, by constructor⟩ },
  { cases tτ, cases vsok,
    rcases IH _ _ vsok_a_1 tτ_a_1 with ⟨η, h⟩,
    exact ⟨_, step_call.cons _ h⟩ }
end

theorem step_ret.progress {Γ E σs H S η τ v}
  (Sok : stack.ok Γ E σs S τ) (vok : value.ok Γ E v τ) :
  ∃ s', step_ret ⟨H, S, η⟩ v s' :=
begin
  cases Sok,
  { cases vok, exact ⟨_, step_ret.done⟩ },
  { exact ⟨_, step_ret.ret⟩ }
end

theorem step_deref.progress {Γ E σ Δ H S η a τ K}
  (Eok : heap.ok Γ H E) (σok : vars_ty.ok Δ σ)
  (ηok : vars.ok Γ E η σ) (aok : addr_opt.ok Γ E σ a τ) :
  ∃ s', step_deref ⟨H, S, η⟩ a K s' :=
begin
  cases a,
  { exact ⟨_, step_deref.null⟩ },
  { cases addr.get.progress Eok σok ηok aok with v h,
    exact ⟨_, step_deref.deref h⟩ }
end

inductive progresses (Γ : ast) (s : state) : Prop
| final {} : s.final → progresses
| prog {s'} : step Γ s none s' → progresses
| io {i} (f : heap × value → state) :
  (∀ o, step Γ s (some (i, o)) (f o)) → progresses
open progresses

theorem progress {Γ : ast} (ok : Γ.ok)
  {s} (stok : state.ok Γ s) : progresses Γ s :=
begin
  cases stok,
  case c0.state.ok.stmt : E σs σ Δ C τ δ s K t Cok tτ sok si Kok {
    cases Cok with _ _ _ H η S _ _ σok Eok ηok Sok,
    cases sok,
    { exact prog (step.decl sok_a) },
    { exact prog (step.decl_asgn sok_a) },
    { exact prog step.If₁ },
    { exact prog step.while },
    { cases e : lval.is_var sok_lv,
      { exact prog (step.asgn₁ e) },
      { exact prog (step.asgn_var₁ e) } },
    { exact prog step.asnop₁ },
    { exact prog step.eval₁ },
    { exact prog step.assert₁ },
    { cases sok_e,
      { cases sok_a, cases tτ,
        cases step_ret.progress Sok value.ok.nil with s' h,
        exact prog (step.ret_none h) },
      { exact prog step.ret₁ } },
    { cases K,
      { rcases Kok with ⟨⟨⟩⟩ | Kok,
        cases Kok.eq_none, cases tτ,
        cases step_ret.progress Sok value.ok.nil with s' h,
        exact prog (step.nop₁ h) },
      { exact prog step.nop₂ } },
    { exact prog step.seq } },
  case c0.state.ok.exp : E σs σ H η S Δ ret τ e α K Cok eu lok eok {
    cases Cok with _ _ _ H η S _ _ σok Eok ηok Sok,
    rcases eok with ⟨t, eok, tτ⟩,
    cases α,
    { cases eok,
      { exact prog step.int },
      { exact prog step.bool },
      { exact prog step.null },
      { rcases finmap.exists_mem_lookup_iff.2 (finmap.mem_keys.1 eu) with ⟨τ', iτ'⟩,
        rcases ηok _ _ iτ' with ⟨v, h, vok⟩,
        exact prog (step.var h) },
      { exact prog step.binop₁ },
      { exact prog step.unop₁ },
      { exact prog step.cond₁ },
      { exact prog step.nil },
      { exact prog step.cons₁ },
      { exact prog step.call₁ },
      { exact prog step.field },
      { exact prog step.deref },
      { exact prog step.index },
      { cases value.default_exists ok.ind (sum.inl _) eok_a_1 with v v0,
        exact prog (step.alloc_ref eok_a v0 ⟨⟩) },
      { exact prog (step.alloc_arr₁ eok_a) } },
    { cases lok,
      { exact prog step.addr_var },
      { exact prog step.addr_deref₁ },
      { exact prog step.addr_index₁ },
      { exact prog step.addr_field₁ } } },
  case c0.state.ok.ret : E σs σ H η S Δ ret τ α a K Cok aok Kok {
    cases Cok with _ _ _ H η S _ _ σok Eok ηok Sok,
    cases Kok,
    { cases aok,
      exact prog step.If₂ },
    { exact prog step.asgn₂ },
    { cases Kok_a,
      { exact prog step.asgn_err },
      { rcases addr.update.progress ok.ind Eok ηok
          Kok_a_1 (by exact λ _ _, ⟨a, rfl⟩)
          (addr.eq.ok aok) with ⟨H', η', h⟩,
        exact prog (step.asgn₃ h) } },
    { exact prog step.asgn_var₂ },
    { cases step_deref.progress Eok σok ηok aok with s' h,
      exact prog (step.asnop₂ h) },
    { exact prog step.eval₂ },
    { cases aok,
      exact prog step.assert₂ },
    { cases step_ret.progress Sok aok with s' h,
      exact prog (step.ret₂ h) },
    { cases aok;
      exact prog step.addr_deref₂ },
    { cases a,
      { exact prog step.addr_field_err },
      { exact prog step.addr_field₂ } },
    { cases aok;
      exact prog step.addr_index₂ },
    { cases aok, cases Kok_o,
      { exact prog step.addr_index_err₁ },
      { cases Kok_a _ rfl with n aok,
        have h := addr.get_len.progress Eok σok ηok aok,
        rcases bounds.progress n aok_1 with ⟨j, h₁, h₂⟩ | h',
        { exact prog (step.addr_index₃ h h₁ h₂) },
        { exact prog (step.addr_index_err₂ h h') } } },
    { exact prog step.binop₂ },
    { rcases step_binop.progress Kok_a Kok_a_1 Kok_a_3 aok with ⟨v|err, h⟩,
      { exact prog (step.binop₃ h) },
      { exact prog (step.binop_err h) } },
    { rcases step_unop.progress Kok_a Kok_a_1 aok with ⟨v, h⟩,
      exact prog (step.unop₂ h) },
    { cases aok,
      exact prog step.cond₂ },
    { exact prog step.cons₂ },
    { exact prog step.cons₃ },
    { cases Kok,
      rcases Kok_a_6 with ext | ⟨τ, Δ, s, h⟩,
      { exact progresses.io
          (λ o, state.ret cont_ty.V ⟨o.1, S, η⟩ o.2 Kok_K)
          (λ ⟨H', v⟩, step.call_extern ext) },
      { cases step_call.progress ok Kok_a_5 h Kok_a_8 aok with η h',
        exact prog (step.call₂ h h') } },
    { cases step_deref.progress Eok σok ηok aok with s' h,
      exact prog (step.deref' h) },
    { cases aok,
      rcases alloc_arr.progress aok_1 with ⟨j, h⟩ | h,
      { cases value.default_exists ok.ind (sum.inl _) Kok_a_1 with v v0,
        exact prog (step.alloc_arr₂ h v0 ⟨⟩) },
      { exact prog (step.alloc_arr_err h) } } },
  case c0.state.ok.err : err { exact final state.final.err },
  case c0.state.ok.done : n { exact final state.final.done },
end

end c0


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

namespace Lean.Elab.Tactic
open Meta

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

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

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

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

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

/-
  `optConfig` is of the form `("(" "config" ":=" term ")")?`
  If `ctx == false`, the argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise. -/
def elabSimpConfig (optConfig : Syntax) (ctx : Bool) : TermElabM Meta.Simp.Config := do
  if ctx then
    return (← elabSimpConfigCtxCore optConfig).toConfig
  else
    elabSimpConfigCore optConfig

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

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

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

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

    syntax simpErase := "-" ident
    -/
    withMainContext do
      let mut thms    := ctx.simpTheorems
      let mut starArg := false
      for arg in stx[1].getSepArgs do
        if arg.getKind == ``Lean.Parser.Tactic.simpErase then
          if eraseLocal && (← Term.isLocalIdent? arg[1]).isSome then
            -- We use `eraseCore` because the simp theorem for the hypothesis was not added yet
            thms := thms.eraseCore arg[1].getId
          else
            let declName ← resolveGlobalConstNoOverloadWithInfo arg[1]
            thms ← thms.erase declName
        else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
          let post :=
            if arg[0].isNone then
              true
            else
              arg[0][0].getKind == ``Parser.Tactic.simpPost
          let inv  := !arg[1].isNone
          let term := arg[2]
          match (← resolveSimpIdTheorem? term) with
          | some e => thms ← addDeclToUnfoldOrTheorem thms e post inv
          | _      => thms ← addSimpTheorem thms term post inv
        else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
          starArg := true
        else
          throwUnsupportedSyntax
      return { ctx := { ctx with simpTheorems := thms }, starArg }
where
  resolveSimpIdTheorem? (simpArgTerm : Syntax) : TacticM (Option Expr) := do
    if simpArgTerm.isIdent then
      try
        Term.resolveId? simpArgTerm (withInfo := true)
      catch _ =>
        return none
    else
      Term.elabCDotFunctionAlias? simpArgTerm

-- TODO: move?
private def getPropHyps : MetaM (Array FVarId) := do
  let mut result := #[]
  for localDecl in (← getLCtx) do
    unless localDecl.isAuxDecl do
      if (← isProp localDecl.type) then
        result := result.push localDecl.fvarId
  return result

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

/--
  If `ctx == false`, the config argument is assumed to have type `Meta.Simp.Config`, and `Meta.Simp.ConfigCtx` otherwise.
  If `ctx == false`, the `discharge` option must be none -/
def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (ctx := false) (ignoreStarArg : Bool := false) : TacticM MkSimpContextResult := do
  if ctx && !stx[2].isNone then
    throwError "'simp_all' tactic does not support 'discharger' option"
  let dischargeWrapper ← mkDischargeWrapper stx[2]
  let simpOnly := !stx[3].isNone
  let simpTheorems ←
    if simpOnly then
      ({} : SimpTheorems).addConst ``eq_self
    else
      getSimpTheorems
  let congrTheorems ← getSimpCongrTheorems
  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) {
    config      := (← elabSimpConfig stx[1] (ctx := ctx))
    simpTheorems, congrTheorems
  }
  if !r.starArg || ignoreStarArg then
    return { r with fvarIdToLemmaId := {}, dischargeWrapper }
  else
    let ctx := r.ctx
    let erased := ctx.simpTheorems.erased
    let hs ← getPropHyps
    let mut ctx := ctx
    let mut fvarIdToLemmaId := {}
    for h in hs do
      let localDecl ← getLocalDecl h
      unless erased.contains localDecl.userName do
        let fvarId := localDecl.fvarId
        let proof  := localDecl.toExpr
        let id     ← mkFreshUserName `h
        fvarIdToLemmaId := fvarIdToLemmaId.insert fvarId id
        let simpTheorems ← ctx.simpTheorems.add #[] proof (name? := id)
        ctx := { ctx with simpTheorems }
    return { ctx, fvarIdToLemmaId, dischargeWrapper }

/--
`simpLocation ctx discharge? varIdToLemmaId loc`
runs the simplifier at locations specified by `loc`,
using the simp theorems collected in `ctx`
optionally running a discharger specified in `discharge?` on generated subgoals.
(Local hypotheses which have been added to the simp theorems must be recorded in
`fvarIdToLemmaId`.)

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

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

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

@[builtinTactic Lean.Parser.Tactic.simpAll] def evalSimpAll : Tactic := fun stx => do
  let { ctx, .. } ← mkSimpContext stx (eraseLocal := true) (ctx := true) (ignoreStarArg := true)
  match (← simpAll (← getMainGoal) ctx) with
  | none => replaceMainGoal []
  | some mvarId => replaceMainGoal [mvarId]

end Lean.Elab.Tactic


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

variables {a b c p : Prop}

namespace tactic.interactive

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

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

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

meta instance : decidable_eq mono_function :=
by mk_dec_eq_instance

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

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

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

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

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

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

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

open list (hiding map) functor dlist

section config

parameter opt : mono_cfg
parameter asms : list expr

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

universes u v

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

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

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

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

open monad

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

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

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

end config

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

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

open format mono_selection

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

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

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

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

Here is an example of mono:

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

More succinctly, we can prove the same goal as:

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

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

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

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

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

open sum nat

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

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

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

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

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

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

/--

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

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

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

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

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

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

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

`ac_mono` can be used as follows:

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

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

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

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

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

attribute [mono] and.imp or.imp

end tactic.interactive


import tactic
import .boolset2d
import .sokostate
import .boxint
import .sokolevel
import .sokowidget

def boxint.generate_from_list (avail : bset2d) (boxes blocks : list (ℕ × ℕ)) (sk : ℕ × ℕ) : boxint
:=
let boxes2d := (bset2d.from_indexes boxes) in
let blocks2d := (bset2d.from_indexes blocks) in
let subboxes := boxes2d ∩ avail in
let supboxes := (avail \ blocks2d) ∪ subboxes in
boxint.generate avail subboxes supboxes sk

def list.pall {α : Type} (P : α → Prop) : list α → Prop
| [] := true
| (h::t) := P h ∧ list.pall t
def list.pall_iff {α : Type} {P : α → Prop} {l : list α}
: list.pall P l ↔ (∀ a : α, a ∈ l → P a)
:=
begin
  induction l with h t IH, {
    split,
    { intros H a Hin, exfalso,
      exact list.not_mem_nil a Hin, },
    { intro H, trivial, }
  }, {
    split, {
      intros H a Hin,
      cases H with Hh Ht,
      cases Hin,
      rw Hin, exact Hh,
      exact IH.mp Ht a Hin,
    }, {
      intro H, split,
      { apply H, simp, },
      { apply IH.mpr,
        intros a Hin,
        apply H, right, exact Hin,
      }
    }
  }
end
lemma list.pall_in {α : Type} (l : list α)
: l.pall (λ a, a ∈ l) := list.pall_iff.mpr (λ a H, H)

namespace deadlocks

theorem boxint.generate_from_list_valid {avail : bset2d} {boxes blocks : list (ℕ × ℕ)} {sk : ℕ × ℕ}
: (boxint.generate_from_list avail boxes blocks sk).valid avail
:=
begin
  apply boxint.generate_valid, {
    exact bset2d.union_supset_right,
  }, {
    apply bset2d.union_subset,
    exact bset2d.sdiff_subset,
    exact bset2d.inter_subset_right,
  }
end

def deadlock (avail : bset2d) (goal : boxes_only) (as : boxint) : Prop
:= ∀ s1 s2 : sokostate, s1 ∈ as → s2 ∈ goal → s2.reachable avail s1 → false

meta def deadlock.to_html {avail : bset2d} {goal : boxes_only} {as : boxint}
  (H : deadlocks.deadlock avail goal as) : widget.html empty
  := sokowidget.build_table avail as.supboxes as.subboxes goal.boxes as.sk_comp

lemma new_deadlocks {avail : bset2d} {goal : boxes_only} {new_dls : list boxint}
: (∀ as : boxint, as ∈ new_dls →
  as.valid avail ∧ as.disjoint goal ∧
  (∀ as2 : boxint, as2 ∈ as.next_states avail →
  ∃ dl : boxint, as2.subset_g dl goal ∧ (dl ∈ new_dls ∨ deadlock avail goal dl))
) → (∀ as : boxint, as ∈ new_dls → deadlock avail goal as)
:=
begin
  intro H,
  intros as Has_in s1 sg Hs1 Hsg Hr,
  revert as,
  induction Hr with s1 d Hr IH,
  {
    assume as Has_in Hs,
    exact boxint.disjoint_correct as goal sg (H as Has_in).2.1 Hs Hsg,
  },
  {
    assume as Has_in Hs1,
    rcases H as Has_in with ⟨Hval, Hdisj, H⟩,
    cases boxint.next_of_real_move avail as Hval s1 d Hs1 with H1 H2,
    { exact IH as Has_in H1, }, -- no change in abstract state
    {
      rcases H2 with ⟨as2, Has2_next, Hin_as2⟩,
      rcases H as2 Has2_next with ⟨dl, Hdl_sup, Hdl⟩,
      let s2 := sokostate.move avail d s1,
      have : s2 ∈ dl
      := boxint.subset_g_correct Hdl_sup s2 sg Hin_as2 Hsg Hr,
      cases Hdl with Hdl_new Hdl_old,
      {
        clear H,
        exact IH dl Hdl_new this,
      },
      { apply Hdl_old s2 sg this Hsg Hr, }
    },
  }
end

lemma new_deadlock {avail : bset2d} {goal : boxes_only} {new_dl : boxint}
: (
  new_dl.valid avail ∧ new_dl.disjoint goal ∧
  (∀ as2 : boxint, as2 ∈ new_dl.next_states avail →
  ∃ dl : boxint, as2.subset_g dl goal ∧ deadlock avail goal dl)
) → deadlock avail goal new_dl
:=
begin
  rintros ⟨Hval, Hdisj, H⟩,
  have : (∀ as, as ∈ [new_dl] → deadlock avail goal as), {
    apply new_deadlocks,
    refine list.pall_iff.mp ⟨_, trivial⟩,
      refine ⟨Hval, Hdisj, _⟩,
      intros as2 Has2,
      rcases H as2 Has2 with ⟨dl, Hsub, Hdl⟩,
      existsi dl,
      split, exact Hsub,
      right, exact Hdl,
  },
  exact (list.pall_iff.mpr this).1,
end

--   _             _   _
--  | |_ __ _  ___| |_(_) ___ ___
--  | __/ _` |/ __| __| |/ __/ __|
--  | || (_| | (__| |_| | (__\__ \
--   \__\__,_|\___|\__|_|\___|___/
--

meta def and_placeholders : ℕ → pexpr
| 0 := ``(trivial)
| (n+1) := ``(and.intro %%(pexpr.mk_placeholder) %%(and_placeholders n))

meta def analyze_deadlock : tactic unit
:=
do
  tactic.refine ``(and.intro boxint.generate_from_list_valid
    (and.intro dec_trivial (list.pall_iff.mp _))),
  `(list.pall %%_ %%steps_list) ← tactic.target,
  num_steps ← tactic.eval_expr nat `(@list.length boxint %%steps_list),
  tactic.refine (and_placeholders num_steps),
  return ()

end deadlocks

meta def get_deadlock_of_step (t : expr) : tactic (expr × bool)
:=
(do
  `(deadlocks.deadlock %%e0 %%e1 %%e) ← tactic.whnf t reducible,
  return (e, ff)
) <|>
(do
  `(%%e ∈ %%e0) ← return t,
  return (e, tt)
)

meta def tactic.deadlocked_step (e : expr) : tactic unit :=
do
  t ← tactic.infer_type e,
  (dl, is_rep) ← get_deadlock_of_step t,
  tactic.refine ``(exists.intro %%dl (and.intro dec_trivial _)),
  if is_rep then tactic.left >> tactic.exact e
  else tactic.try tactic.right >> tactic.exact e

meta def tactic.interactive.deadlocked_step (q : interactive.parse interactive.types.texpr) : tactic unit
:= tactic.i_to_expr q >>= tactic.deadlocked_step


import ProofWidgets.Component.Basic

open ProofWidgets
open Lean Meta Server Elab Tactic

/-- A `MetaM String` continuation, containing both the computation and all monad state. -/
structure MetaMStringCont where
  ci : Elab.ContextInfo
  lctx : LocalContext
  -- We can only derive `TypeName` for type constants, so this must be monomorphic.
  k : MetaM String
  deriving TypeName

structure RunnerWidgetProps where
  /-- A continuation to run and print the results of when the button is clicked. -/
  k : WithRpcRef MetaMStringCont

-- Make it possible for widgets to receive `RunnerWidgetProps`. Uses the `TypeName` instance.
#mkrpcenc RunnerWidgetProps

@[server_rpc_method]
def runMetaMStringCont : RunnerWidgetProps → RequestM (RequestTask String)
  | {k := ⟨{ci, lctx, k}⟩} => RequestM.asTask do
    ci.runMetaM lctx k

@[widget_module]
def runnerWidget : Component RunnerWidgetProps where
  javascript := "
    import { RpcContext, mapRpcError } from '@leanprover/infoview'
    import * as React from 'react';
    const e = React.createElement;

    export default function(props) {
      const [contents, setContents] = React.useState('Run!')
      const rs = React.useContext(RpcContext)
      return e('button', { onClick: () => {
        setContents('Running..')
        rs.call('runMetaMStringCont', props)
          .then(setContents)
          .catch(e => { setContents(mapRpcError(e).message) })
      }}, contents)
    }
  "

syntax (name := makeRunnerTac) "make_runner" : tactic

@[tactic makeRunnerTac] def makeRunner : Tactic
  | `(tactic| make_runner%$tk) => do
    let x : MetaM String := do
      return "Hello, world!"
    -- Store the continuation and monad context.
    let props : RunnerWidgetProps := {
      k := ⟨{
        ci := (← ContextInfo.save)
        lctx := (← getLCtx)
        k := x
      }⟩}
    -- Save a widget together with a pointer to `props`.
    savePanelWidgetInfo tk ``runnerWidget (rpcEncode props)
  | _ => throwUnsupportedSyntax

example : True := by
  make_runner
  trivial


import Runtime.Reaction.Monad

/-
This file contains a variety of trivial lemmas about the monadic operations defined for `ReactionT`.
-/

namespace ReactionT

/--
This macro should be used by LF-users to prove theorems about reactions. It makes it possible to
write `input -[ReactorName.ReactionN]→ output` to express that running reaction number N of reactor
(class) `ReactorName` on a given `input` produces `output`.
-/
macro input:term:max " -[" rcn:ident "]→ " output:term:max : term => `(
  ($(Lean.mkIdentFrom rcn <| `LF ++ rcn.getId ++ `body) $input).fst = $output
)

-- TODO: https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Conditional.20Syntax/near/311857316
open Lean in
macro "mk_get_lemmas" op:ident field:ident var:"_"? : command => do
  let var := if var.isSome then #[mkIdent `var] else #[]
  let input := mkIdent `input
  let opApp ← `($op $[ $var ]* $input (m := Id)
    (σPS := $(mkIdent `σPS)) (σPE := $(mkIdent `σPE))
    (σAS := $(mkIdent `σAS)) (σAE := $(mkIdent `σAE))
    (σS  := $(mkIdent  `σS)) (σP  := $(mkIdent  `σP))
  )
  let lemmas := #[
    ("value",         ← `(($opApp).snd = $input.$field $[ $var ]*)),
    ("state",         ← `(($opApp).fst.state = $(input).state)),
    ("ports",         ← `(($opApp).fst.ports.isEmpty)),
    ("events",        ← `(($opApp).fst.events.isEmpty)),
    ("stopRequested", ← `(($opApp).fst.stopRequested = false)),
    ("writtenPorts",  ← `(($opApp).fst.writtenPorts.isEmpty))
  ]
  let commands ← lemmas.mapM fun ⟨suffix, property⟩ => `(
    @[simp] theorem $(mkIdentFrom op s!"{op.getId}_{suffix}") {$[ $var ]*} : $property := rfl
  )
  return ⟨mkNullNode commands⟩

open Lean in
macro "mk_set_lemma" op:ident suffix:ident " : " prop:term : command => `(
  @[simp] theorem $(mkIdentFrom op s!"{op.getId}_{suffix.getId}") : $prop := by
    simp [$op:ident]; first | done | rfl | intro h; simp [h]
)

mk_get_lemmas getInput       ports   _
mk_get_lemmas getState       state   _
mk_get_lemmas getAction      actions _
mk_get_lemmas getParam       params  _
mk_get_lemmas getTag         tag
mk_get_lemmas getLogicalTime time

mk_set_lemma setOutput state : (setOutput (m := Id) (σAE := σAE) var val input).fst.state = input.state
mk_set_lemma setOutput same_port : (setOutput (m := Id) (σAE := σAE) var val input).fst.ports var = val

@[simp] theorem setOutput_other_port {var' var val} : (var' ≠ var) →
  (setOutput (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.ports var' = none :=
  by simp [setOutput]; first | done | rfl | intro h; simp [h]

mk_set_lemma setOutput events : (setOutput (m := Id) (σAE := σAE) var val input).fst.events.isEmpty
mk_set_lemma setOutput stopRequested : (setOutput (m := Id) (σAE := σAE) var val input).fst.stopRequested = false
mk_set_lemma setOutput writtenPorts : (setOutput (m := Id) (σAE := σAE) var val input).fst.writtenPorts = #[var]

mk_set_lemma setState same_state : (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.state var = val

@[simp] theorem setState_other_state {var' var val} : (var' ≠ var) →
  (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.state var' = input.state var' :=
  by simp [setState]; first | done | rfl | intro h; simp [h]

mk_set_lemma setState ports : (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.ports.isEmpty
mk_set_lemma setState events : (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.events.isEmpty
mk_set_lemma setState stopRequested : (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.stopRequested = false
mk_set_lemma setState writtenPorts : (setState (m := Id) (σPE := σPE) (σAE := σAE) var val input).fst.writtenPorts.isEmpty

-- TODO: Lemmas for `schedule` and `requestStop`.

end ReactionT


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import Init.Control.Basic
import Init.Data.List.Basic

namespace List
universe u v w u₁ u₂

/-!
Remark: we can define `mapM`, `mapM₂` and `forM` using `Applicative` instead of `Monad`.
Example:
```
def mapM {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
  | []    => pure []
  | a::as => List.cons <$> (f a) <*> mapM as
```

However, we consider `f <$> a <*> b` an anti-idiom because the generated code
may produce unnecessary closure allocations.
Suppose `m` is a `Monad`, and it uses the default implementation for `Applicative.seq`.
Then, the compiler expands `f <$> a <*> b <*> c` into something equivalent to
```
(Functor.map f a >>= fun g_1 => Functor.map g_1 b) >>= fun g_2 => Functor.map g_2 c
```
In an ideal world, the compiler may eliminate the temporary closures `g_1` and `g_2` after it inlines
`Functor.map` and `Monad.bind`. However, this can easily fail. For example, suppose
`Functor.map f a >>= fun g_1 => Functor.map g_1 b` expanded into a match-expression.
This is not unreasonable and can happen in many different ways, e.g., we are using a monad that
may throw exceptions. Then, the compiler has to decide whether it will create a join-point for
the continuation of the match or float it. If the compiler decides to float, then it will
be able to eliminate the closures, but it may not be feasible since floating match expressions
may produce exponential blowup in the code size.

Finally, we rarely use `mapM` with something that is not a `Monad`.

Users that want to use `mapM` with `Applicative` should use `mapA` instead.
-/

@[inline]
def mapM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) (as : List α) : m (List β) :=
  let rec @[specialize] loop
    | [],      bs => pure bs.reverse
    | a :: as, bs => do loop as ((← f a)::bs)
  loop as []

@[specialize]
def mapA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
  | []    => pure []
  | a::as => List.cons <$> f a <*> mapA f as

@[specialize]
protected def forM {m : Type u → Type v} [Monad m] {α : Type w} (as : List α) (f : α → m PUnit) : m PUnit :=
  match as with
  | []      => pure ⟨⟩
  | a :: as => do f a; List.forM as f

@[specialize]
def forA {m : Type u → Type v} [Applicative m] {α : Type w} (as : List α) (f : α → m PUnit) : m PUnit :=
  match as with
  | []      => pure ⟨⟩
  | a :: as => f a *> forA as f

@[specialize]
def filterAuxM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) : List α → List α → m (List α)
  | [],     acc => pure acc
  | h :: t, acc => do
    let b ← f h
    filterAuxM f t (cond b (h :: acc) acc)

@[inline]
def filterM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) (as : List α) : m (List α) := do
  let as ← filterAuxM f as []
  pure as.reverse

@[inline]
def filterRevM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) (as : List α) : m (List α) :=
  filterAuxM f as.reverse []

@[inline]
def filterMapM {m : Type u → Type v} [Monad m] {α β : Type u} (f : α → m (Option β)) (as : List α) : m (List β) :=
  let rec @[specialize] loop
    | [],     bs => pure bs
    | a :: as, bs => do
      match (← f a) with
      | none   => loop as bs
      | some b => loop as (b::bs)
  loop as.reverse []

@[specialize]
protected def foldlM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (f : s → α → m s) → (init : s) → List α → m s
  | _, s, []      => pure s
  | f, s, a :: as => do
    let s' ← f s a
    List.foldlM f s' as

@[inline]
def foldrM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} (f : α → s → m s) (init : s) (l : List α) : m s :=
  l.reverse.foldlM (fun s a => f a s) init

@[specialize]
def firstM {m : Type u → Type v} [Alternative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m β
  | []    => failure
  | a::as => f a <|> firstM f as

@[specialize]
def anyM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
  | []    => pure false
  | a::as => do
    match (← f a) with
    | true  => pure true
    | false => anyM f as

@[specialize]
def allM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
  | []    => pure true
  | a::as => do
    match (← f a) with
    | true  => allM f as
    | false => pure false

@[specialize]
def findM? {m : Type → Type u} [Monad m] {α : Type} (p : α → m Bool) : List α → m (Option α)
  | []    => pure none
  | a::as => do
    match (← p a) with
    | true  => pure (some a)
    | false => findM? p as

@[specialize]
def findSomeM? {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m (Option β)) : List α → m (Option β)
  | []    => pure none
  | a::as => do
    match (← f a) with
    | some b => pure (some b)
    | none   => findSomeM? f as

@[inline] protected def forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : α → β → m (ForInStep β)) : m β :=
  let rec @[specialize] loop
    | [], b    => pure b
    | a::as, b => do
      match (← f a b) with
      | ForInStep.done b  => pure b
      | ForInStep.yield b => loop as b
  loop as init

instance : ForIn m (List α) α where
  forIn := List.forIn

@[simp] theorem forIn_nil [Monad m] (f : α → β → m (ForInStep β)) (b : β) : forIn [] b f = pure b :=
  rfl

@[simp] theorem forIn_cons [Monad m] (f : α → β → m (ForInStep β)) (a : α) (as : List α) (b : β)
    : forIn (a::as) b f = f a b >>= fun | ForInStep.done b => pure b | ForInStep.yield b => forIn as b f :=
  rfl

@[inline] protected def forIn' {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : (a : α) → a ∈ as → β → m (ForInStep β)) : m β :=
  let rec @[specialize] loop : (as' : List α) → (b : β) → Exists (fun bs => bs ++ as' = as) → m β
    | [], b, _    => pure b
    | a::as', b, h => do
      have : a ∈ as := by
        have ⟨bs, h⟩ := h
        subst h
        exact mem_append_of_mem_right _ (Mem.head ..)
      match (← f a this b) with
      | ForInStep.done b  => pure b
      | ForInStep.yield b =>
        have : Exists (fun bs => bs ++ as' = as) := have ⟨bs, h⟩ := h; ⟨bs ++ [a], by rw [← h, append_cons bs a as']⟩
        loop as' b this
  loop as init ⟨[], rfl⟩

instance : ForIn' m (List α) α inferInstance where
  forIn' := List.forIn'

@[simp] theorem forIn'_eq_forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : α → β → m (ForInStep β)) : forIn' as init (fun a _ b => f a b) = forIn as init f := by
  simp [forIn', forIn, List.forIn, List.forIn']
  have : ∀ cs h, List.forIn'.loop cs (fun a _ b => f a b) as init h = List.forIn.loop f as init := by
    intro cs h
    induction as generalizing cs init with
    | nil => intros; rfl
    | cons a as ih => intros; simp [List.forIn.loop, List.forIn'.loop, ih]
  apply this

instance : ForM m (List α) α where
  forM := List.forM

@[simp] theorem forM_nil  [Monad m] (f : α → m PUnit) : forM [] f = pure ⟨⟩ :=
  rfl
@[simp] theorem forM_cons [Monad m] (f : α → m PUnit) (a : α) (as : List α) : forM (a::as) f = f a >>= fun _ => forM as f :=
  rfl

instance : Functor List where
  map := List.map

end List